[ENH] Browser pluggable menu structure

Andres Valloud sqrmax at cvtci.com.ar
Fri Mar 12 21:22:00 UTC 1999


Hi.

Ok, I have the browsers with pluggable menues. Now, before converting every
single hardcoded menu into aMenuPlugin I'd like to know if everything's going
fine. So here's the changeset (together with a postcript that initializes
everything so no problems --- worked ok in a clean 2.3 image).

Hope you like it!

Andres.
'From Squeak 2.3 of January 14, 1999 on 12 March 1999 at 6:18:11 pm'!
Browser class
	instanceVariableNames: 'menuManager '!
Object subclass: #Cluster
	instanceVariableNames: 'contents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Pluggable Menues'!
Object subclass: #MenuPlugin
	instanceVariableNames: 'itemList name linesAt '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Pluggable Menues'!
Object subclass: #MenuPluginManager
	instanceVariableNames: 'menues '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Pluggable Menues'!

!Browser methodsFor: 'system category functions' stamp: 'SqR!!!! 3/12/1999 17:31'!
systemCategoryMenu: aMenu

	self class menuManager build: #SystemCategory on: aMenu.
	^aMenu

"^ aMenu labels:
'find class... (f)
recent classes...
browse all
browse
printOut
fileOut
reorganize
update
add item...
rename...
remove' 
	lines: #(2 4 6 8)
	selections:
		#(findClass recent browseAllClasses buildSystemCategoryBrowser
		printOutSystemCategory fileOutSystemCategory
		editSystemCategories updateSystemCategories
		addSystemCategory renameSystemCategory removeSystemCategory )
"! !

!Browser methodsFor: 'class functions' stamp: 'SqR!!!! 3/12/1999 17:55'!
classListMenu: aMenu

	self class menuManager build: #ClassList on: aMenu.
	^aMenu

"^ aMenu labels: 
'browse class
browse full (b)
printOut
fileOut
hierarchy
definition
comment
spawn hierarchy
spawn protocol
inst var refs..
inst var defs..
class var refs...
class vars
class refs (N)
rename...
remove
unsent methods
find method...' 
	lines: #(4 7 9 11 14 16)
	selections:
		#(buildClassBrowser browseMethodFull printOutClass fileOutClass
		hierarchy editClass editComment
		spawnHierarchy spawnProtocol
		browseInstVarRefs browseInstVarDefs browseClassVarRefs 
		browseClassVariables browseClassRefs
		renameClass removeClass browseUnusedMethods findMethod)"! !

!Browser methodsFor: 'message category functions' stamp: 'SqR!!!! 3/12/1999 18:12'!
messageCategoryMenu: aMenu

	self class menuManager build: #MessageCategory on: aMenu.
	^aMenu

"^ aMenu labels:
'browse
printOut
fileOut
reorganize
add item...
rename...
remove
TeX fileOut'
	lines: #(3 4 7)
	selections:
		#(buildMessageCategoryBrowser printOutMessageCategories fileOutMessageCategories
		editMessageCategories
		addCategory renameCategory removeMessageCategory
		texFileOutMessageCategories)"! !


!Browser class methodsFor: 'class initialization' stamp: 'SqR!!!! 3/12/1999 18:11'!
initialize
	"Browser initialize"

	| systemCategoryPlugin classListPlugin messageCategoryPlugin |

	RecentClasses _ OrderedCollection new.
	menuManager _ MenuPluginManager new.
	
	systemCategoryPlugin _ MenuPlugin new.
	systemCategoryPlugin name: #StdSystemCategoryPlugin.
	systemCategoryPlugin
		addItemLabel: 'find class... (f)' action: #findClass;
		addItemLabel: 'recent classes... ' action: #recent;
		addItemLabel: 'browse all' action: #browseAllClasses;
		addItemLabel: 'browse' action: #buildSystemCategoryBrowser;
		addItemLabel: 'printOut' action: #printOutSystemCategory;
		addItemLabel: 'fileOut' action: #fileOutSystemCategory;
		addItemLabel: 'reorganize' action: #editSystemCategories;
		addItemLabel: 'update' action: #updateSystemCategories;
		addItemLabel: 'add item...' action: #addSystemCategory;
		addItemLabel: 'rename...' action: #renameSystemCategory;
		addItemLabel: 'remove' action: #removeSystemCategory.
	systemCategoryPlugin linesAt: #(2 4 6 8).

	menuManager addMenu: #SystemCategory.
	menuManager menu: #SystemCategory addPlugin: systemCategoryPlugin.

	classListPlugin _ MenuPlugin new.
	classListPlugin name: #StdClassListPlugin.
	classListPlugin
		addItemLabel: 'browse class' action: #buildClassBrowser;
		addItemLabel: 'browse full (b)' action: #browseFullMethod;
		addItemLabel: 'printOut' action: #printOutClass;
		addItemLabel: 'fileOut' action: #fileOutClass;
		addItemLabel: 'hierarchy' action: #hierarchy;
		addItemLabel: 'definition' action: #editClass;
		addItemLabel: 'comment' action: #editComment;
		addItemLabel: 'spawn hierarchy' action: #spawnHierarchy;
		addItemLabel: 'spawn protocol' action: #spawnProtocol;
		addItemLabel: 'inst var refs..' action: #browseInstVarRefs;
		addItemLabel: 'inst var defs..' action: #browseInstVarDefs;
		addItemLabel: 'class var refs...' action: #browseClassVarRefs;
		addItemLabel: 'class vars' action: #browseClassVariables;
		addItemLabel: 'class refs (N)' action: #browseClassRefs;
		addItemLabel: 'rename...' action: #renameClass;
		addItemLabel: 'remove' action: #removeClass;
		addItemLabel: 'unsent methods' action: #browseUnusedMethods;
		addItemLabel: 'find method...' action: #findMethod.
	classListPlugin linesAt: #(4 7 9 11 14 16).

	menuManager addMenu: #ClassList.
	menuManager menu: #ClassList addPlugin: classListPlugin.

	messageCategoryPlugin _ MenuPlugin new.
	messageCategoryPlugin name: #StdMessageCategoryPlugin.
	messageCategoryPlugin
		addItemLabel: 'browse' action: #buildMessageCategoryBrowser;
		addItemLabel: 'printOut' action: #printOutMessageCategories;
		addItemLabel: 'fileOut' action: #fileOutMessageCategories;
		addItemLabel: 'reorganize' action: #editMessageCategories;
		addItemLabel: 'add item...' action: #addCategory;
		addItemLabel: 'rename...' action: #renameCategory;
		addItemLabel: 'remove' action: #removeMessageCategory.
	messageCategoryPlugin linesAt: #(3 4).

	menuManager addMenu: #MessageCategory.
	menuManager menu: #MessageCategory addPlugin: messageCategoryPlugin.! !

!Browser class methodsFor: 'class initialization' stamp: 'SqR!!!! 3/12/1999 17:29'!
menuManager
	^menuManager! !


!Cluster reorganize!
('accessing' doesNotUnderstand:)
!


!Cluster methodsFor: 'accessing' stamp: 'SqR!!!! 3/9/1999 22:51'!
doesNotUnderstand: aMessage

	| selector |

	"Not initialized, huh?"
	contents isNil ifTrue: [contents _ Dictionary new].

	"Check unary selector"
	aMessage arguments isEmpty ifTrue: [^contents at: aMessage selector].

	"Check 1 argument"
	aMessage arguments size = 1 ifTrue:
		[
			selector _ aMessage selector.
			"Skip binary messages"
			selector last = $: ifFalse: [^super doesNotUnderstand: aMessage].
			selector _ (selector copyFrom: 1 to: selector size - 1) asSymbol.
			^contents at: selector put: aMessage arguments first.
		].

	"The rest, well thank you"
	^super doesNotUnderstand: aMessage! !


!Cluster class reorganize!
('as yet unclassified')
!



!Collection methodsFor: 'enumerating' stamp: 'SqR 10/28/97 00:14'!
do: aBlock andBetweenDo: aSeparatorBlock
	"Evaluate aBlock for each element of the receiver, evaluating aSeparatorBlock
	between each pair of evaluations of aBlock"

	| first |

	first := true.
	self do:
		[:each |
			first
				ifTrue: [first := false]
				ifFalse: [aSeparatorBlock value].
			aBlock value: each.
		]! !


!MenuPlugin reorganize!
('accessing' addItemLabel:action: itemList linesAt linesAt: name name: removeItemAt:)
('printing' printOn:)
('private' initialize)
!


!MenuPlugin methodsFor: 'accessing' stamp: 'SqR!!!! 3/12/1999 17:31'!
addItemLabel: aLabel action: anAction
	itemList add:
		(
			Cluster new
				label: aLabel;
				action: anAction;
				yourself
		)! !

!MenuPlugin methodsFor: 'accessing' stamp: 'SqR!!!! 3/9/1999 22:53'!
itemList
	^itemList! !

!MenuPlugin methodsFor: 'accessing' stamp: 'SqR!!!! 3/12/1999 15:38'!
linesAt
	^linesAt! !

!MenuPlugin methodsFor: 'accessing' stamp: 'SqR!!!! 3/12/1999 15:38'!
linesAt: anArray
	linesAt _ anArray! !

!MenuPlugin methodsFor: 'accessing' stamp: 'SqR!!!! 3/9/1999 22:50'!
name
	^name! !

!MenuPlugin methodsFor: 'accessing' stamp: 'SqR!!!! 3/9/1999 22:50'!
name: aString
	name _ aString! !

!MenuPlugin methodsFor: 'accessing' stamp: 'SqR!!!! 3/9/1999 22:53'!
removeItemAt: anInteger
	itemList removeAt: anInteger! !

!MenuPlugin methodsFor: 'printing' stamp: 'SqR!!!! 3/12/1999 17:36'!
printOn: aStream
	aStream nextPutAll: self class name.
	aStream nextPut: $(.
	name printOn: aStream.
	aStream nextPut: $)! !

!MenuPlugin methodsFor: 'private' stamp: 'SqR!!!! 3/12/1999 15:38'!
initialize
	itemList _ OrderedCollection new.
	linesAt _ Array new! !


!MenuPlugin class reorganize!
('instance creation' new)
!


!MenuPlugin class methodsFor: 'instance creation' stamp: 'SqR!!!! 3/9/1999 22:49'!
new
	^super new initialize! !


!MenuPluginManager reorganize!
('menu filling' menu:addFirstPlugin: menu:addPlugin: menu:removePlugin: pluginsInMenu:)
('menu management' addMenu: build:on: buildPlugin:on: menues removeMenu:)
('printing' printOn:)
('private' initialize)
!


!MenuPluginManager methodsFor: 'menu filling' stamp: 'SqR!!!! 3/12/1999 17:09'!
menu: aSymbol addFirstPlugin: aMenuPlugin
	(menues at: aSymbol) add: aMenuPlugin beforeIndex: 0! !

!MenuPluginManager methodsFor: 'menu filling' stamp: 'SqR!!!! 3/12/1999 15:57'!
menu: aSymbol addPlugin: aMenuPlugin
	(menues at: aSymbol) add: aMenuPlugin! !

!MenuPluginManager methodsFor: 'menu filling' stamp: 'SqR!!!! 3/12/1999 15:58'!
menu: aSymbol removePlugin: aMenuPluginName

	menues at: aSymbol put: 
		((menues at: aSymbol) reject: 
			[:one | one name = aMenuPluginName])! !

!MenuPluginManager methodsFor: 'menu filling' stamp: 'SqR!!!! 3/12/1999 15:58'!
pluginsInMenu: aMenuName
	(menues at: aMenuName) collect: [:each | each name]! !

!MenuPluginManager methodsFor: 'menu management' stamp: 'SqR!!!! 3/12/1999 15:55'!
addMenu: aSymbol
	(menues keys includes: aSymbol) ifTrue:
		[^self notify: 'Menu already exists'].
	menues at: aSymbol put: OrderedCollection new! !

!MenuPluginManager methodsFor: 'menu management' stamp: 'SqR!!!! 3/12/1999 18:06'!
build: aMenuName on: aMenu
	"Build aMenu from the plugin list at aMenuName"

	(menues at: aMenuName) 
		do: [:each | self buildPlugin: each on: aMenu]
		andBetweenDo: [aMenu addLine]! !

!MenuPluginManager methodsFor: 'menu management' stamp: 'SqR!!!! 3/12/1999 16:08'!
buildPlugin: aMenuPlugin on: aMenu
	"Build aMenuPlugin on aMenu"

	| index |

	index _ 1.
	aMenuPlugin itemList do:
		[:each |
			aMenu add: each label action: each action.
			(aMenuPlugin linesAt includes: index) ifTrue: 
				[aMenu addLine].
			index _ index + 1.
		]! !

!MenuPluginManager methodsFor: 'menu management' stamp: 'SqR!!!! 3/12/1999 15:47'!
menues
	^menues keys! !

!MenuPluginManager methodsFor: 'menu management' stamp: 'SqR!!!! 3/12/1999 15:56'!
removeMenu: aSymbol
	menues removeKey: aSymbol ifAbsent: 
		[self inform: 'The menu ', aSymbol, ' does not exist']! !

!MenuPluginManager methodsFor: 'printing' stamp: 'SqR!!!! 3/12/1999 17:38'!
printOn: aStream
	aStream nextPutAll: self class name.
	self menues asArray printOn: aStream! !

!MenuPluginManager methodsFor: 'private' stamp: 'SqR!!!! 3/12/1999 15:44'!
initialize
	menues _ Dictionary new! !


!MenuPluginManager class reorganize!
('instance creation' new)
!


!MenuPluginManager class methodsFor: 'instance creation' stamp: 'SqR!!!! 3/12/1999 15:44'!
new
	^super new initialize! !


Browser initialize!
Cluster removeSelector: #initialize!
Cluster class removeSelector: #new!
MenuPlugin removeSelector: #addItemLabel:selection:!
Smalltalk removeClassNamed: #MenuItem!
Browser initialize.
self inform: 'Pluggable Menu Structure added to Browser'!





More information about the Squeak-dev mailing list