Menu plugins

Andres Valloud sqrmax at cvtci.com.ar
Mon Mar 15 18:07:14 UTC 1999


Hi.

This change set includes the plugin manager and standard menu plugins for 3
browsers. It's now possible to change the menues of those browsers on the fly,
and updating such menues is now very easy because each class has a menu plugin
manager that dictates how should the menues be.

Think you'll like this.

Andres.
'From Squeak 2.3 of January 14, 1999 on 15 March 1999 at 3:04:51 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 methodsFor: 'message functions' stamp: 'SqR!!!! 3/15/1999 14:31'!
messageListMenu: aMenu shifted: shifted

	self class menuManager 
		build: (shifted ifTrue: [#ShiftedMessageList] ifFalse: [#MessageList])
		on: aMenu.
	^aMenu

"	^ shifted ifFalse: [aMenu labels:
'browse full (b)
fileOut
printOut
senders of... (n)
implementors of... (m)
method inheritance
versions (v)
inst var refs...
inst var defs...
class var refs...
class variables
class refs (N)
remove
more...'
	lines: #(3 7 12)
	selections:
		#(browseMethodFull fileOutMessage printOutMessage
		browseSendersOfMessages browseMessages methodHierarchy browseVersions
		browseInstVarRefs browseInstVarDefs browseClassVarRefs 
			browseClassVariables browseClassRefs
		removeMessage shiftedYellowButtonActivity )]

	ifTrue: [aMenu labels: 'browse class hierarchy
browse class
browse method
implementors of sent messages
change sets with this method
inspect instances
inspect subinstances
remove from this browser
annotations in this browser
revert to previous version
remove from current change set
revert and forget
more...' 
	lines: #(5 7 9 12)
	selections: #(classHierarchy browseClass 
		buildMessageBrowser browseAllMessages findMethodInChangeSets 
		inspectInstances inspectSubInstances
		removeMessageFromBrowser chooseAnnotations
		revertToPreviousVersion 
		removeFromCurrentChanges revertAndForget
		unshiftedYellowButtonActivity)]
"! !


!Browser class methodsFor: 'menu plugins' stamp: 'SqR!!!! 3/15/1999 14:21'!
classListPlugin

	| classListPlugin |

	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).
	^classListPlugin! !

!Browser class methodsFor: 'menu plugins' stamp: 'SqR!!!! 3/15/1999 14:22'!
messageCategoryPlugin

	| messageCategoryPlugin |

	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).
	^messageCategoryPlugin! !

!Browser class methodsFor: 'menu plugins' stamp: 'SqR!!!! 3/15/1999 14:24'!
messageListPlugin

	| messageListPlugin |

	messageListPlugin _ MenuPlugin new.
	messageListPlugin name: #StdMessageListPlugin.
	messageListPlugin
		addItemLabel: 'browse full (b)' action: #browseMethodFull;
		addItemLabel: 'fileOut' action: #fileOutMessage;
		addItemLabel: 'printOut' action: #printOutMessage;
		addItemLabel: 'senders of... (n)' action: #browseSendersOfMessages;
		addItemLabel: 'implementors of... (m)' action: #browseMessages;
		addItemLabel: 'method inheritance' action: #methodHierarchy;
		addItemLabel: 'versions (v)' action: #browseVersions;
		addItemLabel: 'inst var refs...' action: #browseInstVarRefs;
		addItemLabel: 'inst var defs...' action: #browseInstVarDefs;
		addItemLabel: 'class var refs...' action: #browseClassVarRefs;
		addItemLabel: 'class variables' action: #browseClassVariables;
		addItemLabel: 'class refs (N)' action: #browseClassRefs;
		addItemLabel: 'remove' action: #removeMessage;
		addItemLabel: 'more...' action: #shiftedYellowButtonActivity.
	messageListPlugin linesAt: #(3 7 12).
	^messageListPlugin! !

!Browser class methodsFor: 'menu plugins' stamp: 'SqR!!!! 3/15/1999 14:24'!
shiftedMessageListPlugin

	| shiftedMessageListPlugin |

	shiftedMessageListPlugin _ MenuPlugin new.
	shiftedMessageListPlugin name: #StdShiftedMessageList.
	shiftedMessageListPlugin
		addItemLabel: 'browse class hierarchy' action: #classHierarchy;
		addItemLabel: 'browse class' action: #browseClass;
		addItemLabel: 'browse method' action: #buildMessageBrowser;
		addItemLabel: 'implementors of sent messages' action: #browseAllMessages;
		addItemLabel: 'change sets with this method' action: #findMethodInChangeSets;
		addItemLabel: 'inspect instances' action: #inspectInstances;
		addItemLabel: 'inspect subinstances' action: #inspectSubInstances;
		addItemLabel: 'remove from this browser' action: #removeMessageFromBrowser;
		addItemLabel: 'annotations in this browser' action: #chooseAnnotations;
		addItemLabel: 'revert to previous version' action: #revertToPreviousVersion;
		addItemLabel: 'remove from current change set' action: #removeFromCurrentChanges;
		addItemLabel: 'revert and forget' action: #revertAndForget;
		addItemLabel: 'more...' action: #unshiftedYellowButtonActivity.
	shiftedMessageListPlugin linesAt: #(5 7 9 12).
	^shiftedMessageListPlugin! !

!Browser class methodsFor: 'menu plugins' stamp: 'SqR!!!! 3/15/1999 14:20'!
systemCategoryPlugin

	| systemCategoryPlugin |

	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).
	^systemCategoryPlugin! !

!Browser class methodsFor: 'class initialization' stamp: 'SqR!!!! 3/15/1999 14:23'!
initialize
	"Browser initialize"

	| |

	RecentClasses _ OrderedCollection new.

	menuManager _ MenuPluginManager new.
	menuManager addMenu: #SystemCategory.
	menuManager menu: #SystemCategory addPlugin: self systemCategoryPlugin.
	menuManager addMenu: #ClassList.
	menuManager menu: #ClassList addPlugin: self classListPlugin.
	menuManager addMenu: #MessageCategory.
	menuManager menu: #MessageCategory addPlugin: self messageCategoryPlugin.
	menuManager addMenu: #MessageList.
	menuManager menu: #MessageList addPlugin: self messageListPlugin.
	menuManager addMenu: #ShiftedMessageList.
	menuManager menu: #ShiftedMessageList addPlugin: self shiftedMessageListPlugin! !

!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.
		]! !


!FileContentsBrowser methodsFor: 'menus' stamp: 'SqR!!!! 3/15/1999 14:41'!
classListMenu: aMenu

	^super classListMenu: aMenu	

"	^ aMenu 
		labels:
'definition
comment
class refs
fileIn
fileOut
rename...
remove
remove existing'
		lines: #(2 3 5 7)
		selections: #(editClass editComment browseClassRefs fileInClass fileOutClass renameClass removeClass removeUnmodifiedCategories) 

"! !

!FileContentsBrowser methodsFor: 'menus' stamp: 'SqR!!!! 3/15/1999 14:44'!
messageCategoryMenu: aMenu

	^super messageCategoryMenu: aMenu

"	^ aMenu 
		labels:
'fileIn
fileOut
reorganize
add item...
rename...
remove
remove existing'
		lines: #(2 3 6)
		selections: #(fileInMessageCategories fileOutMessageCategories editMessageCategories addCategory renameCategory removeMessageCategory removeUnmodifiedMethods)"! !

!FileContentsBrowser methodsFor: 'menus' stamp: 'SqR!!!! 3/15/1999 14:55'!
messageListMenu: aMenu

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

"	^ aMenu 
		labels:
'fileIn
fileOut
senders
implementors
versions
remove'
		lines: #(2 5)
		selections: #(fileInMessage fileOutMessage
browseSenders browseImplementors browseVersions
removeMessage)."! !

!FileContentsBrowser methodsFor: 'menus' stamp: 'SqR!!!! 3/15/1999 14:48'!
packageListMenu: aMenu

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

"	^ aMenu 
		labels:
'find class...
fileIn
fileOut
remove
remove existing'
		lines: #(1 3 4)
		selections: #(findClass fileInPackage fileOutPackage removePackage removeUnmodifiedClasses)"! !


!FileContentsBrowser class methodsFor: 'initialization' stamp: 'SqR!!!! 3/15/1999 14:53'!
initialize

	super initialize.
	menuManager addMenu: #PackageList.
	menuManager menu: #PackageList addPlugin: self packageListPlugin! !

!FileContentsBrowser class methodsFor: 'menu plugins' stamp: 'SqR!!!! 3/15/1999 14:38'!
classListPlugin

	| classListPlugin |

	classListPlugin _ MenuPlugin new.
	classListPlugin name: #StdFileClassListMenu.
	classListPlugin
		addItemLabel: 'definition' action: #editClass;
		addItemLabel: 'comment' action: #editComment;
		addItemLabel: 'class refs' action: #browseClassRefs;
		addItemLabel: 'fileIn' action: #fileInClass;
		addItemLabel: 'fileOut' action: #fileOutClass;
		addItemLabel: 'rename...' action: #renameClass;
		addItemLabel: 'remove' action: #removeClass;
		addItemLabel: 'remove existing' action: #removeUnmodifiedCategories.
	classListPlugin linesAt: #(2 3 5 7).
	^classListPlugin! !

!FileContentsBrowser class methodsFor: 'menu plugins' stamp: 'SqR!!!! 3/15/1999 14:44'!
messageCategoryPlugin

	| messageCategoryPlugin |

	messageCategoryPlugin _ MenuPlugin new.
	messageCategoryPlugin name: #StdFileMessageCategory.
	messageCategoryPlugin
		addItemLabel: 'fileIn' action: #fileInMessageCategories;
		addItemLabel: 'fileOut' action: #fileOutMessageCategories;
		addItemLabel: 'reorganize' action: #editMessageCategories;
		addItemLabel: 'add item...' action: #addCategory;
		addItemLabel: 'rename...' action: #renameCategory;
		addItemLabel: 'remove' action: #removeMessageCategory;
		addItemLabel: 'remove existing' action: #removeUnmodifiedMethods.
	messageCategoryPlugin linesAt: #(2 3 6).
	^messageCategoryPlugin! !

!FileContentsBrowser class methodsFor: 'menu plugins' stamp: 'SqR!!!! 3/15/1999 14:46'!
messageListPlugin

	| messageListPlugin |

	messageListPlugin _ MenuPlugin new.
	messageListPlugin name: #StdFileMessageList.
	messageListPlugin
		addItemLabel: 'fileIn' action: #fileInMessage;
		addItemLabel: 'fileOut' action: #fileOutMessage;
		addItemLabel: 'senders' action: #browseSenders;
		addItemLabel: 'implementors' action: #browseImplementors;
		addItemLabel: 'versions' action: #browseVersions;
		addItemLabel: 'remove' action: #removeMessage.
	messageListPlugin linesAt: #(2 5).
	^messageListPlugin! !

!FileContentsBrowser class methodsFor: 'menu plugins' stamp: 'SqR!!!! 3/15/1999 14:51'!
packageListPlugin

	| packageListPlugin |

	packageListPlugin _ MenuPlugin new.
	packageListPlugin name: #StdFilePackageList.
	packageListPlugin
		addItemLabel: 'find class...' action: #findClass;
		addItemLabel: 'fileIn' action: #fileInPackage;
		addItemLabel: 'fileOut' action: #fileOutPackage;
		addItemLabel: 'remove' action: #removePackage;
		addItemLabel: 'remove existing' action: #removeUnmodifiedClasses.
	packageListPlugin linesAt: #(1 3 4).
	^packageListPlugin! !


!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!
FileContentsBrowser initialize!
MenuPlugin removeSelector: #addItemLabel:selection:!
Smalltalk removeClassNamed: #MenuItem!
Browser initialize.
HierarchyBrowser initialize.
FileContentsBrowser initialize.
self inform: 'Pluggable Menu Structure added to the system.'!





More information about the Squeak-dev mailing list