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!