The Trunk: Tools-jr.745.mcz

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

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

Name: Tools-jr.745
Author: jr
Time: 28 February 2017, 2:20:44.822081 am
UUID: c3e3bfae-ac2c-0d4e-a606-c41b7d388d67
Ancestors: Tools-cmm.744

improve Tools support for environments

allows...
- navigating senders/implementors
- using the hierarchy browser
- defining new classes and traits
- enjoying a Workspace
...in other environments

Also ensure all objects understand #environment, so tools can send it without fear.

Depends on ToolBuilder-Kernel-jr.109 for choosing something in 'find class'.

=============== Diff against Tools-cmm.744 ===============

Item was changed:
  ----- Method: Browser>>copyClass (in category 'class functions') -----
  copyClass
  | originalClass originalName copysName |
  self hasClassSelected ifFalse: [^ self].
  self okToChange ifFalse: [^ self].
  originalClass := self selectedClass.
  originalName := originalClass name.
  copysName := self request: 'Please type new class name' initialAnswer: originalName.
  copysName = '' ifTrue: [^ self].  " Cancel returns '' "
  copysName := copysName asSymbol.
  copysName = originalName ifTrue: [^ self].
+ (self environment hasClassNamed: copysName)
- (Smalltalk hasClassNamed: copysName)
  ifTrue: [^ self error: copysName , ' already exists'].
  Cursor wait showWhile: [
  | newDefinition newMetaDefinition newClass |
  newDefinition := originalClass definition
  copyReplaceAll: originalName printString
  with: copysName printString.
+ newClass := Compiler evaluate: newDefinition environment: self environment
+ logged: true.
- newClass := Compiler evaluate: newDefinition logged: true.
  newMetaDefinition := originalClass class definition
  copyReplaceAll: originalClass class name
  with: newClass class name.
+ Compiler evaluate: newMetaDefinition environment: self environment
+ logged: true.
- Compiler evaluate: newMetaDefinition logged: true.
  newClass copyAllCategoriesFrom: originalClass.
  newClass class copyAllCategoriesFrom: originalClass class.
  originalClass hasComment ifTrue: [
  newClass comment: originalClass comment ] ].
  self classListIndex: 0.
  self changed: #classList!

Item was changed:
  ----- Method: Browser>>defineClass:notifying: (in category 'class functions') -----
  defineClass: defString notifying: aController  
  "The receiver's textual content is a request to define a new class. The
  source code is defString. If any errors occur in compilation, notify
  aController."
  | oldClass class newClassName defTokens keywdIx envt |
  oldClass := self selectedClassOrMetaClass.
  defTokens := defString findTokens: Character separators.
 
  ((defTokens first = 'Trait' and: [defTokens second = 'named:'])
  or: [defTokens second = 'classTrait'])
  ifTrue: [^self defineTrait: defString notifying: aController].
 
  keywdIx := defTokens findFirst: [:x | x beginsWith: 'category'].
+ envt := self selectedEnvironment.
- envt := Smalltalk.
  keywdIx := defTokens findFirst: [:x | '*subclass*' match: x].
  newClassName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
  ((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName])
  and: [envt includesKey: newClassName asSymbol]) ifTrue:
  ["Attempting to define new class over existing one when
  not looking at the original one in this browser..."
  (self confirm: ((newClassName , ' is an existing class in this system.
  Redefining it might cause serious problems.
  Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size))
  ifFalse: [^ false]].
  "ar 8/29/1999: Use oldClass superclass for defining oldClass
  since oldClass superclass knows the definerClass of oldClass."
  oldClass ifNotNil:[oldClass := oldClass superclass].
+ class := envt beCurrentDuring:
+ [oldClass subclassDefinerClass
- class := oldClass subclassDefinerClass
  evaluate: defString
+ in: envt
  notifying: aController
+ logged: false].
- logged: false.
  (class isKindOf: Behavior)
  ifTrue: [self changed: #systemCategoryList.
  self changed: #classList.
  self clearUserEditFlag.
  self setClass: class selector: nil.
  "self clearUserEditFlag; editClass."
  ^ true]
  ifFalse: [^ false]!

Item was changed:
  ----- Method: Browser>>defineTrait:notifying: (in category 'traits') -----
  defineTrait: defString notifying: aController  
 
  | defTokens keywdIx envt oldTrait newTraitName trait |
  oldTrait := self selectedClassOrMetaClass.
  defTokens := defString findTokens: Character separators.
  keywdIx := defTokens findFirst: [:x | x = 'category'].
  envt := self selectedEnvironment.
  keywdIx := defTokens findFirst: [:x | x = 'named:'].
  newTraitName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
  ((oldTrait isNil or: [oldTrait baseTrait name asString ~= newTraitName])
  and: [envt includesKey: newTraitName asSymbol]) ifTrue:
  ["Attempting to define new class/trait over existing one when
  not looking at the original one in this browser..."
  (self confirm: ((newTraitName , ' is an existing class/trait in this system.
  Redefining it might cause serious problems.
  Is this really what you want to do?') asText makeBoldFrom: 1 to: newTraitName size))
  ifFalse: [^ false]].
 
+ trait := envt beCurrentDuring:
+ [Compiler evaluate: defString in: envt notifying: aController logged: true].
- trait := Compiler evaluate: defString notifying: aController logged: true.
  ^(trait isTrait)
  ifTrue: [
  self changed: #classList.
  self classListIndex: (self classListIndexOf: trait baseTrait name).
  self clearUserEditFlag; editClass.
  true]
  ifFalse: [ false ]
  !

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

Item was changed:
  ----- Method: Browser>>findClass (in category 'system category functions') -----
  findClass
  "Search for a class by name."
 
  | foundClass |
  (self multiWindowState notNil
  or: [self okToChange]) ifFalse:
  [^self classNotFound].
+ foundClass := UIManager default chooseClassOrTraitFrom: self environment.
- foundClass := UIManager default chooseClassOrTrait.
  foundClass ifNil: [^self classNotFound].
  (self selectedClass notNil
  and: [self multiWindowState notNil
  "Can only support multi-window if original window has all the right panes."
  and: [self multiWindowState prototype isHierarchy not]]) ifTrue:
  [(self classList includes: foundClass name)
  ifTrue: [self multiWindowState copyWindow]
  ifFalse: [self multiWindowState addNewWindow]].
    self selectCategoryForClass: foundClass.
  self selectClass: foundClass!

Item was changed:
  ----- Method: Browser>>hierarchicalClassList (in category 'class list') -----
  hierarchicalClassList
 
  "classNames are an arbitrary collection of classNames of the system.
  Reorder those class names so that they are sorted and indended by inheritance"
  | classes |
  "Creating the hierarchy is *really slow* for the full class list. Skip it for now."
  self selectedSystemCategory = SystemOrganizer allCategory
  ifTrue: [^ self defaultClassList].
 
+ classes := self defaultClassList collect: [:sym | self environment classNamed: sym].
- classes := self defaultClassList collect: [:sym | Smalltalk classNamed: sym].
  ^ self
  flattenHierarchyTree: (self createHierarchyTreeOf: classes)
  on: OrderedCollection new
  indent: ''.!

Item was changed:
  ----- Method: Browser>>selectedClass (in category 'class list') -----
  selectedClass
  "Answer the class that is currently selected. Answer nil if no selection
  exists."
 
  | name envt |
  (name := self selectedClassName) ifNil: [^ nil].
  (envt := self selectedEnvironment) ifNil: [^ nil].
+ ^ envt at: name ifAbsent: [envt valueOf: name ifAbsent: [nil]]!
- ^ envt at: name ifAbsent: [nil]!

Item was changed:
  ----- Method: Browser>>selectedEnvironment (in category 'system category list') -----
  selectedEnvironment
+ "Answer the browsed environment. If this returned a system category dependent
+ value and possibly nil (as it did in previous versions), selectedClass would not work in
+ a hierarchy browser that has to display classes from different environments
+ (because the correct categories might be missing in the browser)"
- "Answer the name of the selected system category or nil."
 
+ ^ environment ifNil: [Smalltalk globals]!
- self hasSystemCategorySelected ifFalse: [^nil].
- ^ environment ifNil: [Smalltalk]!

Item was changed:
  ----- Method: ChangeList>>diffedVersionContents (in category 'viewing access') -----
  diffedVersionContents
  "Answer diffed version contents, maybe pretty maybe not"
 
  | change class earlier later |
  (listIndex = 0
  or: [changeList size < listIndex])
  ifTrue: [^ ''].
  change := changeList at: listIndex.
  later := change text.
+ class := change methodClass: self environment.
- class := change methodClass.
  (listIndex == changeList size or: [class == nil])
  ifTrue: [^ (self showingPrettyDiffs and: [class notNil])
  ifTrue: [class prettyPrinterClass format: later in: class notifying: nil]
  ifFalse: [later]].
 
  earlier := (changeList at: listIndex + 1) text.
 
  ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs!

Item was changed:
  ----- Method: ChangeList>>fileInSelections (in category 'menu actions') -----
  fileInSelections
  | any |
  any := false.
+ self selectedClass environment beCurrentDuring: [
+ listSelections with: changeList do:
+ [:selected :item | selected ifTrue: [any := true. item fileIn]]].
- listSelections with: changeList do:
- [:selected :item | selected ifTrue: [any := true. item fileIn]].
  any ifFalse:
  [self inform: 'nothing selected, so nothing done']!

Item was changed:
  ----- Method: DependencyBrowser>>selectedEnvironment (in category 'accessing') -----
  selectedEnvironment
  "Answer the name of the selected package or nil."
 
  self hasPackageSelected ifFalse: [^nil].
+ ^ Smalltalk globals!
- ^ Smalltalk!

Item was changed:
  ----- Method: HierarchyBrowser>>classList (in category 'class list') -----
  classList
+ classDisplayList := classDisplayList select: [:each | (self environment valueOf: each withBlanksTrimmed asSymbol) notNil].
- classDisplayList := classDisplayList select: [:each | Smalltalk includesKey: each withBlanksTrimmed asSymbol].
  ^ classDisplayList!

Item was changed:
  ----- Method: HierarchyBrowser>>classListIndex: (in category 'initialization') -----
  classListIndex: newIndex
  "Cause system organization to reflect appropriate category"
  | newClassName ind |
  newIndex ~= 0 ifTrue:
  [newClassName := (classDisplayList at: newIndex) copyWithout: $ .
  selectedSystemCategory := (systemOrganizer categories at:
+ (systemOrganizer numberOfCategoryOfElement: newClassName)
+ ifAbsent: [nil])].
- (systemOrganizer numberOfCategoryOfElement: newClassName))].
  ind := super classListIndex: newIndex.
 
  "What I'd like to write:"
  "self selectedClassName ifNotNil:
  [ selectedSystemCategory := self selectedClass category ]."
  self changed: #systemCategorySingleton.
  ^ ind!

Item was changed:
  ----- Method: HierarchyBrowser>>initHierarchyForClass: (in category 'initialization') -----
  initHierarchyForClass: aClassOrMetaClass
  | nonMetaClass superclasses |
  centralClass := aClassOrMetaClass.
  nonMetaClass := aClassOrMetaClass theNonMetaClass.
+ self selectEnvironment: aClassOrMetaClass environment.
- self systemOrganizer: SystemOrganization.
  metaClassIndicated := aClassOrMetaClass isMeta.
  classDisplayList := OrderedCollection new.
  (superclasses := nonMetaClass allSuperclasses reversed) withIndexDo:
  [ : each : indent | classDisplayList add:
  (String streamContents:
  [ : stream | indent - 1 timesRepeat: [ stream nextPutAll: '  ' ].
  stream nextPutAll: each name ]) ].
  nonMetaClass
  allSubclassesWithLevelDo:
  [ : eachClass : lvl | classDisplayList add:
  (String streamContents:
  [ : stream | lvl timesRepeat: [ stream nextPutAll: '  ' ].
  stream nextPutAll: eachClass name ]) ]
  startingLevel: superclasses size.
 
  self changed: #classList.
  self selectClass: nonMetaClass!

Item was changed:
  ----- Method: MessageSet class>>parse:toClassAndSelector: (in category 'utilities') -----
  parse: methodRef toClassAndSelector: csBlock
  "Decode strings of the form <className> [class] <selectorName>."
 
  | tuple cl |
 
 
  self flag: #mref. "compatibility with pre-MethodReference lists"
 
  methodRef ifNil: [^ csBlock value: nil value: nil].
  methodRef isString ifFalse:
  [^methodRef setClassAndSelectorIn: csBlock].
  methodRef isEmpty ifTrue:
  [^csBlock value: nil value: nil].
  tuple := (methodRef asString includesSubstring: '>>')
  ifTrue: [(methodRef findTokens: '>>') fold: [:a :b| (a findTokens: ' '), {b first = $# ifTrue: [b allButFirst] ifFalse: [b]}]]
  ifFalse: [methodRef asString findTokens: ' .'].
+ self flag: #environments. "missing information about the class environment"
  cl := Smalltalk at: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil].
  ^(tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']])
  ifTrue: [csBlock value: cl value: (tuple at: 2) asSymbol]
  ifFalse: [csBlock value: cl class value: (tuple at: 3) asSymbol]!

Item was changed:
  ----- Method: MessageTrace>>filteredSelectorsNamed: (in category 'filtering') -----
  filteredSelectorsNamed: selectorSymbol
 
+ ^(SystemNavigation for: self environment) allImplementorsOf: selectorSymbol
- ^SystemNavigation new allImplementorsOf: selectorSymbol
  !

Item was added:
+ ----- Method: Model>>environment (in category '*Tools') -----
+ environment
+ ^ (self selectedClass ifNil: [self class]) environment!

Item was added:
+ ----- Method: Object>>environment (in category '*Tools') -----
+ environment
+ "This is a fallback for models that do not inherit from Model or something else that provides
+ a useful Environment answer. You should consider copying this method to (base) classes of
+ objects from which you expect exactly the behavior below.
+ Absolutely feel free to override this method for objects that have or operate on a dedicated
+ environment, such as references to classes, code loaders, or tools."
+ ^ self class environment!

Item was changed:
  StringHolder subclass: #Workspace
+ instanceVariableNames: 'bindings acceptDroppedMorphs acceptAction mustDeclareVariables shouldStyle environment'
- instanceVariableNames: 'bindings acceptDroppedMorphs acceptAction mustDeclareVariables shouldStyle'
  classVariableNames: 'LookupPools ShouldStyle'
  poolDictionaries: ''
  category: 'Tools-Base'!
 
  !Workspace commentStamp: 'fbs 6/2/2012 20:46' prior: 0!
  A Workspace is a text area plus a lot of support for executable code.  It is a great place to execute top-level commands to compute something useful, and it is a great place to develop bits of a program before those bits get put into class methods.
 
  To open a new workspace, execute:
 
  Workspace open
 
 
  A workspace can have its own variables, called "workspace variables", to hold intermediate results.  For example, if you type into a workspace "x := 5" and do-it, then later you could type in "y := x * 2" and y would become 10.
 
  Additionally, in Morphic, a workspace can gain access to morphs that are on the screen.  If acceptDroppedMorphs is turned on, then whenever a morph is dropped on the workspace, a variable will be created which references that morph.  This functionality is toggled with the window-wide menu of a workspace.
 
 
  The instance variables of this class are:
 
  bindings  -  holds the workspace variables for this workspace
 
  acceptDroppedMorphs - whether dropped morphs should create new variables!

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

Item was added:
+ ----- Method: Workspace>>environment: (in category 'accessing') -----
+ environment: anEnvironment
+
+ environment := anEnvironment.!

Item was changed:
  ----- Method: Workspace>>initialize (in category 'initialize-release') -----
  initialize
 
  super initialize.
  self initializeBindings.
  acceptDroppedMorphs := false.
+ mustDeclareVariables := false.
+ environment := Environment current.!
- mustDeclareVariables := false!