[squeak-dev] The Inbox: Tools-jr.745.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Feb 28 02:31:40 UTC 2017
A new version of Tools was added to project The Inbox:
http://source.squeak.org/inbox/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!
More information about the Squeak-dev
mailing list
|