holdam@daimi.UUCP (Jan Holdam) (12/08/86)
I would like to join the chorus of people submitting goodies for the Smalltalk-80 system. The goodies are developed for (or have been tested on) the PS-version of Smalltalk-80 running on Sun 3's. Alas, this goodie has similarities to the "findSelector" from Mario Wolczko, but nevertheless: what follows is a goodie for supporting navigation in the System Browser. It includes a version of the findClass where it is possible to type a wildcard specification of the class wanted, and where you may ask the system to look for other classes if the first guess is not what you wanted. The other main part of this navigation goodie is a findMethod which looks in the actual class for the method. If the method is not found, you may choose the first guess, ask the system to try harder, or ask if the method is in the superclass of the class. The last part of this goodie is a facility to move from a class to its superclass, or to one of its subclasses (if any). The goodie is not supposed to work correctly for multiple superclasses - at least it will only look for the first one. Any comments to: Jan Holdam Department of Computer Science Aarhus University DK-8000 Aarhus C Denmark UUCP: holdam@daimi or ..mcvax!diku!daimi!holdam ------------------------cut here---------------------------- 'From Smalltalk-80, version 2, of April 1, 1983 on 28 November 1986 at 12:40:32 pm'! !Browser methodsFor: 'searching'! chooseSelectorsAmong: selectors considering: aSelString "Find the selectors that match aSelString." ^selectors select: [:aSel | aSelString match: aSel]! findClass "Ask the user for the name of a class. If the name contains no wildcard characters (* #) then answer the class having its name closest to the typed string, otherwise find all classes matching the string." | aString | self changeRequest ifFalse: [^self]. aString _ FillInTheBlank request: 'Find which class?' initialAnswer: 'ClassName'. aString isEmpty ifTrue: [^self]. (aString includes: $*) | (aString includes: $#) ifTrue: [^self findWildcardClass: aString]. ^self findClass: aString! findClass: aClassString "Test if the string denotes an existing class. If not, find the class closest to aClassString and ask the user if that was the wanted class. If it isn't, try other alternatives." | aClassName bestScore selectors score aStream menu reply showPoint | aClassName _ aClassString asSymbol. (Smalltalk includesKey: aClassName) ifTrue: [((Smalltalk at: aClassName) isKindOf: Behavior) ifFalse: [^Transcript cr; show: aClassName, ' is a global instance of ', (Smalltalk at: aClassName) class printString]] ifFalse: ["find closest class" bestScore _ 0. Smalltalk classNames do: [:aClass | (score _ aClass spellAgainst: aClassString) > bestScore ifTrue: [bestScore _ score. aClassName _ aClass]]. aStream _ WriteStream on: (String new: 200). aStream nextPutAll: 'correct? ', (aClassName contractTo: 25); cr. aStream nextPutAll: 'try harder'. menu _ PopUpMenu labels: aStream contents. reply _ menu startUp: #anyButton at: (showPoint _ Sensor cursorPoint) withHeading: ' ', (aClassString contractTo: 25), ' is not a class'. reply == 0 ifTrue: [^self]. reply == 2 ifTrue: ["sort all class names with respect to the typed string, removing the one that has already been used" Cursor execute showWhile: [selectors _ Smalltalk classNames copy. selectors remove: aClassName ifAbsent: [self error: 'Error while removing a class name']. selectors _ self sortSelectors: selectors considering: aClassString]. ^self showAlternativesAmong: selectors at: showPoint string: aClassString]]. self newClass: aClassName! findMethod "Ask the user for the name of a method. If it is the name of a unary or binary selector, look for it. If it is the name of a keyword selector, test if the name contains wildcard characters (* #). If it doesn't, answer the method having its name closest to the typed string. If it does, find all methods matching the string." | aString | self changeRequest ifFalse: [^self]. aString _ FillInTheBlank request: 'Find which method?' initialAnswer: 'methodName'. aString isEmpty ifTrue: [^self]. aString detect: [:aCharacter | aCharacter tokenish] ifNone: [^self findMethod: aString inClass: self selectedClass showMenuAt: Sensor cursorPoint]. (aString includes: $*) | (aString includes: $#) ifTrue: [^self findWildcardMethod: aString inClass: self selectedClass showMenuAt: Sensor cursorPoint]. ^self findMethod: aString inClass: self selectedClass showMenuAt: Sensor cursorPoint! findMethod: aMethodString inClass: aClass showMenuAt: aPoint "Test if the string denotes a method in aClass. If not, find the method closest to aMethodString and ask the user if that was the wanted method. If it isn't, try other alternatives in the same class, or look at methods in the superclass (if any)." | aMethodName reply menu selectors aStream menuArray posInMenu showPoint | aMethodName _ aMethodString asSymbol. (aClass whichCategoryIncludesSelector: aMethodName) isNil ifTrue: ["sort all method selectors with respect to the typed string" Cursor execute showWhile: [selectors _ self sortSelectors: aClass selectors considering: aMethodString]. "build menu" menuArray _ Array new: 3. posInMenu _ 0. aStream _ WriteStream on: (String new: 200). selectors isEmpty ifFalse: [aMethodName _ selectors removeFirst. posInMenu _ posInMenu + 1. aStream nextPutAll: 'correct? ', (aMethodName contractTo: 25); cr. selectors isEmpty ifFalse: [aStream nextPutAll: 'try harder'; cr. posInMenu _ posInMenu + 1. menuArray at: posInMenu put: #tryHarder]]. aClass ~= Object ifTrue: [aStream nextPutAll: 'try in superclass'. posInMenu _ posInMenu + 1. menuArray at: posInMenu put: #tryInSuperclass] ifFalse: [aStream skip: -1]. posInMenu = 0 ifTrue: [^self]. "now ask user" menu _ ActionMenu labels: aStream contents selectors: menuArray. reply _ menu startUp: #anyButton at: aPoint withHeading: ' ', (aMethodString contractTo: 25), ' is not a method in ' , aClass name. reply == 0 ifTrue: [^self]. (menu selectorAt: reply) == #tryHarder ifTrue: [^self showAlternativesAmong: selectors for: aClass at: aPoint string: aMethodString]. (menu selectorAt: reply) == #tryInSuperclass ifTrue: [^self findMethod: aMethodString inClass: aClass superclass showMenuAt: aPoint]]. self newSelector: aMethodName in: aClass.! findSubclass | aStream no classArray menu reply | "show the subclasses (if any) of the selected class in the browser, and let the user choose among them" self changeRequest ifFalse: [^self]. self selectedClass = Object ifTrue: [^Transcript cr; show: 'Can not be used from Object']. Cursor execute showWhile: [aStream _ WriteStream on: (String new: 200). classArray _ Array new: 50. no _ 0. self selectedClass subclasses do: [:aClass | aStream nextPutAll: aClass name; cr. no _ no+1. no > 50 ifTrue: [Cursor normal show. ^Transcript cr; show: 'More than 50 subclasses']. "to assure the menu will fit on the screen" classArray at: no put: aClass]. no > 0 ifTrue: [aStream skip: -1] ifFalse: [Cursor normal show. ^Transcript cr; show: 'No subclasses']]. no = 1 ifTrue: [^self showNewClass: (classArray at: 1)]. menu _ PopUpMenu labels: aStream contents lines: (Array with: no). (reply _ menu startUp: #anyButton at: Sensor cursorPoint withHeading: ' Subclasses: ') == 0 ifTrue: [^self]. self showNewClass: (classArray at: reply).! findSuperclass "show the superclass (if any) of the selected class in the browser" self changeRequest ifFalse: [^self]. self selectedClass ~= Object ifTrue: [self showNewClass: self selectedClass superclass]! findWildcardClass: aClassString "Find all the classes that match aClassString, and let the user choose among them. If no match, abort." | reply aStream no classArray classNames menu | Cursor execute showWhile: [classNames _ (self chooseSelectorsAmong: Smalltalk classNames considering: aClassString) asSortedCollection. aStream _ WriteStream on: (String new: 200). classArray _ Array new: 50. no _ 0. classNames do: [:aClass | aStream nextPutAll: aClass; cr. no _ no+1. no > 50 ifTrue: [Cursor normal show. ^Transcript cr; show: 'More than 50 classes matching']. "to assure the menu will fit on the screen" classArray at: no put: aClass]. no > 0 ifTrue: [aStream skip: -1] ifFalse: [Cursor normal show. ^Transcript cr; show: 'No match']]. menu _ PopUpMenu labels: aStream contents lines: (Array with: no). (reply _ menu startUp: #anyButton at: Sensor cursorPoint withHeading: 'Classes mathcing ', (aClassString contractTo: 25)) == 0 ifTrue: [^self]. self newClass: (classArray at: reply).! findWildcardMethod: aMethodString inClass: aClass showMenuAt: aPoint "Find all the selectors in aClass that match aMethodString, and let the user choose among them. If no match, the user may look at the superclass (if any)." | reply menu selectors aStream no selectorArray | Cursor execute showWhile: [selectors _ (self chooseSelectorsAmong: aClass selectors considering: aMethodString) asSortedCollection. aStream _ WriteStream on: (String new: 200). selectorArray _ Array new: 50. no _ 0. selectors do: [:aSelector | aStream nextPutAll: (aSelector contractTo: 25); cr. no _ no+1. no > 50 ifTrue: [Cursor normal show. ^Transcript cr; show: 'More than 50 methods matching']. "to assure the menu will fit on the screen" selectorArray at: no put: aSelector]]. aClass ~= Object ifTrue: [aStream nextPutAll: 'try in superclass'] ifFalse: [no > 0 ifTrue: [aStream skip: -1] ifFalse: [Cursor normal show. ^Transcript cr; show: 'No match']]. menu _ PopUpMenu labels: aStream contents lines: (Array with: no). reply _ no > 0 ifTrue: [menu startUp: #anyButton at: aPoint withHeading: ' Methods mathcing ', (aMethodString contractTo: 25), ' in ', aClass name, ' '] ifFalse: [menu startUp: #anyButton at: aPoint withHeading: ' No methods mathcing ', (aMethodString contractTo: 25), ' in ', aClass name, ' ']. reply == 0 ifTrue: [^self]. reply == (no+1) ifTrue: [^self findWildcardMethod: aMethodString inClass: aClass superclass showMenuAt: aPoint]. self newSelector: (selectorArray at: reply) in: aClass.! newClass: aClassName "Adjust the contents of the Browser." | aClass | aClass _ Smalltalk at: aClassName ifAbsent: [^self]. aClass category ~= category ifTrue: [self newCategoryList: aClass category]. ((aClass ~= self selectedClass) and: [aClass class ~= self selectedClass]) ifTrue: [self newClassList: aClassName].! newSelector: aMethodName in: aClass "Adjust the contents of the Browser." | newProtocol tempClass changeMeta | changeMeta _ false. (newProtocol _ (aClass whichCategoryIncludesSelector: aMethodName)) isNil ifTrue: [^self]. meta ifTrue: [((aClass ~= Object) & (aClass ~= Behavior) & (aClass ~= ClassDescription)) ifTrue: [tempClass _ aClass soleInstance] ifFalse: [tempClass _ aClass. changeMeta _ true]] ifFalse: [tempClass _ aClass]. tempClass category ~= category ifTrue: [self newCategoryList: tempClass category]. tempClass ~= self selectedClass ifTrue: [self newClassList: tempClass name asSymbol]. changeMeta ifTrue: [meta _ false. self changed: #meta]. protocol ~= newProtocol ifTrue: [self newProtocolList: newProtocol]. selector ~= aMethodName ifTrue: [self newSelectorList: aMethodName].! showAlternativesAmong: selectors at: aPoint string: aClassString "Show the next 5 classes closest to aClassString that haven't been shown before. Let the user choose among them, or decide to continue with more imaginative proposals." | aStream reply no selectorArray sel | aStream _ WriteStream on: (String new: 200). selectorArray _ Array new: 5. no _ 0. [no >= 5 or: [selectors isEmpty]] whileFalse: [no _ no+1. selectorArray at: no put: selectors removeFirst. aStream nextPutAll: (selectorArray at: no); cr]. selectors isEmpty ifTrue: [aStream skip: -1] ifFalse: [aStream nextPutAll: 'tryHarder']. reply _ (PopUpMenu labels: aStream contents lines: (Array with: no)) startUp: #anyButton at: aPoint withHeading: ' ', (aClassString contractTo: 25), ' is not a class'. reply == 0 ifTrue: [^self]. reply = (no+1) ifTrue: [^self showAlternativesAmong: selectors at: aPoint string: aClassString] ifFalse: [^self newClass: (selectorArray at: reply)]! showAlternativesAmong: selectors for: aClass at: aPoint string: aMethodString "Show the next 5 selectors in aClass closest to aMethodString that haven't been shown before. Let the user choose among them, decide to continue with more imaginative proposals, or look at the superclass (if any)." | aStream reply no selectorArray menu | aStream _ WriteStream on: (String new: 200). selectorArray _ Array new: 7. no _ 0. [no >= 5 or: [selectors isEmpty]] whileFalse: [no _ no+1. selectorArray at: no put: selectors removeFirst. aStream nextPutAll: ((selectorArray at: no) contractTo: 25); cr]. selectors isEmpty ifFalse: [aStream nextPutAll: 'try harder'; cr. selectorArray at: no+1 put: #tryHarder]. aClass = Object ifTrue: [aStream skip: -1] ifFalse: [aStream nextPutAll: 'try in superclass'. selectorArray at: (((selectorArray at: no+1) == nil) ifTrue: [no+1] ifFalse: [no+2]) put: #tryInSuperclass]. menu _ ActionMenu labels: aStream contents lines: (Array with: no) selectors: selectorArray. reply _ menu startUp: #anyButton at: aPoint withHeading: ' ', (aMethodString contractTo: 25), ' is not a method in ', aClass name. reply == 0 ifTrue: [^self]. (menu selectorAt: reply) == #tryHarder ifTrue: [^self showAlternativesAmong: selectors for: aClass at: aPoint string: aMethodString]. (menu selectorAt: reply) == #tryInSuperclass ifTrue: [^self findMethod: aMethodString inClass: aClass superclass showMenuAt: aPoint]. ^self newSelector: (selectorArray at: reply) in: aClass! showNewClass: aClass | tempClass changeMeta | "Adjust the contents of the Browser." aClass isMeta ifTrue: [tempClass _ aClass soleInstance. changeMeta _ meta not] ifFalse: [tempClass _ aClass. changeMeta _ meta]. tempClass category ~= category ifTrue: [self newCategoryList: tempClass category]. ((tempClass ~= self selectedClass) and: [tempClass class ~= self selectedClass]) ifTrue: [self newClassList: tempClass name]. changeMeta ifTrue: [self meta: meta not]! sortSelectors: keys considering: aString "Sort selectors with respect to being closest to aString. The intermediate collection of arrays is used of effiency purposes." | selectors | selectors _ keys collect: [:sel | Array with: sel with: (sel spellAgainst: aString)]. ^(selectors asSortedCollection: [:aSel :anotherSel | (aSel at: 2) > (anotherSel at: 2)]) collect: [:sel | sel at: 1]! ! !PopUpMenu methodsFor: 'controlling'! startUp: aSymbol at: aPoint withHeading: aText "Display and make a selection from the receiver as long as the button denoted by the symbol, aSymbol, is pressed. Answer the current selection." self displayAt: aPoint withHeading: aText during: [Sensor cursorPoint: marker center. [self buttonPressed: aSymbol] whileFalse: []. [self buttonPressed: aSymbol] whileTrue: [self manageMarker]]. ^selection! ! !Browser methodsFor: 'category list'! categoryMenu "Browser flushMenus" category == nil ifTrue: [^ActionMenu labels: 'add category\update\edit all\find class' withCRs lines: #(1 3) selectors: #(addCategory updateCategories editCategories findClass)]. CategoryMenu == nil ifTrue: [CategoryMenu _ ActionMenu labels: 'file out\print out\spawn\add category\rename\remove\update\edit all\find class' withCRs lines: #(3 7 9) selectors: #(fileOutCategory printOutCategory spawnCategory addCategory renameCategory removeCategory updateCategories editCategories findClass)]. ^CategoryMenu! ! !Browser methodsFor: 'class list'! classMenu "Browser flushMenus" className == nil ifTrue: [^nil]. ClassMenu == nil ifTrue: [ClassMenu _ ActionMenu labels: 'file out\print out\spawn\spawn hierarchy\hierarchy\definition\comment\protocols\inst var refs\class var refs\class refs\rename\remove\superclass\subclass' withCRs lines: #(4 9 12 14) selectors: #(fileOutClass printOutClass spawnClass spawnHierarchy showHierarchy editClass editComment editProtocols browseFieldReferences browseClassVariables browseClassReferences renameClass removeClass findSuperclass findSubclass)]. ^ClassMenu! ! !Browser methodsFor: 'protocol list'! protocolMenu "Browser flushMenus" protocol == nil ifTrue: [^ActionMenu labels: 'add protocol\find method' withCRs lines: #(1) selectors: #(addProtocol findMethod)]. ProtocolMenu == nil ifTrue: [ProtocolMenu _ ActionMenu labels: 'file out\print out\spawn\add protocol\rename\remove\find method' withCRs lines: #(3 7) selectors: #(fileOutProtocol printOutProtocol spawnProtocol addProtocol renameProtocol removeProtocol findMethod)]. ^ProtocolMenu! !