The Trunk: Monticello-jr.663.mcz

David T. Lewis uploaded a new version of Monticello to project The Trunk:
http://source.squeak.org/trunk/Monticello-jr.663.mcz

==================== Summary ====================

Name: Monticello-jr.663
Author: jr
Time: 28 February 2017, 3:23:47.576081 am
UUID: a39bff3c-bb90-704a-bbdc-1c9ce084747b
Ancestors: Monticello-ul.662

add environments support to Monticello

Neither PackageInfo nor MCPackage are naturally bound to an environment,
so choose MCWorkingCopy as the keeper of one.
To make sure that an MCPackage creates its snapshot
from the correct environment, wrap a working copy's
package in a decorator that activates the environment
when a snapshot is requested.
This is kind of hacky, but otherwise all senders of #snapshot
would have to take care to activate the correct environment.
It would be complicated because there is code breaking the Law of Demeter as follows:
     aWorkingCopyOrVersion package snapshot

So with this solution, be sure to snapshot/load via the working copy if possible.

Add a 'change environment' menu item to the working copies list.
Afterwards, snapshots will be taken in the chosen environment,
and new code will be compiled in it.

Add a 'load into other environment' menu item to snapshot browsers.

Depends on Compiler-jr.329 for compiling text in other environments,
on Environments-jr.71 for choosing an environment,
and Tools-jr.745 would help enable system navigation independently from this version.

=============== Diff against Monticello-ul.662 ===============

Item was changed:
  SystemOrganization addCategory: #'Monticello-Base'!
  SystemOrganization addCategory: #'Monticello-Chunk Format'!
  SystemOrganization addCategory: #'Monticello-Loading'!
  SystemOrganization addCategory: #'Monticello-Merging'!
  SystemOrganization addCategory: #'Monticello-Modeling'!
  SystemOrganization addCategory: #'Monticello-Patching'!
  SystemOrganization addCategory: #'Monticello-Repositories'!
  SystemOrganization addCategory: #'Monticello-Storing'!
  SystemOrganization addCategory: #'Monticello-UI'!
  SystemOrganization addCategory: #'Monticello-Versioning'!
+ SystemOrganization addCategory: #'Monticello-Environments'!

Item was added:
+ ----- Method: Environment>>provisions (in category '*Monticello-Loading') -----
+ provisions
+ "In contrast to #keys, return also the imported names"
+ ^ bindings keys!

Item was changed:
  ----- Method: MCClassDefinition>>actualClass (in category 'accessing') -----
  actualClass
+ ^ self actualClassIn: Environment current!
- ^Smalltalk classNamed: self className!

Item was added:
+ ----- Method: MCClassDefinition>>actualClassIn: (in category 'accessing') -----
+ actualClassIn: anEnvironment
+ ^anEnvironment classNamed: self className!

Item was changed:
  ----- Method: MCClassDefinition>>createClass (in category 'installing') -----
  createClass
+ | environment superClass class composition |
+ environment := Environment current.
- | superClass class composition |
  superClass := superclassName == #nil ifFalse:
+ [environment valueOf: superclassName
+ ifAbsent: [(KeyNotFound key: superclassName) signal]].
- [Smalltalk at: superclassName].
  [class := (ClassBuilder new)
  name: name
+ inEnvironment: environment
- inEnvironment: (CurrentEnvironment signal ifNil: [superClass environment])
  subclassOf: superClass
  type: type
  instanceVariableNames: self instanceVariablesString
  classVariableNames: self classVariablesString
  poolDictionaries: self sharedPoolsString
  category: category.
  ] on: Warning, DuplicateVariableError do:[:ex| ex resume].
 
  "The following is written to support traits unloading"
  composition := self traitComposition ifNil: [Array new] ifNotNil: [:traitComposition | Compiler evaluate: traitComposition].
  (composition isCollection and:[composition isEmpty and:[class traitComposition isEmpty]]) ifFalse:[
  class setTraitComposition: composition asTraitComposition.
  ].
 
  composition := self classTraitComposition ifNil: [Array new] ifNotNil: [:traitComposition | Compiler evaluate: traitComposition].
  (composition isCollection and:[composition isEmpty and:[class class traitComposition isEmpty]]) ifFalse:[
  class class setTraitComposition: composition asTraitComposition.
  ].
 
  ^class!

Item was changed:
  ----- Method: MCClassDefinition>>unload (in category 'installing') -----
  unload
+ Environment current removeClassNamed: name!
- Smalltalk removeClassNamed: name!

Item was changed:
  MCTool subclass: #MCCodeTool
+ instanceVariableNames: 'items environmentInDisplayingImage'
- instanceVariableNames: 'items'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Monticello-UI'!
 
  !MCCodeTool commentStamp: 'nk 11/10/2003 22:00' prior: 0!
  MCCodeTool is an abstract superclass for those Monticello browsers that display code.
  It contains copies of the various CodeHolder methods that perform the various menu operations in the method list.
  !

Item was added:
+ ----- Method: MCCodeTool>>environmentInDisplayingImage (in category 'accessing') -----
+ environmentInDisplayingImage
+ ^ environmentInDisplayingImage ifNil: [Smalltalk globals]!

Item was added:
+ ----- Method: MCCodeTool>>environmentInDisplayingImage: (in category 'accessing') -----
+ environmentInDisplayingImage: anEnvironment
+ environmentInDisplayingImage := anEnvironment!

Item was added:
+ ----- Method: MCDefinition>>actualClassIn: (in category 'accessing') -----
+ actualClassIn: anEnvironment
+
+ ^nil!

Item was changed:
  ----- Method: MCMethodDefinition>>actualClass (in category 'accessing') -----
  actualClass
+ ^ self actualClassIn: Environment current!
- ^Smalltalk at: className ifPresent: [:class |
- class isBehavior ifTrue: [classIsMeta ifTrue: [class classSide] ifFalse: [class]]]!

Item was added:
+ ----- Method: MCMethodDefinition>>actualClassIn: (in category 'accessing') -----
+ actualClassIn: anEnvironment
+ ^ (anEnvironment at: className ifAbsent: [anEnvironment valueOf: className])
+ ifNotNil: [:class |
+ class isBehavior ifTrue: [classIsMeta ifTrue: [class classSide] ifFalse: [class]]]!

Item was changed:
  ----- Method: MCOperationsBrowser>>revertSelection (in category 'actions') -----
  revertSelection
  | loader |
  selection ifNotNil:
  [loader := MCPackageLoader new.
  selection inverse applyTo: loader.
+ self environmentInDisplayingImage beCurrentDuring: [loader loadWithName: self changeSetNameForInstall].
- loader loadWithName: self changeSetNameForInstall.
  self reverts add: selection.
  self
  advanceSelection;
  changed: #list ]!

Item was changed:
  ----- Method: MCOperationsBrowser>>selectedClass (in category 'subclassResponsibility') -----
  selectedClass
  | definition |
  selection ifNil: [ ^nil ].
  (definition := selection definition) ifNil: [ ^nil ].
  definition isMethodDefinition ifFalse: [ ^nil ].
+ definition className in: [:className | | environment |
+ environment := self environmentInDisplayingImage.
+ ^ environment at: className ifAbsent: [environment valueOf: className]]!
- ^Smalltalk at: definition className ifAbsent: [ ]!

Item was changed:
  ----- Method: MCOperationsBrowser>>selectedClassOrMetaClass (in category 'subclassResponsibility') -----
  selectedClassOrMetaClass
  | definition |
  selection ifNil: [ ^nil ].
  (definition := selection definition) ifNil: [ ^nil ].
  (definition isMethodDefinition or: [definition isClassDefinition]) ifFalse: [ ^nil ].
+ ^ definition actualClassIn: self environmentInDisplayingImage!
- ^definition actualClass!

Item was added:
+ ----- Method: MCPackage>>inEnvironment: (in category 'environments') -----
+ inEnvironment: anEnvironment
+ "Answer a decorator for me that activates anEnvironment for certain operations."
+ ^ MCPackageInEnvironment decorating: self in: anEnvironment!

Item was changed:
  ----- Method: MCPackage>>packageInfo (in category 'accessing') -----
  packageInfo
+ "Activate my working copy's environment so the PackageInfo is added to the
+ correct EnvironmentInfo's packages."
+ | getPackageInfo |
+ getPackageInfo := [PackageInfo named: name].
+ ^ self hasWorkingCopy
+ ifTrue: [self workingCopy withEnvironmentActiveDo: getPackageInfo]
+ ifFalse: getPackageInfo!
- ^ PackageInfo named: name!

Item was added:
+ ProtoObject subclass: #MCPackageInEnvironment
+ instanceVariableNames: 'package environment'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Monticello-Environments'!
+
+ !MCPackageInEnvironment commentStamp: 'jr 2/27/2017 23:05' prior: 0!
+ I am a decorator for an MCPackage, activating an Environment for relevant operations.
+
+ Instance Variables
+ environment: <Environment> should be the current one for some of my operations
+ package: <MCPackage> my substance!

Item was added:
+ ----- Method: MCPackageInEnvironment class>>decorating:in: (in category 'instance creation') -----
+ decorating: aPackage in: anEnvironment
+ | instance |
+ instance := self new.
+ instance initializeWithPackage: aPackage in: anEnvironment.
+ ^ instance!

Item was added:
+ ----- Method: MCPackageInEnvironment>>basicInspect (in category 'object behavior') -----
+ basicInspect
+ "Create and schedule an Inspector in which the user can examine the
+ receiver's variables. This method should not be overriden."
+ ^ToolSet basicInspect: self!

Item was added:
+ ----- Method: MCPackageInEnvironment>>doesNotUnderstand: (in category 'delegating') -----
+ doesNotUnderstand: aMessage
+ ^ aMessage sendTo: package!

Item was added:
+ ----- Method: MCPackageInEnvironment>>environment (in category 'accessing') -----
+ environment
+
+ ^ environment!

Item was added:
+ ----- Method: MCPackageInEnvironment>>environment: (in category 'accessing') -----
+ environment: anObject
+
+ environment := anObject!

Item was added:
+ ----- Method: MCPackageInEnvironment>>inEnvironment: (in category 'initialize-release') -----
+ inEnvironment: anEnvironment
+ environment == anEnvironment ifTrue: [^ self].
+ ^ MCPackageInEnvironment decorating: package in: anEnvironment!

Item was added:
+ ----- Method: MCPackageInEnvironment>>initializeWithPackage:in: (in category 'initialize-release') -----
+ initializeWithPackage: aPackage in: anEnvironment
+ package := aPackage.
+ environment := anEnvironment.!

Item was added:
+ ----- Method: MCPackageInEnvironment>>respondsTo: (in category 'delegating') -----
+ respondsTo: aSymbol
+ ^ (MCPackageInEnvironment canUnderstand: aSymbol)
+ or: [package respondsTo: aSymbol]!

Item was added:
+ ----- Method: MCPackageInEnvironment>>snapshot (in category 'input/output') -----
+ snapshot
+ ^ environment beCurrentDuring: [package snapshot]!

Item was changed:
  ----- Method: MCPackageLoader>>provisions (in category 'private') -----
  provisions
+ ^ provisions ifNil: [provisions := Set withAll: Environment current provisions] !
- ^ provisions ifNil: [provisions := Set withAll: Smalltalk globals keys]!

Item was changed:
  ----- Method: MCPackageManager>>initializeWithPackage: (in category 'initialize-release') -----
  initializeWithPackage: aPackage
+ package := aPackage inEnvironment: Environment current.
- package := aPackage.
  self initialize.!

Item was changed:
  ----- Method: MCSnapshotBrowser>>classListMenu: (in category 'menus') -----
  classListMenu: aMenu
  classSelection ifNil: [ ^aMenu ].
 
  super classListMenu: aMenu.
 
  aMenu
  addLine;
  add: ('load class {1}' translated format: {classSelection})
+ action: #loadClassSelection;
+ add: ('load class {1} into other Environment...' translated format: {classSelection})
+ action: #loadClassSelectionIntoOtherEnvironment.
- action: #loadClassSelection.
  ^ aMenu!

Item was added:
+ ----- Method: MCSnapshotBrowser>>loadClassSelectionIntoOtherEnvironment (in category 'menus') -----
+ loadClassSelectionIntoOtherEnvironment
+ | env |
+ classSelection ifNil: [ ^self ].
+ env := EnvironmentRequest signal.
+ env beCurrentDuring: [
+ (self packageClasses detect: [ :ea | ea className = classSelection ] ifNone: [ ^self ])
+ load.
+ self methodsForSelectedClass do: [ :m | m load ]].!

Item was changed:
  ----- Method: MCSnapshotBrowser>>selectedClass (in category 'accessing') -----
  selectedClass
+ | environment |
  classSelection ifNil: [ ^nil ].
+ environment := self environmentInDisplayingImage.
+ ^ environment at: classSelection ifAbsent: [environment valueOf: classSelection]
- ^Smalltalk at: classSelection ifAbsent: [ nil ].
  !

Item was changed:
  ----- Method: MCTraitDefinition>>createClass (in category 'visiting') -----
  createClass
  ^ClassDescription
  newTraitNamed: name
  uses: (Compiler evaluate: self traitCompositionString)
  category: category
+ in: Environment current
 
  !

Item was changed:
  ----- Method: MCVersion>>load (in category 'actions') -----
  load
+ self workingCopy withEnvironmentActiveDo: [MCVersionLoader loadVersion: self]!
- MCVersionLoader loadVersion: self!

Item was changed:
  ----- Method: MCVersion>>merge (in category 'actions') -----
  merge
+ self workingCopy withEnvironmentActiveDo: [MCVersionMerger mergeVersion: self]!
- MCVersionMerger mergeVersion: self!

Item was changed:
  MCPackageManager subclass: #MCWorkingCopy
+ instanceVariableNames: 'versionInfo ancestry counter repositoryGroup requiredPackages environment'
- instanceVariableNames: 'versionInfo ancestry counter repositoryGroup requiredPackages'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Monticello-Versioning'!

Item was added:
+ ----- Method: MCWorkingCopy>>environment (in category 'accessing') -----
+ environment
+ ^ environment ifNil: [Smalltalk globals]!

Item was added:
+ ----- Method: MCWorkingCopy>>environment: (in category 'accessing') -----
+ environment: anEnvironment
+ "Anything that is loaded to me should go into anEnvironment from now on."
+ environment := anEnvironment.
+ package := package inEnvironment: anEnvironment.!

Item was changed:
  ----- Method: MCWorkingCopy>>unload (in category 'operations') -----
  unload
+ self withEnvironmentActiveDo: [MCPackageLoader unloadPackage: self package].
- MCPackageLoader unloadPackage: self package.
  self unregisterSubpackages.
  self unregister.!

Item was added:
+ ----- Method: MCWorkingCopy>>withEnvironmentActiveDo: (in category 'private') -----
+ withEnvironmentActiveDo: aBlock
+ ^ self environment beCurrentDuring: aBlock!

Item was added:
+ ----- Method: MCWorkingCopyBrowser>>changeEnvironment (in category 'actions') -----
+ changeEnvironment
+ workingCopy ifNil: [^ self].
+ workingCopy environment: EnvironmentRequest signal!

Item was changed:
  ----- Method: MCWorkingCopyBrowser>>viewChanges (in category 'actions') -----
  viewChanges
  | patch |
  self canSave ifTrue:
  [patch := workingCopy changesRelativeToRepository: self repository.
  patch isNil ifTrue: [^ self].
  patch isEmpty
  ifTrue: [ workingCopy modified: false.
  self inform: 'No changes' ]
  ifFalse:
  [ workingCopy modified: true.
  (MCPatchBrowser forPatch: patch)
  label: 'Patch Browser: ', workingCopy description;
+ environmentInDisplayingImage: workingCopy environment;
  show]]!

Item was changed:
  ----- Method: MCWorkingCopyBrowser>>workingCopyListMenu: (in category 'morphic ui') -----
  workingCopyListMenu: aMenu
  workingCopy ifNil: [^ aMenu].
  self fillMenu: aMenu fromSpecs:
  #(('add required package' #addRequiredPackage)
  ('clear required packages' #clearRequiredPackages)
  ('add repository...' #addPackageRepository)
  ('browse package' #browseWorkingCopy)
  ('view changes' #viewChanges)
  ('view history' #viewHistory)
  ('search history' #searchHistory)
  ('recompile package' #recompilePackage)
  ('revert package...' #revertPackage)
  ('unload package' #unloadPackage)
  ('delete working copy' #deleteWorkingCopy)
  ('inspect working copy' #inspectWorkingCopy)
+ ('rename package...' #renamePackage)
+ ('change environment...' #changeEnvironment)).
- ('rename package...' #renamePackage)).
  (Smalltalk includesKey: #SARMCPackageDumper) ifTrue: [
  aMenu add: 'make SAR' target: self selector: #fileOutAsSAR
  ].
  self fillMenu: aMenu fromSpecs:
  #( addLine
  ('check all packages for changes' #checkAllPackages)).
  self insertExternalMenuEntries: aMenu.
  ^aMenu!

Item was changed:
  ----- Method: MethodAddition>>createCompiledMethod (in category 'as yet unclassified') -----
  createCompiledMethod
  | notification |
  [methodAndNode := myClass
  compile: text asString
+ environment: Environment current
  notifying: requestor
  trailer: (myClass defaultMethodTrailerIfLogSource: logSource)
  ifFail: [^nil]]
  on: SyntaxErrorNotification do: [:exc |
  notification := exc.
  exc pass].
  notification ifNotNil: [notification newSource ifNotNil: [:newSource | text := newSource]].
  selector := methodAndNode selector.
  compiledMethod := methodAndNode method.
  self writeSourceToLog.
  priorMethodOrNil := myClass compiledMethodAt: selector ifAbsent: [nil].
  !