[squeak-dev] The Trunk: Tools-jr.745.mcz

commits at source.squeak.org commits at source.squeak.org
Sun Mar 5 16:01:48 UTC 2017

David T. Lewis uploaded a new version of Tools to project The Trunk:

==================== 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

- 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') -----
  	| 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
  	| 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.
  		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') -----
  	"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') -----
  	"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') -----
  	"Answer the class that is currently selected. Answer nil if no selection 
  	| 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') -----
+ 	"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') -----
  	"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') -----
  	| 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') -----
  	"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') -----
+ 	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 ]) ].
  			[ : 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') -----
  	super initialize.
  	self initializeBindings.
  	acceptDroppedMorphs := false.
+ 	mustDeclareVariables := false.
+ 	environment := Environment current.!
- 	mustDeclareVariables := false!

More information about the Squeak-dev mailing list