The Trunk: Protocols-ar.20.mcz

Andreas Raab uploaded a new version of Protocols to project The Trunk:
http://source.squeak.org/trunk/Protocols-ar.20.mcz

==================== Summary ====================

Name: Protocols-ar.20
Author: ar
Time: 4 January 2010, 2:42:56 am
UUID: e6380bd6-d791-6e43-8990-f30c269f9c9f
Ancestors: Protocols-ar.19

Make Protocols unloadable: Move ProtocolBrowser, Lexicon, and InstanceBrowser to Protocols. Classify various extension methods in Protocols.

=============== Diff against Protocols-ar.19 ===============

Item was added:
+ ----- Method: Lexicon>>obtainNewSearchString (in category 'search') -----
+ obtainNewSearchString
+ "Put up a box allowing the user to enter a fresh search string"
+
+ | fragment |
+
+ fragment := UIManager default request: 'type method name or fragment: ' initialAnswer: self currentQueryParameter.
+ fragment ifNil: [^ self].
+ (fragment := fragment copyWithout: $ ) size == 0  ifTrue: [^ self].
+ currentQueryParameter := fragment.
+ fragment := fragment asLowercase.
+ currentQuery := #selectorName.
+ self showQueryResultsCategory.
+ self messageListIndex: 0!

Item was added:
+ ----- Method: PasteUpMorph>>currentVocabulary (in category '*Protocols') -----
+ currentVocabulary
+ "Answer the default Vocabulary object to be applied when scripting"
+
+ | aSym aVocab |
+ aSym := self valueOfProperty: #currentVocabularySymbol.
+ aSym ifNil:
+ [aVocab := self valueOfProperty: #currentVocabulary.
+ aVocab ifNotNil:
+ [aSym := aVocab vocabularyName.
+ self setProperty: #currentVocabularySymbol toValue: aSym.
+ self removeProperty: #currentVocabulary]].
+ ^ aSym
+ ifNotNil:
+ [Vocabulary vocabularyNamed: aSym]
+ ifNil:
+ [Vocabulary fullVocabulary]!

Item was added:
+ ----- Method: Lexicon>>removeFromSelectorsVisited: (in category 'history') -----
+ removeFromSelectorsVisited: aSelector
+ "remove aSelector from my history list"
+
+ self selectorsVisited remove: aSelector ifAbsent: []!

Item was added:
+ ----- Method: ProtocolBrowser>>growable (in category 'accessing') -----
+ growable
+ "Answer whether the receiver is subject to manual additions and deletions"
+
+ ^ false!

Item was added:
+ ----- Method: Lexicon>>removeMessage (in category 'menu commands') -----
+ removeMessage
+ "Remove the selected message from the system."
+
+ messageListIndex = 0 ifTrue: [^ self].
+ self okToChange ifFalse: [^ self].
+
+ super removeMessage.
+ "my #reformulateList method, called from the super #removeMethod method, will however try to preserve the selection, so we take pains to clobber it by the below..."
+ messageListIndex := 0.
+ self changed: #messageList.
+ self changed: #messageListIndex.
+ contents := nil.
+ self contentsChanged!

Item was added:
+ ----- Method: Lexicon>>categoryListKey:from: (in category 'category list') -----
+ categoryListKey: aChar from: aView
+ "The user hit a command-key while in the category-list.  Do something"
+
+ (aChar == $f and: [self hasSearchPane not]) ifTrue:
+ [^ self obtainNewSearchString].!

Item was added:
+ ----- Method: Lexicon>>okayToAccept (in category 'model glue') -----
+ okayToAccept
+ "Answer whether it is okay to accept the receiver's input"
+
+ | ok aClass reply |
+ (ok := super okayToAccept) ifTrue:
+ [((aClass := self selectedClassOrMetaClass) ~~ targetClass) ifTrue:
+ [reply := UIManager default chooseFrom:
+ {'okay, no problem'.
+ 'cancel - let me reconsider'.
+ 'compile into ', targetClass name, ' instead'.
+ 'compile into a new uniclass'} title:
+ 'Caution!!  This would be
+ accepted into class ', aClass name, '.
+ Is that okay?' .
+ reply = 1 ifTrue: [^ true].
+ reply ~~ 2 ifTrue:
+ [self notYetImplemented].
+ ^ false]].
+ ^ ok!

Item was added:
+ ----- Method: Lexicon>>lastSearchString (in category 'search') -----
+ lastSearchString
+ "Answer the last search string, initializing it to an empty string if it has not been initialized yet"
+
+ ^ currentQueryParameter ifNil: [currentQueryParameter := 'contents']!

Item was added:
+ ----- Method: Lexicon>>selectorsReferringToClassVar (in category 'category list') -----
+ selectorsReferringToClassVar
+ "Return a list of methods that refer to given class var that are in the
+ protocol of this object"
+ | aList aClass nonMeta poolAssoc |
+ nonMeta := targetClass theNonMetaClass.
+ aClass := nonMeta classThatDefinesClassVariable: currentQueryParameter.
+ aList := OrderedCollection new.
+ poolAssoc := aClass classPool associationAt: currentQueryParameter asSymbol.
+ (self systemNavigation allCallsOn: poolAssoc)
+ do: [:elem | (nonMeta isKindOf: elem actualClass)
+ ifTrue: [aList add: elem methodSymbol]].
+ ^ aList!

Item was added:
+ ----- Method: Lexicon>>categoryWithNameSpecifiedBy: (in category 'category list') -----
+ categoryWithNameSpecifiedBy: aSelector
+ "Answer the category name obtained by sending aSelector to my class.  This provides a way to avoid hard-coding the wording of conventions such as '-- all --'"
+
+ ^ self class perform: aSelector!

Item was added:
+ ----- Method: PasteUpMorph>>makeVectorUseConformToPreference (in category '*Protocols') -----
+ makeVectorUseConformToPreference
+ "Make certain that the use of vectors in this project conforms to the current preference setting."
+
+ | prefValue currentValue |
+ prefValue := Preferences useVectorVocabulary.
+ currentValue := self currentlyUsingVectorVocabulary.
+ prefValue ~~ currentValue ifTrue:
+ [currentValue
+ ifTrue:
+ [self abandonVocabularyPreference]
+ ifFalse:
+ [self installVectorVocabulary]]!

Item was added:
+ ----- Method: Lexicon class>>viewedCategoryName (in category 'visible category names') -----
+ viewedCategoryName
+ "Answer the name to be used for the previously-viewed-methods category"
+
+ true ifTrue: [^ #'-- active --'].
+
+ ^ '-- active --' asSymbol "For benefit of method-strings-containing-it search"
+ !

Item was added:
+ ----- Method: Lexicon>>limitClassString (in category 'limit class') -----
+ limitClassString
+ "Answer a string representing the current choice of most-generic-class-to-show"
+
+ | most |
+ (most := self limitClass) == ProtoObject
+ ifTrue: [^ 'All'].
+ most == targetClass
+ ifTrue: [^ most name].
+ ^ 'Only through ', most name!

Item was added:
+ ----- Method: Lexicon>>showHomeCategory (in category 'menu commands') -----
+ showHomeCategory
+ "Continue to show the current selector, but show it within the context of its primary category"
+
+ | aSelector |
+ (aSelector := self selectedMessageName) ifNotNil:
+ [self preserveSelectorIfPossibleSurrounding:
+ [self setToShowSelector: aSelector]]!

Item was added:
+ ----- Method: Lexicon class>>allCategoryName (in category 'visible category names') -----
+ allCategoryName
+ "Answer the name to be used for the all category"
+
+ true ifTrue: [^ #'-- all --'].
+
+ '-- all --' asSymbol  "Placed here so a message-strings-containing-it query will find this method"
+ !

Item was added:
+ ----- Method: Lexicon>>targetObject (in category 'model glue') -----
+ targetObject
+ "Answer the object to which this tool is bound."
+
+ ^ nil!

Item was added:
+ ----- Method: Lexicon>>categoryListMenuTitle (in category 'category list') -----
+ categoryListMenuTitle
+ "Answer the menu title for the category list menu"
+
+ ^ 'categories'!

Item was added:
+ ----- Method: Lexicon>>maybeReselectClass:selector: (in category 'transition') -----
+ maybeReselectClass: aClass selector: aSelector
+ "The protocol or limitClass may have changed, so that there is a different categoryList.  Formerly, the given class and selector were selected; if it is possible to do so, reselect them now"
+
+ aClass ifNil: [^ self].
+ (currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass)
+ ifTrue:
+ [self selectSelectorItsNaturalCategory: aSelector]!

Item was added:
+ ----- Method: Lexicon>>categoryDefiningSelector: (in category 'category list') -----
+ categoryDefiningSelector: aSelector
+ "Answer a category in which aSelector occurs"
+
+ | categoryNames |
+ categoryNames := categoryList copyWithoutAll: #('-- all --').
+ ^ currentVocabulary categoryWithNameIn: categoryNames thatIncludesSelector: aSelector forInstance: self targetObject ofClass: targetClass!

Item was added:
+ ----- Method: Lexicon>>categoryOfSelector: (in category 'selection') -----
+ categoryOfSelector: aSelector
+ "Answer the name of the defining category for aSelector, or nil if none"
+ | classDefiningSelector |
+ classDefiningSelector := targetClass whichClassIncludesSelector: aSelector.
+ classDefiningSelector
+ ifNil: [^ nil].
+ "can happen for example if one issues this from a change-sorter for a
+ message that is recorded as having been removed"
+ ^ classDefiningSelector whichCategoryIncludesSelector: aSelector!

Item was added:
+ ----- Method: Lexicon>>buildCustomButtonsWith: (in category 'toolbuilder') -----
+ buildCustomButtonsWith: builder
+
+ "This method if very similar to StringHolder>>buildOptionalButtonsWith:.
+ Refactor and pass in button specs?"
+ | panelSpec |
+ panelSpec := builder pluggablePanelSpec new.
+ panelSpec children: OrderedCollection new.
+ self customButtonSpecs do: [:spec | | buttonSpec |
+ buttonSpec := builder pluggableActionButtonSpec new.
+ buttonSpec model: self.
+ buttonSpec label: spec first.
+ buttonSpec action: spec second.
+ spec size > 2 ifTrue: [buttonSpec help: spec third].
+ panelSpec children add: buttonSpec.
+ ].
+ panelSpec layout: #horizontal. "buttons"
+ self addSpecialButtonsTo: panelSpec with: builder.
+ ^panelSpec!

Item was added:
+ ----- Method: ProtocolBrowser>>selector (in category 'accessing') -----
+ selector
+ "Answer the receiver's selected selector."
+ ^ selectedSelector!

Item was added:
+ ----- Method: Lexicon>>annotation (in category 'basic operation') -----
+ annotation
+ "Provide a line of annotation material for a middle pane."
+
+ | aCategoryName |
+ self selectedMessageName ifNotNil: [^ super annotation].
+ (aCategoryName := self selectedCategoryName) ifNil:
+ [^ self hasSearchPane
+ ifTrue:
+ ['type a message name or fragment in the top pane and hit RETURN or ENTER']
+ ifFalse:
+ [''  "currentVocabulary documentation"]].
+
+
+ (aCategoryName = self class queryCategoryName) ifTrue:
+ [^ self queryCharacterization].
+
+ #(
+ (allCategoryName 'Shows all methods, whatever other category they belong to')
+ (viewedCategoryName 'Methods visited recently.  Use  "-" button to remove a method from this category.')
+ (queryCategoryName 'Query results'))
+
+ do:
+ [:pair | (self categoryWithNameSpecifiedBy: pair first) = aCategoryName ifTrue: [^ pair second]].
+
+ ^ currentVocabulary categoryCommentFor: aCategoryName!

Item was added:
+ ----- Method: Lexicon>>buildWith: (in category 'toolbuilder') -----
+ buildWith: builder
+ "Create the ui for the browser"
+ | windowSpec max |
+ max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4].
+ windowSpec := self buildWindowWith: builder specs: {
+ (0@0 corner: 0.5@max) -> [self buildCategoryListWith: builder].
+ (0.5@0 corner: 1@max) -> [self buildMessageListWith: builder].
+ (0@max corner: 1@1) -> [self buildCodePaneWith: builder].
+ }.
+ ^builder build: windowSpec!

Item was added:
+ ----- Method: Lexicon>>lastSendersSearchSelector (in category 'search') -----
+ lastSendersSearchSelector
+ "Answer the last senders search selector, initializing it to a default value if it does not already have a value"
+
+ ^ currentQueryParameter ifNil: [currentQueryParameter := #flag:]!

Item was added:
+ ----- Method: ProtocolBrowser>>list (in category 'accessing') -----
+ list
+ "Answer the receiver's message list."
+ ^ messageList!

Item was added:
+ ----- Method: Lexicon>>startingWindowTitle (in category 'window title') -----
+ startingWindowTitle
+ "Answer the initial window title to apply"
+
+ ^ 'Vocabulary of ', targetClass nameForViewer!

Item was added:
+ ----- Method: Lexicon>>selectedCategoryName (in category 'category list') -----
+ selectedCategoryName
+ "Answer the selected category name"
+
+ ^ categoryList ifNotNil:
+ [categoryList at: categoryListIndex ifAbsent: [nil]]!

Item was added:
+ ----- Method: Lexicon>>browseInstVarRefs (in category 'new-window queries') -----
+ browseInstVarRefs
+ "Let the search pertain to the target class regardless of selection"
+ self systemNavigation  browseInstVarRefs: targetClass!

Item was added:
+ ----- Method: InstanceBrowser class>>windowColorSpecification (in category 'window color') -----
+ windowColorSpecification
+ "Answer a WindowColorSpec object that declares my preference"
+
+ ^ WindowColorSpec classSymbol: self name wording: 'Instance Browser' brightColor: #(0.806 1.0 1.0) pastelColor: #(0.925 1.000 1.0) helpMessage: 'A tool for browsing the full protocol of an instance.'!

Item was added:
+ ProtocolBrowser subclass: #Lexicon
+ instanceVariableNames: 'currentVocabulary categoryList categoryListIndex targetClass limitClass currentQuery currentQueryParameter selectorsVisited'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Protocols-Tools'!
+
+ !Lexicon commentStamp: '<historical>' prior: 0!
+ An instance of Lexicon shows the a list of all the method categories known to an object or any of its superclasses, as a "flattened" list, and, within any selected category, shows all methods understood by the class's instances which are associated with that category, again as a "flattened" list.  A variant with a search pane rather than a category list is also implemented.
+
+ categoryList the list of categories
+ categoryListIndex index of currently-selected category
+ targetObject optional -- an instance being viewed
+ targetClass the class being viewed
+ lastSearchString the last string searched for
+ lastSendersSearchSelector the last senders search selector
+ limitClass optional -- the limit class to search for
+ selectorsVisited list of selectors visited
+ selectorsActive not presently in use, subsumed by selectorsVisited
+ currentVocabulary the vocabulary currently installed
+ currentQuery what the query category relates to:
+ #senders #selectorName #currentChangeSet!

Item was added:
+ ----- Method: Lexicon>>removeFromSelectorsVisited (in category 'history') -----
+ removeFromSelectorsVisited
+ "Remove the currently-selected method from the active set"
+
+ | aSelector |
+ (aSelector := self selectedMessageName) ifNil: [^ self].
+ self removeFromSelectorsVisited: aSelector.
+ self chooseCategory: self class viewedCategoryName!

Item was added:
+ ----- Method: Lexicon>>limitClass: (in category 'limit class') -----
+ limitClass: aClass
+ "Set the most generic class to show as indicated"
+
+ limitClass := aClass!

Item was added:
+ ----- Method: Lexicon>>showSearchPane (in category 'search') -----
+ showSearchPane
+ "Given that the receiver is showing the categories pane, replace that with a search pane.  Though there is a residual UI for obtaining this variant, it is obscure and the integrity of the protocol-category-browser when there is no categories pane is not necessarily assured at the moment."
+
+ | aPane |
+ (aPane := self categoriesPane) ifNil: [^ Beeper beep].
+ self containingWindow replacePane: aPane with: self newSearchPane.
+ categoryList := nil.
+ self changed: #categoryList.
+ self changed: #messageList!

Item was added:
+ ----- Method: Lexicon>>categoriesPane (in category 'category list') -----
+ categoriesPane
+ "If there is a pane defined by #categoryList in my containing window, answer it, else answer nil"
+
+ ^ self listPaneWithSelector: #categoryList!

Item was added:
+ ----- Method: Inspector>>spawnFullProtocol (in category '*Protocols-Tools') -----
+ spawnFullProtocol
+ "Spawn a window showing full protocol for the receiver's selection"
+
+ | objectToRepresent |
+ objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
+ ProtocolBrowser openFullProtocolForClass: objectToRepresent class!

Item was added:
+ ----- Method: Lexicon>>showMethodsInCurrentChangeSet (in category 'within-tool queries') -----
+ showMethodsInCurrentChangeSet
+ "Set the current query to be for methods in the current change set"
+
+ currentQuery := #currentChangeSet.
+ autoSelectString := nil.
+ self categoryListIndex: (categoryList indexOf: self class queryCategoryName).!

Item was added:
+ ----- Method: Lexicon>>queryCharacterization (in category 'within-tool queries') -----
+ queryCharacterization
+ "Answer a characterization of the most recent query"
+
+ currentQuery == #selectorName
+ ifTrue: [^ 'My methods whose names include "', self lastSearchString, '"'].
+ currentQuery == #methodsWithInitials
+ ifTrue: [^ 'My methods stamped with initials ', currentQueryParameter].
+ currentQuery == #senders
+ ifTrue: [^ 'My methods that send #', self lastSendersSearchSelector].
+ currentQuery == #currentChangeSet
+ ifTrue: [^ 'My methods in the current change set'].
+ currentQuery == #instVarRefs
+ ifTrue: [^ 'My methods that refer to instance variable "', currentQueryParameter, '"'].
+ currentQuery == #instVarDefs
+ ifTrue: [^ 'My methods that store into instance variable "', currentQueryParameter, '"'].
+ currentQuery == #classVarRefs
+ ifTrue: [^ 'My methods that refer to class variable "', currentQueryParameter, '"'].
+ ^ 'Results of queries will show up here'!

Item was added:
+ ----- Method: Lexicon>>selectorsDefiningInstVar (in category 'within-tool queries') -----
+ selectorsDefiningInstVar
+ "Return a list of methods that define a given inst var that are in the protocol of this object"
+
+ | aList  |
+ aList := OrderedCollection new.
+ targetClass withAllSuperclassesDo:
+ [:aClass |
+ (aClass whichSelectorsStoreInto: currentQueryParameter asString) do:
+ [:sel | sel isDoIt ifFalse: [aList add: sel]
+ ]
+ ].
+ ^ aList!

Item was added:
+ ----- Method: Object>>haveFullProtocolBrowsedShowingSelector: (in category '*Protocols') -----
+ haveFullProtocolBrowsedShowingSelector: aSelector
+ "Open up a Lexicon on the receiver, having it open up showing aSelector, which may be nil"
+
+ | aBrowser |
+ aBrowser := (Smalltalk at: #InstanceBrowser ifAbsent:[^nil]) new useVocabulary: Vocabulary fullVocabulary.
+ aBrowser openOnObject: self inWorld: ActiveWorld showingSelector: aSelector
+
+ "(2@3) haveFullProtocolBrowsed"!

Item was added:
+ ----- Method: Lexicon>>chooseLimitClass (in category 'limit class') -----
+ chooseLimitClass
+ "Put up a menu allowing the user to choose the most generic class to show"
+
+ | aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
+ targetClass withAllSuperclasses do:
+ [:aClass |
+ aClass == ProtoObject
+ ifTrue:
+ [aMenu addLine].
+ aMenu add: aClass name selector: #setLimitClass: argument: aClass.
+ aClass == limitClass ifTrue:
+ [aMenu lastItem color: Color red].
+ aClass == targetClass ifTrue: [aMenu addLine]].
+ aMenu addTitle: 'Show only methods
+ implemented at or above...'.  "heh heh -- somebody please find nice wording here!!"
+ aMenu popUpInWorld: self currentWorld!

Item was added:
+ ----- Method: Lexicon>>showMethodsWithInitials (in category 'within-tool queries') -----
+ showMethodsWithInitials
+ "Prompt the user for initials to scan for; then show, in the query-results category, all methods with those initials in their time stamps"
+
+ | initials |
+ initials := UIManager default request: 'whose initials? ' initialAnswer: Utilities authorInitials.
+ initials isEmptyOrNil ifTrue: [^ self].
+ self showMethodsWithInitials: initials
+
+
+ !

Item was added:
+ ----- Method: Lexicon>>openOnClass:showingSelector: (in category 'toolbuilder') -----
+ openOnClass: aTargetClass showingSelector: aSelector
+
+ currentVocabulary ifNil: [currentVocabulary := Vocabulary fullVocabulary].
+ targetClass := aTargetClass.
+ self initialLimitClass.
+
+ self reformulateCategoryList.
+ ToolBuilder open: self.
+ self adjustWindowTitle.!

Item was added:
+ ----- Method: ProtocolBrowser>>selectedClassOrMetaClass (in category 'class list') -----
+ selectedClassOrMetaClass
+ ^selectedClass!

Item was added:
+ ----- Method: ProtocolBrowser>>setClassAndSelectorIn: (in category 'private') -----
+ setClassAndSelectorIn: csBlock
+ "Decode strings of the form    <selectorName> (<className> [class])"
+
+ | i classAndSelString selString sel |
+
+ sel := self selection ifNil: [^ csBlock value: nil value: nil].
+ (sel isKindOf: MethodReference) ifTrue: [
+ sel setClassAndSelectorIn: csBlock
+ ] ifFalse: [
+ selString := sel asString.
+ i := selString indexOf: $(.
+ "Rearrange to  <className> [class] <selectorName> , and use MessageSet"
+ classAndSelString := (selString copyFrom: i + 1 to: selString size - 1) , ' ' ,
+ (selString copyFrom: 1 to: i - 1) withoutTrailingBlanks.
+ MessageSet parse: classAndSelString toClassAndSelector: csBlock.
+ ].
+ !

Item was added:
+ ----- Method: Lexicon class>>activeCategoryName (in category 'visible category names') -----
+ activeCategoryName
+ "Answer the name to be used for the active-methods category"
+
+ true ifTrue: [^ #'-- current working set --'].
+
+ '-- current working set --' asSymbol "Placed here so a message-strings-containing-it query will find this method"
+ !

Item was added:
+ ----- Method: Lexicon>>setLocalClassVarRefs (in category 'within-tool queries') -----
+ setLocalClassVarRefs
+ "Put up a list of the class variables in the viewed object, and when the user selects one, let the query results category show all the references to that class variable."
+
+ | aName |
+
+ (aName := targetClass theNonMetaClass chooseClassVarName) ifNil: [^ self].
+ currentQuery := #classVarRefs.
+ currentQueryParameter := aName.
+ self showQueryResultsCategory!

Item was added:
+ ----- Method: Lexicon>>canShowMultipleMessageCategories (in category 'message category functions') -----
+ canShowMultipleMessageCategories
+ "Answer whether the receiver is capable of showing multiple message categories"
+
+ ^ true!

Item was added:
+ ----- Method: Lexicon>>newCategoryPane (in category 'category list') -----
+ newCategoryPane
+ "Formulate a category pane for insertion into the receiver's pane list"
+
+ | aListMorph |
+ aListMorph := PluggableListMorph on: self list: #categoryList
+ selected: #categoryListIndex changeSelected: #categoryListIndex:
+ menu: #categoryListMenu:shifted:
+ keystroke: #categoryListKey:from:.
+ aListMorph setNameTo: 'categoryList'.
+ aListMorph menuTitleSelector: #categoryListMenuTitle.
+ ^ aListMorph!

Item was added:
+ ----- Method: Lexicon>>chooseVocabulary (in category 'vocabulary') -----
+ chooseVocabulary
+ "Put up a dialog affording the user a chance to choose a different vocabulary to be installed in the receiver"
+
+ | aMenu |
+ Smalltalk at: #Vocabulary ifPresent:[:aClass|
+ aMenu := MenuMorph new defaultTarget: self.
+ aMenu addTitle: 'Choose a vocabulary
+ blue = current
+ red = imperfect' translated.
+ aMenu addStayUpItem.
+ aClass allStandardVocabularies do:[:aVocabulary |
+ (targetClass implementsVocabulary: aVocabulary)
+ ifTrue:
+ [aMenu add: aVocabulary vocabularyName selector: #switchToVocabulary: argument: aVocabulary.
+ (targetClass fullyImplementsVocabulary: aVocabulary) ifFalse:
+ [aMenu lastItem color: Color red].
+ aVocabulary == currentVocabulary ifTrue:
+ [aMenu lastItem color: Color blue].
+ aMenu balloonTextForLastItem: aVocabulary documentation]].
+ aMenu popUpInWorld: self currentWorld
+ ].!

Item was added:
+ ----- Method: Lexicon>>setToShowSelector: (in category 'selection') -----
+ setToShowSelector: aSelector
+ "Set up the receiver so that it will show the given selector"
+
+ | catName catIndex detectedItem messageIndex aList |
+ catName := (aList := currentVocabulary categoriesContaining: aSelector  forClass: targetClass) size > 0
+ ifTrue:
+ [aList first]
+ ifFalse:
+ [self class allCategoryName].
+ catIndex := categoryList indexOf: catName ifAbsent: [1].
+ self categoryListIndex: catIndex.
+ detectedItem := messageList detect:
+ [:anItem | (anItem upTo: $ ) asString asSymbol == aSelector] ifNone: [^ self].
+ messageIndex := messageList indexOf: detectedItem.
+ self messageListIndex: messageIndex
+ !

Item was added:
+ ----- Method: PasteUpMorph>>installVectorVocabulary (in category '*Protocols') -----
+ installVectorVocabulary
+ "Install the experimental Vector vocabulary as the default for the current project"
+
+ | standardViewers aVocabulary |
+ self setProperty: #currentVocabularySymbol toValue: #Vector.
+ standardViewers := (self submorphsSatisfying: [:m | m isKindOf: ViewerFlapTab]) collect:
+ [:m | m referent firstSubmorph].
+ aVocabulary := Vocabulary vocabularyNamed: #Vector.
+ standardViewers do: [:m | m switchToVocabulary: aVocabulary]!

Item was added:
+ ----- Method: Lexicon>>navigateToNextMethod (in category 'history') -----
+ navigateToNextMethod
+ "Navigate to the 'next' method in the current viewing sequence"
+
+ | anIndex aSelector |
+ self selectorsVisited size == 0 ifTrue: [^ self].
+ anIndex := (aSelector := self selectedMessageName) notNil ifTrue: [selectorsVisited indexOf: aSelector ifAbsent: [selectorsVisited size]] ifFalse: [1].
+ self selectedCategoryName == self class viewedCategoryName
+ ifTrue:
+ [self selectWithinCurrentCategory: (selectorsVisited atWrap: (anIndex + 1))]
+ ifFalse:
+ [self displaySelector: (selectorsVisited atWrap: (anIndex + 1))]!

Item was added:
+ ----- Method: Lexicon>>selectorsChanged (in category 'within-tool queries') -----
+ selectorsChanged
+ "Return a list of methods in the current change set (or satisfying some
+ other such criterion) that are in the protocol of this object"
+ | aList targetedClass |
+ targetedClass := self targetObject
+ ifNil: [targetClass]
+ ifNotNil: [self targetObject class].
+ aList := OrderedCollection new.
+ ChangeSet current methodChanges
+ associationsDo: [:classChgAssoc | classChgAssoc value
+ associationsDo: [:methodChgAssoc | | aClass | (methodChgAssoc value == #change
+ or: [methodChgAssoc value == #add])
+ ifTrue: [(aClass := targetedClass whichClassIncludesSelector: methodChgAssoc key)
+ ifNotNil: [aClass name = classChgAssoc key
+ ifTrue: [aList add: methodChgAssoc key]]]]].
+ ^ aList!

Item was changed:
  ----- Method: Vocabulary class>>initializeStandardVocabularies (in category 'class initialization') -----
  initializeStandardVocabularies
  "Initialize a few standard vocabularies and place them in the AllStandardVocabularies list."
 
  AllStandardVocabularies _ nil.
  Smalltalk at: #EToyVocabulary
  ifPresent:[:aClass| self addStandardVocabulary: aClass new].
  Smalltalk at: #EToyVectorVocabulary
  ifPresent:[:aClass| self addStandardVocabulary: aClass new].
 
  self addStandardVocabulary: self newPublicVocabulary.
  self addStandardVocabulary: FullVocabulary new.
 
  self addStandardVocabulary: self newQuadVocabulary.
 
  self addStandardVocabulary: ColorType new.
  self addStandardVocabulary: BooleanType new.
  self addStandardVocabulary: GraphicType new.
  Smalltalk at: #PlayerType
  ifPresent:[:aClass| self addStandardVocabulary: aClass new].
  self addStandardVocabulary: SoundType new.
  self addStandardVocabulary: StringType new.
  self addStandardVocabulary: MenuType new.
  self addStandardVocabulary: UnknownType new.
  Smalltalk at: #ScriptNameType
  ifPresent:[:aClass| self addStandardVocabulary: aClass new].
 
  self addStandardVocabulary: (SymbolListType new symbols: #(simple raised inset complexFramed complexRaised complexInset complexAltFramed complexAltRaised complexAltInset); vocabularyName: #BorderStyle; yourself).
  self addStandardVocabulary: (SymbolListType new symbols: #(lines arrows arrowheads dots); vocabularyName: #TrailStyle; yourself).
  self addStandardVocabulary: (SymbolListType new symbols: #(leftToRight rightToLeft topToBottom bottomToTop); vocabularyName: #ListDirection; yourself).
 
  self addStandardVocabulary: (SymbolListType new symbols: #(topLeft bottomRight center justified); vocabularyName: #ListCentering; yourself).
 
  self addStandardVocabulary: (SymbolListType new symbols: #(buttonDown whilePressed buttonUp); vocabularyName: #ButtonPhase; yourself).
 
  self addStandardVocabulary: (SymbolListType new symbols: #(rotate #'do not rotate' #'flip left right' #'flip up down'); vocabularyName: #RotationStyle; yourself).
 
  self addStandardVocabulary: (SymbolListType new symbols: #(rigid spaceFill shrinkWrap); vocabularyName: #Resizing; yourself).
 
  self addStandardVocabulary: self newSystemVocabulary.  "A custom vocabulary for Smalltalk -- still under development)"
 
  self numberVocabulary.   "creates and adds it"
+ "self wonderlandVocabulary."   "creates and adds it"
- self wonderlandVocabulary.   "creates and adds it"
  self vocabularyForClass: Time.   "creates and adds it"
 
  Smalltalk at: #KedamaPatchType ifPresent:[:aClass|
  self addStandardVocabulary: (aClass new vocabularyName: #Patch; yourself).
  ].
  self addStandardVocabulary: (SymbolListType new symbols: #(wrap stick bouncing); vocabularyName: #EdgeMode; yourself).
  self addStandardVocabulary: (SymbolListType new symbols: #(logScale linear color); vocabularyName: #PatchDisplayMode; yourself).
 
  "Vocabulary initialize"!

Item was added:
+ ----- Method: Lexicon>>doItReceiver (in category 'model glue') -----
+ doItReceiver
+ "This class's classPool has been jimmied to be the classPool of the class being browsed. A doIt in the code pane will let the user see the value of the class variables.  Here, if the receiver is affiliated with a specific instance, we give give that primacy"
+
+ ^ self targetObject ifNil: [self selectedClass ifNil: [FakeClassPool new]]!

Item was added:
+ ----- Method: ProtocolBrowser>>initListFrom:highlighting: (in category 'private') -----
+ initListFrom: selectorCollection highlighting: aClass
+ "Make up the messageList with items from aClass in boldface."
+ messageList := OrderedCollection new.
+ selectorCollection do: [ :selector |  
+ | defClass item |
+ defClass := aClass whichClassIncludesSelector: selector.
+ item := selector, '     (' , defClass name , ')'.
+ defClass == aClass ifTrue: [item := item asText allBold].
+ messageList add: (
+ MethodReference new
+ setClass: defClass
+ methodSymbol: selector
+ stringVersion: item
+ )
+ ].
+ selectedClass := aClass.!

Item was added:
+ ----- Method: Lexicon>>wantsAnnotationPane (in category 'toolbuilder') -----
+ wantsAnnotationPane
+ "This kind of browser always wants annotation panes, so answer true"
+
+ ^ true!

Item was added:
+ ----- Method: Lexicon>>browseClassVarRefs (in category 'new-window queries') -----
+ browseClassVarRefs
+ "Let the search pertain to the target class regardless of selection"
+
+ self systemNavigation  browseClassVarRefs: targetClass theNonMetaClass !

Item was added:
+ ----- Method: PasteUpMorph>>abandonVocabularyPreference (in category '*Protocols') -----
+ abandonVocabularyPreference
+ "Remove any memory of a preferred vocabulary in the project"
+
+ | standardViewers aVocabulary |
+ self removeProperty: #currentVocabularySymbol.
+
+ standardViewers := (self submorphsSatisfying: [:m | m isKindOf: ViewerFlapTab]) collect:
+ [:m | m referent firstSubmorph].
+ aVocabulary := Vocabulary vocabularyNamed: #eToy.
+ standardViewers do:
+ [:m | ((m valueOfProperty: #currentVocabularySymbol ifAbsent: [nil]) == #Vector) ifTrue:
+ [m switchToVocabulary: aVocabulary]]
+
+ "ActiveWorld abandonVocabularyPreference"!

Item was added:
+ ----- Method: Lexicon>>switchToVocabulary: (in category 'vocabulary') -----
+ switchToVocabulary: aVocabulary
+ "Make aVocabulary be the current one in the receiver"
+
+ self preserveSelectorIfPossibleSurrounding:
+ [self useVocabulary: aVocabulary.
+ self reformulateCategoryList.
+ self adjustWindowTitle]
+ !

Item was added:
+ ----- Method: InstanceBrowser>>inspectViewee (in category 'menu commands') -----
+ inspectViewee
+ "Open an Inspector on the object I view"
+
+ objectViewed inspect!

Item was added:
+ ----- Method: Lexicon>>preserveSelectorIfPossibleSurrounding: (in category 'transition') -----
+ preserveSelectorIfPossibleSurrounding: aBlock
+ "Make a note of the currently-selected method; perform aBlock and then attempt to reestablish that same method as the selected one in the new circumstances"
+
+ | aClass aSelector |
+ aClass := self selectedClassOrMetaClass.
+ aSelector := self selectedMessageName.
+ aBlock value.
+
+ self hasSearchPane
+ ifTrue:
+ [self setMethodListFromSearchString]
+ ifFalse:
+ [self maybeReselectClass: aClass selector: aSelector]!

Item was added:
+ ----- Method: Lexicon>>selectWithinCurrentCategory: (in category 'selection') -----
+ selectWithinCurrentCategory: aSelector
+ "If aSelector is one of the selectors seen in the current category, select it"
+
+ | detectedItem |
+ detectedItem := self messageList detect:
+ [:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ self].
+ self messageListIndex:  (messageList indexOf: detectedItem ifAbsent: [^ self])!

Item was added:
+ ----- Method: Lexicon>>buildCodePaneWith: (in category 'toolbuilder') -----
+ buildCodePaneWith: builder
+
+ | spec standardButtonPanel codePane customPanelSpec |
+ spec := super buildCodePaneWith: builder.
+ standardButtonPanel := spec children
+ detect: [:ea | ea isKindOf:  PluggablePanelSpec]
+ ifNone: [^ spec]. "do nothing if optionalButtons not enabled"
+ customPanelSpec := self buildCustomButtonsWith: builder.
+ customPanelSpec frame: (0@0.12 corner: 1@0.24).
+ spec children add: customPanelSpec after: standardButtonPanel.
+ "resize code pane so that new panel fits in"
+ codePane := spec children detect: [:ea | ea isKindOf:  PluggableCodePaneSpec].
+ codePane frame:  (codePane frame withTop: 0.24).
+ ^ spec.!

Item was added:
+ ----- Method: Lexicon>>selectorsVisited (in category 'history') -----
+ selectorsVisited
+ "Answer the list of selectors visited in this tool"
+
+ ^ selectorsVisited ifNil: [selectorsVisited := OrderedCollection new]!

Item was added:
+ ----- Method: Inspector>>spawnProtocol (in category '*Protocols-Tools') -----
+ spawnProtocol
+ "Spawn a protocol on browser on the receiver's selection"
+
+ | objectToRepresent |
+ objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
+ ProtocolBrowser openSubProtocolForClass: objectToRepresent class!

Item was added:
+ ----- Method: Lexicon>>categoryListMenu:shifted: (in category 'category list') -----
+ categoryListMenu: aMenu shifted: aBoolean
+ "Answer the menu for the category list"
+
+ ^ aMenu labels: 'find...(f)' lines: #() selections: #(obtainNewSearchString)!

Item was added:
+ ----- Method: Lexicon>>openOnClass:inWorld:showingSelector: (in category 'toolbuilder') -----
+ openOnClass: aTargetClass inWorld: ignored showingSelector: aSelector
+
+ ^self openOnClass: aTargetClass showingSelector: aSelector!

Item was added:
+ ----- Method: ProtocolBrowser>>setSelector: (in category 'accessing') -----
+ setSelector: aString
+ "Set the currently selected message selector to be aString."
+ selectedSelector := aString!

Item was added:
+ ----- Method: CodeHolder>>spawnFullProtocol (in category '*Protocols-Tools') -----
+ spawnFullProtocol
+ "Create and schedule a new protocol browser on the currently selected class or meta."
+
+ | aClassOrMetaclass |
+ (aClassOrMetaclass := self selectedClassOrMetaClass) ifNotNil:
+         [ProtocolBrowser openFullProtocolForClass: aClassOrMetaclass]!

Item was added:
+ ----- Method: ProtocolBrowser>>getList (in category 'accessing') -----
+ getList
+ "Answer the receiver's message list."
+ ^ messageList!

Item was added:
+ ----- Method: Lexicon>>methodsWithInitials (in category 'within-tool queries') -----
+ methodsWithInitials
+ "Answer the list of method selectors within the scope of this tool whose time stamps begin with the initials designated by my currentQueryParameter"
+
+ ^ self methodsWithInitials: currentQueryParameter!

Item was added:
+ ----- Method: Lexicon>>selectImplementedMessageAndEvaluate: (in category 'selection') -----
+ selectImplementedMessageAndEvaluate: aBlock
+ "Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector.  If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any.  In this variant, only selectors "
+
+ | selector method messages |
+ (selector := self selectedMessageName) ifNil: [^ self].
+ method := (self selectedClassOrMetaClass ifNil: [^ self])
+ compiledMethodAt: selector
+ ifAbsent: [].
+ (method isNil or: [(messages := method messages) size == 0])
+ ifTrue: [^ aBlock value: selector].
+ (messages size == 1 and: [messages includes: selector])
+ ifTrue:
+ [^ aBlock value: selector].  "If only one item, there is no choice"
+
+ messages := messages select: [:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass].
+ self systemNavigation
+ showMenuOf: messages
+ withFirstItem: selector
+ ifChosenDo: [:sel | aBlock value: sel]!

Item was added:
+ ----- Method: InstanceBrowser>>offerMenu (in category 'menu commands') -----
+ offerMenu
+ "Offer a menu to the user, in response to the hitting of the menu button on the tool pane"
+
+ | aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
+ aMenu title: 'Messages of ', objectViewed nameForViewer.
+ aMenu addStayUpItem.
+ aMenu addList: #(
+ ('vocabulary...' chooseVocabulary)
+ ('what to show...' offerWhatToShowMenu)
+ -
+ ('inst var refs (here)' setLocalInstVarRefs)
+ ('inst var defs (here)' setLocalInstVarDefs)
+ ('class var refs (here)' setLocalClassVarRefs)
+ -
+
+ ('navigate to a sender...' navigateToASender)
+ ('recent...' navigateToRecentMethod)
+ ('show methods in current change set'
+ showMethodsInCurrentChangeSet)
+ ('show methods with initials...'
+ showMethodsWithInitials)
+ -
+ "('toggle search pane' toggleSearch)"
+
+ -
+ -
+ ('browse full (b)' browseMethodFull)
+ ('browse hierarchy (h)' classHierarchy)
+ ('browse method (O)' openSingleMessageBrowser)
+ ('browse protocol (p)' browseFullProtocol)
+ -
+ ('fileOut' fileOutMessage)
+ ('printOut' printOutMessage)
+ -
+ ('senders of... (n)' browseSendersOfMessages)
+ ('implementors of... (m)' browseMessages)
+ ('versions (v)' browseVersions)
+ ('inheritance (i)' methodHierarchy)
+ -
+ ('inst var refs' browseInstVarRefs)
+ ('inst var defs' browseInstVarDefs)
+ ('class var refs' browseClassVarRefs)
+ -
+ ('viewer on me' viewViewee)
+ ('inspector on me' inspectViewee)
+ -
+ ('more...' shiftedYellowButtonActivity)).
+
+ aMenu popUpInWorld: ActiveWorld!

Item was added:
+ ----- Method: Lexicon>>setLocalInstVarRefs (in category 'within-tool queries') -----
+ setLocalInstVarRefs
+ "Put up a list of the instance variables in the viewed object, and when the user seletcts one, let the query results category show all the references to that instance variable."
+
+ | instVarToProbe |
+
+ targetClass chooseInstVarThenDo:
+ [:aName | instVarToProbe := aName].
+ instVarToProbe isEmptyOrNil ifTrue: [^ self].
+ currentQuery := #instVarRefs.
+ currentQueryParameter := instVarToProbe.
+ self showQueryResultsCategory!

Item was added:
+ ----- Method: Lexicon>>retainMethodSelectionWhileSwitchingToCategory: (in category 'transition') -----
+ retainMethodSelectionWhileSwitchingToCategory: aCategoryName
+ "retain method selection while switching the category-pane selection to show the category of the given name"
+
+ | aSelectedName |
+ aSelectedName := self selectedMessageName.
+ self categoryListIndex: (categoryList indexOf: aCategoryName ifAbsent: [^ self]).
+ aSelectedName ifNotNil: [self selectWithinCurrentCategory: aSelectedName]
+ !

Item was added:
+ ----- Method: Lexicon>>reformulateListNoting: (in category 'transition') -----
+ reformulateListNoting: newSelector
+ "A method has possibly been submitted for the receiver with newSelector as its selector; If the receiver has a way of reformulating its message list, here is a chance for it to do so"
+
+ super reformulateListNoting: newSelector.
+ newSelector ifNotNil:
+ [self displaySelector: newSelector]!

Item was added:
+ ----- Method: ProtocolBrowser class>>openFullProtocolForClass: (in category 'instance creation') -----
+ openFullProtocolForClass: aClass
+ "Create and schedule a browser for the entire protocol of the class."
+ "ProtocolBrowser openFullProtocolForClass: ProtocolBrowser."
+ | aPBrowser label |
+ aPBrowser := ProtocolBrowser new on: aClass.
+ label := 'Entire protocol of: ', aClass name.
+ self open: aPBrowser name: label!

Item was added:
+ ----- Method: Lexicon>>navigateToASender (in category 'senders') -----
+ navigateToASender
+ "Present the user with a list of senders of the currently-selected
+ message, and navigate to the chosen one"
+ | selectorSet chosen aSelector |
+ aSelector := self selectedMessageName.
+ selectorSet := Set new.
+ (self systemNavigation allCallsOn: aSelector)
+ do: [:anItem | selectorSet add: anItem methodSymbol].
+ selectorSet := selectorSet
+ select: [:sel | currentVocabulary
+ includesSelector: sel
+ forInstance: self targetObject
+ ofClass: targetClass
+ limitClass: limitClass].
+ selectorSet size == 0
+ ifTrue: [^ Beeper beep].
+ self okToChange
+ ifFalse: [^ self].
+ chosen := UIManager default chooseFrom: selectorSet asSortedArray values: selectorSet asSortedArray.
+ chosen isEmptyOrNil
+ ifFalse: [self displaySelector: chosen]!

Item was added:
+ ----- Method: Lexicon>>showQueryResultsCategory (in category 'within-tool queries') -----
+ showQueryResultsCategory
+ "Point the receiver at the query-results category and set the search string accordingly"
+
+ autoSelectString := self currentQueryParameter.
+ self categoryListIndex: (categoryList indexOf: self class queryCategoryName).
+ self messageListIndex: 0!

Item was added:
+ ----- Method: Lexicon class>>sendersCategoryName (in category 'visible category names') -----
+ sendersCategoryName
+ "Answer the name to be used for the senders-results category"
+
+ true ifTrue: [^ #'-- "senders" results --'].
+
+ ^ '-- "senders" results --'.  "so methods-strings-containing will find this"!

Item was added:
+ ----- Method: Lexicon>>setMethodListFromSearchString (in category 'search') -----
+ setMethodListFromSearchString
+ "Set the method list of the receiver based on matches from the search string"
+
+ | fragment aList |
+ self okToChange ifFalse: [^ self].
+ fragment := currentQueryParameter.
+ fragment := fragment asString asLowercase withBlanksTrimmed.
+
+ aList := targetClass allSelectors select:
+ [:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass].
+ fragment size > 0 ifTrue:
+ [aList := aList select:
+ [:aSelector | aSelector includesSubstring: fragment caseSensitive: false]].
+ aList size == 0 ifTrue:
+ [^ Beeper beep].
+ self initListFrom: aList asSortedArray highlighting: targetClass.
+ messageListIndex :=  messageListIndex min: messageList size.
+ self changed: #messageList
+ !

Item was added:
+ ----- Method: Lexicon>>seeAlso (in category 'within-tool queries') -----
+ seeAlso
+ "Present a menu offering the selector of the currently selected message, as well as of all messages sent by it.  If the chosen selector is showable in the current browser, show it here, minding unsubmitted edits however"
+
+ self selectImplementedMessageAndEvaluate:
+ [:aSelector |
+ ((currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass)   "i.e., is this aSelector available in this browser"
+ and: [self okToChange])
+ ifTrue:
+ [self displaySelector: aSelector]
+ ifFalse:
+ [Beeper beep.  "SysttemNavigation new browseAllImplementorsOf: aSelector"]].
+ "Initially I tried making this open an external implementors browser in this case, but later decided that the user model for this was unstable"!

Item was added:
+ ----- Method: Lexicon>>selectedClassOrMetaClass (in category 'selection') -----
+ selectedClassOrMetaClass
+ "Answer the currently selected class (or metaclass)."
+
+ self setClassAndSelectorIn: [:c :s | ^c]!

Item was added:
+ ----- Method: Behavior>>implementsVocabulary: (in category '*Protocols') -----
+ implementsVocabulary: aVocabulary
+ "Answer whether instances of the receiver respond to the messages in aVocabulary."
+
+ (aVocabulary isKindOf: FullVocabulary orOf: ScreenedVocabulary) ifTrue: [^ true].
+ ^ self fullyImplementsVocabulary: aVocabulary!

Item was added:
+ ----- Method: Lexicon>>selectorsRetrieved (in category 'within-tool queries') -----
+ selectorsRetrieved
+ "Anwer a list of selectors in the receiver that have been retrieved for the query category.  This protocol is used when reformulating a list after, say, a limitClass change"
+
+ currentQuery == #classVarRefs ifTrue: [^ self selectorsReferringToClassVar].
+ currentQuery == #currentChangeSet ifTrue: [^ self selectorsChanged].
+ currentQuery == #instVarDefs ifTrue: [^ self selectorsDefiningInstVar].
+ currentQuery == #instVarRefs ifTrue: [^ self selectorsReferringToInstVar].
+ currentQuery == #methodsWithInitials ifTrue: [^ self methodsWithInitials].
+ currentQuery == #selectorName ifTrue: [^ self selectorsMatching].
+ currentQuery == #senders ifTrue: [^ self selectorsSendingSelectedSelector].
+
+ ^ #()!

Item was added:
+ Lexicon subclass: #InstanceBrowser
+ instanceVariableNames: 'objectViewed'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Protocols-Tools'!

Item was added:
+ ----- Method: InstanceBrowser>>openOnObject:showingSelector: (in category 'initialization') -----
+ openOnObject: anObject showingSelector: aSelector
+ "Create and open a SystemWindow to house the receiver, showing the categories pane."
+
+ objectViewed := anObject.
+ self openOnClass: anObject class showingSelector: aSelector!

Item was added:
+ MessageSet subclass: #ProtocolBrowser
+ instanceVariableNames: 'selectedClass selectedSelector'
+ classVariableNames: 'TextMenu'
+ poolDictionaries: ''
+ category: 'Protocols-Tools'!
+
+ !ProtocolBrowser commentStamp: '<historical>' prior: 0!
+ An instance of ProtocolBrowser shows the methods a class understands--inherited or implemented at this level--as a "flattened" list.!

Item was added:
+ ----- Method: Lexicon class>>windowColorSpecification (in category 'window color') -----
+ windowColorSpecification
+ "Answer a WindowColorSpec object that declares my preference"
+
+ ^ WindowColorSpec classSymbol: self name wording: 'Lexicon' brightColor: #(0.878 1.000 0.878) pastelColor: #(0.925 1.000 0.925) helpMessage: 'A tool for browsing the full protocol of a class.'!

Item was added:
+ ----- Method: ProtocolBrowser>>selector: (in category 'accessing') -----
+ selector: aString
+ "Set the currently selected message selector to be aString."
+ selectedSelector := aString.
+ self changed: #selector!

Item was added:
+ ----- Method: Lexicon>>seeAlso: (in category 'within-tool queries') -----
+ seeAlso: aSelector
+ "If the requested selector is showable in the current browser, show it here, minding unsubmitted edits however"
+
+ ((currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass)   "i.e., is aSelector available in this browser"
+ and: [self okToChange])
+ ifTrue:
+ [self displaySelector: aSelector]
+ ifFalse:
+ [Beeper beep]!

Item was added:
+ ----- Method: Lexicon>>selectorsSendingSelectedSelector (in category 'senders') -----
+ selectorsSendingSelectedSelector
+ "Assumes lastSendersSearchSelector is already set"
+ | selectorSet |
+ autoSelectString := (self lastSendersSearchSelector upTo: $:) asString.
+ selectorSet := Set new.
+ (self systemNavigation allCallsOn: self lastSendersSearchSelector)
+ do: [:anItem | | sel cl |
+ sel := anItem methodSymbol.
+ cl := anItem actualClass.
+ ((currentVocabulary
+ includesSelector: sel
+ forInstance: self targetObject
+ ofClass: targetClass
+ limitClass: limitClass)
+ and: [targetClass includesBehavior: cl])
+ ifTrue: [selectorSet add: sel]].
+ ^ selectorSet asSortedArray!

Item was added:
+ ----- Method: Lexicon>>buildCategoryListWith: (in category 'toolbuilder') -----
+ buildCategoryListWith: builder
+ | listSpec |
+ listSpec := builder pluggableListSpec new.
+ listSpec
+ model: self;
+ list: #categoryList;
+ getIndex: #categoryListIndex;
+ setIndex: #categoryListIndex:;
+ menu: #categoryListMenu:shifted:;
+ keyPress: #categoryListKey:from:.
+ ^listSpec!

Item was added:
+ ----- Method: ProtocolBrowser class>>openSubProtocolForClass: (in category 'instance creation') -----
+ openSubProtocolForClass: aClass
+ "Create and schedule a browser for the entire protocol of the class."
+ "ProtocolBrowser openSubProtocolForClass: ProtocolBrowser."
+ | aPBrowser label |
+ aPBrowser := ProtocolBrowser new onSubProtocolOf: aClass.
+ label := 'Sub-protocol of: ', aClass name.
+ self open: aPBrowser name: label!

Item was added:
+ ----- Method: Lexicon>>reformulateList (in category 'transition') -----
+ reformulateList
+ "Make the category list afresh, and reselect the current selector if appropriate"
+
+ self preserveSelectorIfPossibleSurrounding:
+ [super reformulateList.
+ self categoryListIndex: categoryListIndex]!

Item was added:
+ ----- Method: InstanceBrowser>>viewViewee (in category 'menu commands') -----
+ viewViewee
+ "Open a viewer on the object I view"
+
+ objectViewed beViewed!

Item was added:
+ ----- Method: Lexicon>>setLimitClass: (in category 'limit class') -----
+ setLimitClass: aClass
+ "Set aClass as the limit class for this browser"
+
+ | currentClass currentSelector |
+ currentClass := self selectedClassOrMetaClass.
+ currentSelector := self selectedMessageName.
+
+ self limitClass: aClass.
+ categoryList := nil.
+ self categoryListIndex: 0.
+ self changed: #categoryList.
+ self changed: #methodList.
+ self changed: #contents.
+ self changed: #limitClassString.
+ self adjustWindowTitle.
+ self hasSearchPane
+ ifTrue:
+ [self setMethodListFromSearchString].
+
+ self maybeReselectClass: currentClass selector: currentSelector
+
+ !

Item was added:
+ ----- Method: Lexicon>>toggleSearch (in category 'search') -----
+ toggleSearch
+ "Toggle the determination of whether a categories pane or a search pane shows"
+
+ self hasSearchPane
+ ifTrue: [self showCategoriesPane]
+ ifFalse: [self showSearchPane]!

Item was added:
+ ----- Method: Lexicon>>limitClass (in category 'limit class') -----
+ limitClass
+ "Answer the most generic class to show in the browser.  By default, we go all the way up to ProtoObject"
+
+ ^ limitClass ifNil: [self initialLimitClass]!

Item was added:
+ ----- Method: Lexicon>>navigateToRecentMethod (in category 'history') -----
+ navigateToRecentMethod
+ "Put up a menu of recent selectors visited and navigate to the one chosen"
+
+ | visited aSelector |
+ (visited := self selectorsVisited) size > 1 ifTrue:
+ [visited := visited copyFrom: 1 to: (visited size min: 20).
+ aSelector := UIManager default chooseFrom: visited values: visited
+ title: 'Recent methods visited in this browser'.
+ aSelector isEmptyOrNil ifFalse: [self displaySelector: aSelector]]!

Item was added:
+ ----- Method: Lexicon>>initListFrom:highlighting: (in category 'initialization') -----
+ initListFrom: selectorCollection highlighting: aClass
+ "Make up the messageList with items from aClass in boldface.  Provide a final filtering in that only selectors whose implementations fall within my limitClass will be shown."
+
+
+ messageList := OrderedCollection new.
+ selectorCollection do:
+ [:selector | | item defClass |  defClass := aClass whichClassIncludesSelector: selector.
+ (defClass notNil and: [defClass includesBehavior: self limitClass]) ifTrue:
+ [item := selector, '     (' , defClass name , ')'.
+ item := item asText.
+ defClass == aClass ifTrue: [item allBold].
+ "(self isThereAnOverrideOf: selector) ifTrue: [item addAttribute: TextEmphasis struckOut]."
+ "The above has a germ of a good idea but could be very slow"
+ messageList add: item]]!

Item was added:
+ ----- Method: Lexicon>>methodListFromSearchString: (in category 'search') -----
+ methodListFromSearchString: fragment
+ "Answer a method list of methods whose selectors match the given fragment"
+
+ |  aList searchFor |
+ currentQueryParameter := fragment.
+ currentQuery := #selectorName.
+ autoSelectString := fragment.
+ searchFor := fragment asString asLowercase withBlanksTrimmed.
+
+ aList := targetClass allSelectors select:
+ [:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass].
+ searchFor size > 0 ifTrue:
+ [aList := aList select:
+ [:aSelector | aSelector includesSubstring: searchFor caseSensitive: false]].
+ ^ aList asSortedArray
+ !

Item was added:
+ ----- Method: Lexicon>>useVocabulary: (in category 'vocabulary') -----
+ useVocabulary: aVocabulary
+ "Set up the receiver to use the given vocabulary"
+
+ currentVocabulary := aVocabulary!

Item was added:
+ ----- Method: Lexicon>>showCategory (in category 'menu commands') -----
+ showCategory
+ "A revectoring blamable on history.  Not sent in the image, but grandfathered buttons may still send this."
+
+ ^ self showHomeCategory!

Item was added:
+ ----- Method: Lexicon>>navigateToPreviousMethod (in category 'history') -----
+ navigateToPreviousMethod
+ "Navigate to the 'previous' method in the current viewing sequence"
+
+ | anIndex aSelector |
+ self selectorsVisited size == 0 ifTrue: [^ self].
+ anIndex := (aSelector := self selectedMessageName) notNil
+ ifTrue: [selectorsVisited indexOf: aSelector ifAbsent: [selectorsVisited size]]
+ ifFalse: [selectorsVisited size].
+ self selectedCategoryName == self class viewedCategoryName
+ ifTrue:
+ [self selectWithinCurrentCategory: (selectorsVisited atWrap: (anIndex - 1))]
+ ifFalse:
+ [self displaySelector: (selectorsVisited atWrap: (anIndex - 1))]!

Item was added:
+ ----- Method: CodeHolder>>spawnProtocol (in category '*Protocols-Tools') -----
+ spawnProtocol
+ | aClassOrMetaclass |
+ "Create and schedule a new protocol browser on the currently selected class or meta."
+ (aClassOrMetaclass := self selectedClassOrMetaClass) ifNotNil:
+         [ProtocolBrowser openSubProtocolForClass: aClassOrMetaclass]!

Item was added:
+ ----- Method: Lexicon>>updateSelectorsVisitedfrom:to: (in category 'history') -----
+ updateSelectorsVisitedfrom: oldSelector to: newSelector
+ "Update the list of selectors visited."
+
+ newSelector == oldSelector ifTrue: [^ self].
+ self selectorsVisited remove: newSelector ifAbsent: [].
+
+ (selectorsVisited includes:  oldSelector)
+ ifTrue:
+ [selectorsVisited add: newSelector after: oldSelector]
+ ifFalse:
+ [selectorsVisited add: newSelector]
+ !

Item was added:
+ ----- Method: Lexicon>>selectedMessage (in category 'selection') -----
+ selectedMessage
+ "Answer the source method for the currently selected message."
+
+ (categoryList notNil and: [(categoryListIndex isNil or: [categoryListIndex == 0])])
+ ifTrue:
+ [^ '---'].
+
+ self setClassAndSelectorIn: [:class :selector |
+ class ifNil: [^ 'here would go the documentation for the protocol category, if any.'].
+
+ self showingDecompile ifTrue: [^ self decompiledSourceIntoContents].
+ self showingDocumentation ifTrue: [^ self commentContents].
+
+ currentCompiledMethod := class compiledMethodAt: selector ifAbsent: [nil].
+ ^ self sourceStringPrettifiedAndDiffed asText makeSelectorBoldIn: class]!

Item was added:
+ ----- Method: Lexicon>>messageListKey:from: (in category 'message list menu') -----
+ messageListKey: aChar from: view
+ "Respond to a Command key"
+
+ aChar == $f ifTrue: [^ self obtainNewSearchString].
+ ^ super messageListKey: aChar from: view!

Item was added:
+ ----- Method: Lexicon>>showMethodsWithInitials: (in category 'within-tool queries') -----
+ showMethodsWithInitials: initials
+ "Make the current query be for methods stamped with the given initials"
+
+ currentQuery := #methodsWithInitials.
+ currentQueryParameter := initials.
+ self showQueryResultsCategory.
+ autoSelectString := nil.
+ self changed: #messageList.
+ self adjustWindowTitle
+ !

Item was added:
+ ----- Method: StringHolder>>browseFullProtocol (in category '*Protocols-Tools') -----
+ browseFullProtocol
+ "Open up a protocol-category browser on the value of the receiver's current selection.    If in mvc, an old-style protocol browser is opened instead.  Someone who still uses mvc might wish to make the protocol-category-browser work there too, thanks."
+
+ | aClass |
+
+ (Smalltalk isMorphic and: [Smalltalk includesKey: #Lexicon]) ifFalse: [^ self spawnFullProtocol].
+ ((aClass := self selectedClassOrMetaClass) notNil and: [aClass isTrait not]) ifTrue:
+ [(Smalltalk at: #Lexicon) new openOnClass: aClass showingSelector: self selectedMessageName]!

Item was added:
+ ----- Method: Lexicon>>currentQueryParameter (in category 'within-tool queries') -----
+ currentQueryParameter
+ "Answer the current query parameter"
+
+ ^ currentQueryParameter ifNil: [currentQueryParameter := 'contents']!

Item was added:
+ ----- Method: Lexicon>>selectorsReferringToInstVar (in category 'within-tool queries') -----
+ selectorsReferringToInstVar
+ "Return a list of methods that refer to a given inst var that are in the protocol of this object"
+
+ | aList  |
+ aList := OrderedCollection new.
+ targetClass withAllSuperclassesDo: [:aClass |
+ (aClass whichSelectorsAccess: currentQueryParameter asString) do: [:sel |
+ sel isDoIt ifFalse: [aList add: sel]
+ ]
+ ].
+ ^ aList!

Item was added:
+ ----- Method: Inspector>>browseFullProtocol (in category '*Protocols-Tools') -----
+ browseFullProtocol
+ "Open up a protocol-category browser on the value of the receiver's current selection.  If in mvc, an old-style protocol browser is opened instead."
+
+ | objectToRepresent |
+ Smalltalk isMorphic ifFalse: [^ self spawnProtocol].
+
+ objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
+ InstanceBrowser new openOnObject: objectToRepresent showingSelector: nil!

Item was added:
+ ----- Method: Lexicon>>displaySelector: (in category 'basic operation') -----
+ displaySelector: aSelector
+ "Set aSelector to be the one whose source shows in the browser.  If there is a category list, make it highlight a suitable category"
+
+ | detectedItem messageIndex |
+ self chooseCategory: (self categoryDefiningSelector: aSelector).
+ detectedItem := messageList detect:
+ [:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ Beeper beep].
+ messageIndex := messageList indexOf: detectedItem.
+ self messageListIndex: messageIndex!

Item was added:
+ ----- Method: InstanceBrowser>>targetObject (in category 'target-object access') -----
+ targetObject
+ "Answer the object to which this tool is bound"
+
+ ^ objectViewed!

Item was added:
+ ----- Method: Lexicon>>contents (in category 'contents') -----
+ contents
+ "We have a class, allow new messages to be defined"
+
+ editSelection == #newMessage ifTrue: [^ targetClass sourceCodeTemplate].
+ ^ super contents!

Item was added:
+ ----- Method: Lexicon>>messageListIndex: (in category 'basic operation') -----
+ messageListIndex: anIndex
+ "Set the message list index as indicated, and update the history list if appropriate"
+
+ | newSelector current |
+ current := self selectedMessageName.
+ super messageListIndex: anIndex.
+ anIndex = 0 ifTrue: [
+ self editSelection: #newMessage.
+ self contentsChanged].
+ (newSelector := self selectedMessageName) ifNotNil:
+ [self updateSelectorsVisitedfrom: current to: newSelector]!

Item was added:
+ ----- Method: Lexicon>>setLocalInstVarDefs (in category 'within-tool queries') -----
+ setLocalInstVarDefs
+ "Put up a list of the instance variables in the viewed object, and when the user seletcts one, let the query results category show all the references to that instance variable."
+
+ | instVarToProbe |
+
+ targetClass chooseInstVarThenDo:
+ [:aName | instVarToProbe := aName].
+ instVarToProbe isEmptyOrNil ifTrue: [^ self].
+ currentQuery := #instVarDefs.
+ currentQueryParameter := instVarToProbe.
+ self showQueryResultsCategory!

Item was added:
+ ----- Method: Lexicon>>selectorsMatching (in category 'search') -----
+ selectorsMatching
+ "Anwer a list of selectors in the receiver that match the current search string"
+
+ | fragment aList |
+ fragment := self lastSearchString asLowercase.
+ aList := targetClass allSelectors select:
+ [:aSelector | (aSelector includesSubstring: fragment caseSensitive: false) and:
+ [currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass]].
+
+ ^ aList asSortedArray!

Item was added:
+ ----- Method: InstanceBrowser>>startingWindowTitle (in category 'window title') -----
+ startingWindowTitle
+ "Answer the initial window title to apply"
+
+ ^ 'Vocabulary of ', objectViewed nameForViewer!

Item was added:
+ ----- Method: Lexicon>>noteAcceptanceOfCodeFor: (in category 'transition') -----
+ noteAcceptanceOfCodeFor: newSelector
+ "The user has submitted new code for the given selector; take a note of it.  NB that the selectors-changed list gets added to here, but is not currently used in the system."
+
+ (self selectorsVisited includes: newSelector) ifFalse: [selectorsVisited add: newSelector].!

Item was added:
+ ----- Method: Lexicon>>browseInstVarDefs (in category 'new-window queries') -----
+ browseInstVarDefs
+ "Let the search pertain to the target class regardless of selection"
+
+ self systemNavigation browseInstVarDefs: targetClass!

Item was added:
+ ----- Method: Object>>haveFullProtocolBrowsed (in category '*Protocols') -----
+ haveFullProtocolBrowsed
+ "Open up a Lexicon on the receiver"
+
+ ^ self haveFullProtocolBrowsedShowingSelector: nil
+
+ "(2@3) haveFullProtocolBrowsed"
+ !

Item was added:
+ ----- Method: Lexicon>>selectWithinCurrentCategoryIfPossible: (in category 'category list') -----
+ selectWithinCurrentCategoryIfPossible: aSelector
+ "If the receiver's message list contains aSelector, navigate right to it without changing categories"
+  
+ | detectedItem messageIndex |
+ aSelector ifNil: [^ self].
+ detectedItem := messageList detect:
+ [:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ self].
+ messageIndex := messageList indexOf: detectedItem.
+ self messageListIndex: messageIndex
+ !

Item was added:
+ ----- Method: Lexicon>>hasSearchPane (in category 'search') -----
+ hasSearchPane
+ "Answer whether receiver has a search pane"
+
+ ^ self searchPane notNil!

Item was added:
+ ----- Method: Lexicon>>methodsWithInitials: (in category 'within-tool queries') -----
+ methodsWithInitials: initials
+ "Return a list of selectors representing methods whose timestamps have the given initials and which are in the protocol of this object and within the range dictated by my limitClass."
+
+ | classToUse |
+ classToUse := self targetObject ifNotNil: [self targetObject class] ifNil: [targetClass].  "In support of lightweight uniclasses"
+ ^ targetClass allSelectors select:
+ [:aSelector | (currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: classToUse limitClass: limitClass) and:
+ [Utilities doesMethod: aSelector forClass: classToUse bearInitials: initials]].
+
+ !

Item was added:
+ ----- Method: Lexicon>>categoryList (in category 'category list') -----
+ categoryList
+ "Answer the category list for the protcol, creating it if necessary, and prepending the -- all -- category, and appending the other special categories for search results, etc."
+
+ | specialCategoryNames |
+ categoryList ifNil:
+ [specialCategoryNames := #(queryCategoryName  viewedCategoryName "searchCategoryName sendersCategoryName  changedCategoryName activeCategoryName")  collect:
+ [:sym | self class perform: sym].
+ categoryList :=
+ (currentVocabulary categoryListForInstance: self targetObject ofClass: targetClass limitClass: limitClass),
+ specialCategoryNames,
+ (Array with: self class allCategoryName)].
+ ^ categoryList!

Item was added:
+ ----- Method: Lexicon>>setSendersSearch (in category 'senders') -----
+ setSendersSearch
+ "Put up a list of messages sent in the current message, find all methods
+ of the browsee which send the one the user chooses, and show that list
+ in the message-list pane, with the 'query results' item selected in the
+ category-list pane"
+ | selectorSet aSelector aString |
+ self selectedMessageName
+ ifNil: [aString := UIManager default request: 'Type selector to search for' initialAnswer: 'flag:'.
+ aString isEmptyOrNil
+ ifTrue: [^ self].
+ Symbol
+ hasInterned: aString
+ ifTrue: [:sel | aSelector := sel]]
+ ifNotNil: [self
+ selectMessageAndEvaluate: [:sel | aSelector := sel]].
+ aSelector
+ ifNil: [^ self].
+ selectorSet := Set new.
+ (self systemNavigation allCallsOn: aSelector)
+ do: [:anItem | selectorSet add: anItem methodSymbol].
+ selectorSet := selectorSet
+ select: [:sel | currentVocabulary
+ includesSelector: sel
+ forInstance: self targetObject
+ ofClass: targetClass
+ limitClass: limitClass].
+ selectorSet size > 0
+ ifTrue: [currentQuery := #senders.
+ currentQueryParameter := aSelector.
+ self
+ categoryListIndex: (categoryList indexOf: self class queryCategoryName).
+ self messageListIndex: 0]!

Item was added:
+ ----- Method: Lexicon>>initialLimitClass (in category 'limit class') -----
+ initialLimitClass
+ "Choose a plausible initial vlaue for the limit class, and answer it"
+
+ | oneTooFar |
+ limitClass := targetClass.
+ (#('ProtoObject' 'Object' 'Behavior' 'ClassDescription' 'Class' 'ProtoObject class' 'Object class') includes: targetClass name asString) ifTrue: [^ targetClass].
+
+ oneTooFar := (targetClass isKindOf: Metaclass)
+ ifTrue:
+ ["use the fifth back from the superclass chain for Metaclasses, which is the immediate subclass of ProtoObject class.  Print <ProtoObject class allSuperclasses> to count them yourself."
+ targetClass allSuperclasses at: (targetClass allSuperclasses size - 5)]
+ ifFalse:
+ [targetClass allSuperclasses at: targetClass allSuperclasses size].
+ [limitClass superclass ~~ oneTooFar]
+ whileTrue: [limitClass := limitClass superclass].
+ ^ limitClass!

Item was added:
+ ----- Method: Lexicon>>offerMenu (in category 'menu commands') -----
+ offerMenu
+ "Offer a menu to the user, in response to the hitting of the menu button on the tool pane"
+
+ | aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
+ aMenu addTitle: 'Lexicon'.
+ aMenu addStayUpItem.
+ aMenu addList: #(
+
+ ('vocabulary...' chooseVocabulary)
+ ('what to show...' offerWhatToShowMenu)
+ -
+ ('inst var refs (here)' setLocalInstVarRefs)
+ ('inst var defs (here)' setLocalInstVarDefs)
+ ('class var refs (here)' setLocalClassVarRefs)
+ -
+
+ ('navigate to a sender...' navigateToASender)
+ ('recent...' navigateToRecentMethod)
+ ('show methods in current change set'
+ showMethodsInCurrentChangeSet)
+ ('show methods with initials...'
+ showMethodsWithInitials)
+ -
+ "('toggle search pane' toggleSearch)"
+
+ -
+ ('browse full (b)' browseMethodFull)
+ ('browse hierarchy (h)' classHierarchy)
+ ('browse method (O)' openSingleMessageBrowser)
+ ('browse protocol (p)' browseFullProtocol)
+ -
+ ('fileOut' fileOutMessage)
+ ('printOut' printOutMessage)
+ -
+ ('senders of... (n)' browseSendersOfMessages)
+ ('implementors of... (m)' browseMessages)
+ ('versions (v)' browseVersions)
+ ('inheritance (i)' methodHierarchy)
+ -
+ ('inst var refs' browseInstVarRefs)
+ ('inst var defs' browseInstVarDefs)
+ ('class var refs' browseClassVarRefs)
+ -
+ ('more...' shiftedYellowButtonActivity)).
+
+ aMenu popUpInWorld: ActiveWorld!

Item was added:
+ ----- Method: Lexicon>>addModelItemsToWindowMenu: (in category 'window title') -----
+ addModelItemsToWindowMenu: aMenu
+ "Add model-related item to the window menu"
+
+ super addModelItemsToWindowMenu: aMenu.
+ aMenu add: 'choose vocabulary...' target: self action: #chooseVocabulary!

Item was added:
+ ----- Method: Lexicon>>categoryListIndex (in category 'category list') -----
+ categoryListIndex
+ "Answer the index of the currently-selected item in in the category list"
+
+ ^ categoryListIndex ifNil: [categoryListIndex := 1]!

Item was added:
+ ----- Method: Lexicon>>chooseCategory: (in category 'category list') -----
+ chooseCategory: aCategory
+ "Choose the category of the given name, if there is one"
+
+ self categoryListIndex: (categoryList indexOf: aCategory ifAbsent: [^ Beeper beep])!

Item was added:
+ ----- Method: Lexicon class>>queryCategoryName (in category 'visible category names') -----
+ queryCategoryName
+ "Answer the name to be used for the query-results category"
+
+ true ifTrue: [^ #'-- query results --'].
+
+ ^ '-- query results --' asSymbol   "Placed here so a message-strings-containing-it query will find this method"!

Item was added:
+ ----- Method: Lexicon>>addSpecialButtonsTo:with: (in category 'toolbuilder') -----
+ addSpecialButtonsTo: buttonPanelSpec with: builder
+
+ | homeCatBtnSpec menuBtnSpec mostGenericBtnSpec |
+ homeCatBtnSpec := builder pluggableButtonSpec new
+ model: self;
+ action: #showHomeCategory;
+ label: (ScriptingSystem formAtKey: #Cat) asMorph;
+ help: 'show this method''s home category';
+ yourself.
+ menuBtnSpec := builder pluggableButtonSpec new
+ model: self;
+ action: #offerMenu;
+ label: (ScriptingSystem formAtKey: #TinyMenu) asMorph;
+ help: 'click here to get a menu with further options';
+ yourself.
+ mostGenericBtnSpec :=builder pluggableButtonSpec new
+ model: self;
+ action: #chooseLimitClass;
+ label: #limitClassString;
+ help: 'Governs which classes'' methods should be shown.  If this is the same as the viewed class, then only methods implemented in that class will be shown.  If it is ProtoObject, then methods of all classes in the vocabulary will be shown.'.
+ buttonPanelSpec children
+ add: homeCatBtnSpec;
+ addFirst: mostGenericBtnSpec;
+ addFirst: menuBtnSpec.!

Item was added:
+ ----- Method: Lexicon>>setClassAndSelectorIn: (in category 'selection') -----
+ setClassAndSelectorIn: csBlock
+ "Decode strings of the form    <selectorName> (<className> [class])"
+
+
+ self selection ifNil: [^ csBlock value: targetClass value: nil].
+ ^ super setClassAndSelectorIn: csBlock!

Item was added:
+ ----- Method: Lexicon>>lastSearchString: (in category 'search') -----
+ lastSearchString: aString
+ "Make a note of the last string searched for in the receiver"
+
+ currentQueryParameter := aString asString.
+ currentQuery := #selectorName.
+ autoSelectString := aString.
+ self setMethodListFromSearchString.
+ ^ true!

Item was added:
+ ----- Method: Lexicon>>adjustWindowTitle (in category 'window title') -----
+ adjustWindowTitle
+ "Set the title of the receiver's window, if any, to reflect the current choices"
+
+ | aWindow aLabel catName |
+ (catName := self selectedCategoryName) ifNil: [^ self].
+ (aWindow := self containingWindow) ifNil: [^ self].
+ aLabel := nil.
+ #( (viewedCategoryName 'Messages already viewed - ')
+ (allCategoryName 'All messages - ')) do:
+ [:aPair | catName = (self categoryWithNameSpecifiedBy: aPair first) ifTrue: [aLabel := aPair second]].
+
+ aLabel ifNil:
+ [aLabel := catName = self class queryCategoryName
+ ifTrue:
+ [self queryCharacterization, ' - ']
+ ifFalse:
+ ['Vocabulary of ']].
+ aWindow setLabel: aLabel, (self targetObject ifNil: [targetClass]) nameForViewer!

Item was added:
+ ----- Method: ProtocolBrowser>>onSubProtocolOf: (in category 'private') -----
+ onSubProtocolOf: aClass
+ "Initialize with the entire protocol for the class, aClass,
+ but excluding those inherited from Object."
+ | selectors |
+ selectors := Set new.
+ aClass withAllSuperclasses do:
+ [:each | (each == Object or: [each == ProtoObject])
+ ifFalse: [selectors addAll: each selectors]].
+ self initListFrom: selectors asSortedCollection
+ highlighting: aClass!

Item was added:
+ ----- Method: Lexicon>>customButtonSpecs (in category 'control buttons') -----
+ customButtonSpecs
+ "Answer a triplet defining buttons, in the format:
+
+ button label
+ selector to send
+ help message"
+ | aa |
+ aa := contentsSymbol == #tiles ifTrue: [{   "Consult Ted Kaehler regarding this bit"
+ {'tiles'. #tilesMenu. 'tiles for assignment and constants'. true}.
+ {'vars'. #varTilesMenu. 'tiles for instance variables and a new temporary'. true}
+ }] ifFalse: [#()]. "true in 4th place means act on mouseDown"
+
+ ^ aa, #(
+ ('follow' seeAlso 'view a method I implement that is called by this method')
+ ('find' obtainNewSearchString 'find methods by name search')
+ ('sent...' setSendersSearch 'view the methods I implement that send a given message')
+
+ ('<' navigateToPreviousMethod 'view the previous active method')
+ ('>' navigateToNextMethod 'view the next active method')
+ ('-' removeFromSelectorsVisited 'remove this method from my active list'))!

Item was added:
+ ----- Method: Object>>currentVocabulary (in category '*Protocols') -----
+ currentVocabulary
+ "Answer the currently-prevailing default vocabulary."
+
+ ^ Smalltalk isMorphic ifTrue:
+ [ActiveWorld currentVocabulary]
+ ifFalse:
+ [Vocabulary fullVocabulary]!

Item was added:
+ ----- Method: Lexicon>>selectSelectorItsNaturalCategory: (in category 'selection') -----
+ selectSelectorItsNaturalCategory: aSelector
+ "Make aSelector be the current selection of the receiver, with the category being its home category."
+
+ | cat catIndex detectedItem |
+ cat := self categoryOfSelector: aSelector.
+ catIndex := categoryList indexOf: cat ifAbsent:
+ ["The method's own category is not seen in this browser; the method probably occurs in some other category not known directly to the class, but for now, we'll just use the all category"
+ 1].
+ self categoryListIndex: catIndex.
+ detectedItem := messageList detect:
+ [:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ self].
+ self messageListIndex:  (messageList indexOf: detectedItem ifAbsent: [^ self])!

Item was added:
+ ----- Method: Lexicon>>reformulateCategoryList (in category 'category list') -----
+ reformulateCategoryList
+ "Reformulate the category list"
+
+ categoryList := nil.
+ self categoryListIndex: 0.
+ self changed: #categoryList.
+ self contentsChanged!

Item was added:
+ ----- Method: Lexicon>>showCategoriesPane (in category 'category list') -----
+ showCategoriesPane
+ "Show the categories pane instead of the search pane"
+
+ | aPane |
+ (aPane := self searchPane) ifNil: [^ Beeper beep].
+ self containingWindow replacePane: aPane with: self newCategoryPane.
+ categoryList := nil.
+ self changed: #categoryList.
+ self changed: #messageList!

Item was added:
+ ----- Method: Lexicon>>categoryListIndex: (in category 'category list') -----
+ categoryListIndex: anIndex
+ "Set the category list index as indicated"
+
+ | categoryName aList found existingSelector |
+ existingSelector := self selectedMessageName.
+
+ categoryListIndex := anIndex.
+ anIndex > 0
+ ifTrue:
+ [categoryName := categoryList at: anIndex]
+ ifFalse:
+ [contents := nil].
+ self changed: #categoryListIndex.
+
+ found := false.
+ #( (viewedCategoryName selectorsVisited)
+ (queryCategoryName selectorsRetrieved)) do:
+ [:pair |
+ categoryName = (self class perform: pair first)
+ ifTrue:
+ [aList := self perform: pair second.
+ found := true]].
+ found ifFalse:
+ [aList := currentVocabulary allMethodsInCategory: categoryName forInstance: self targetObject ofClass: targetClass].
+ categoryName = self class queryCategoryName ifFalse: [autoSelectString := nil].
+
+ self initListFrom: aList highlighting: targetClass.
+
+ messageListIndex := 0.
+ self changed: #messageList.
+ contents := nil.
+ self contentsChanged.
+ self selectWithinCurrentCategoryIfPossible: existingSelector.
+ self adjustWindowTitle!

Item was added:
+ ----- Method: ProtocolBrowser>>on: (in category 'private') -----
+ on: aClass
+ "Initialize with the entire protocol for the class, aClass."
+ self initListFrom: aClass allSelectors asSortedCollection
+ highlighting: aClass!

Item was added:
+ ----- Method: Lexicon>>showMainCategory (in category 'menu commands') -----
+ showMainCategory
+ "Continue to show the current selector, but show it within the context of its primary category.  Preserved for backward compatibility with pre-existing buttons."
+
+ ^ self showHomeCategory!

Item was added:
+ ----- Method: InstanceBrowser>>openOnObject:inWorld:showingSelector: (in category 'initialization') -----
+ openOnObject: anObject inWorld: ignored showingSelector: aSelector
+ "Create and open a SystemWindow to house the receiver, showing the categories pane."
+ ^self openOnObject: anObject showingSelector: aSelector!

Item was changed:
  SystemOrganization addCategory: #'Protocols-Kernel'!
  SystemOrganization addCategory: #'Protocols-Type Vocabularies'!
+ SystemOrganization addCategory: #'Protocols-Tools'!