Smalltalk createPackage: 'Helios-Browser'! HLWidget subclass: #HLBrowser slots: {#model. #packagesListWidget. #classesListWidget. #protocolsListWidget. #methodsListWidget. #sourceWidget. #bottomDiv} package: 'Helios-Browser'! !HLBrowser commentStamp! I render a system browser with 4 panes (Packages, Classes, Protocols, Methods) and a source area.! !HLBrowser methodsFor: 'accessing'! environment ^ self model environment ! model ^ model ifNil: [ self model: HLBrowserModel new. model ] ! model: aModel model := aModel. self observeModel ! ! !HLBrowser methodsFor: 'actions'! focus ^ self packagesListWidget focus ! observeModel self model announcer on: HLPackageSelected send: #onPackageSelected: to: self. self model announcer on: HLClassSelected send: #onClassSelected: to: self ! openClassNamed: aString self model openClassNamed: aString ! openMethod: aCompiledMethod self model "Workaround for the package selection announcement when the package list is focused" focusOnSourceCode; selectedPackage: aCompiledMethod methodClass package; showInstance: aCompiledMethod methodClass isMetaclass not; selectedClass: aCompiledMethod methodClass; selectedProtocol: aCompiledMethod protocol; selectedMethod: aCompiledMethod; focusOnSourceCode ! unregister super unregister. { self packagesListWidget. self classesListWidget. self protocolsListWidget. self methodsListWidget. self sourceWidget } do: [ :each | each unregister ] ! ! !HLBrowser methodsFor: 'keybindings'! registerBindingsOn: aBindingGroup HLToolCommand registerConcreteClassesOn: aBindingGroup for: self model ! ! !HLBrowser methodsFor: 'reactions'! onClassSelected: anAnnouncement anAnnouncement item ifNil: [ self setTabLabel: (self model selectedPackage ifNil: [ self defaultTabLabel ] ifNotNil: [ :package | package name ]) ] ifNotNil: [ :item | self setTabLabel: item name ] ! onPackageSelected: anAnnouncement anAnnouncement item ifNotNil: [ :item | self setTabLabel: item name ] ! ! !HLBrowser methodsFor: 'rendering'! renderContentOn: html html with: (HLContainer with: (HLHorizontalSplitter with: (HLVerticalSplitter with: (HLVerticalSplitter with: self packagesListWidget with: self classesListWidget) with: (HLVerticalSplitter with: self protocolsListWidget with: self methodsListWidget)) with: self sourceWidget)). self packagesListWidget focus ! ! !HLBrowser methodsFor: 'testing'! canHaveFocus ^ true ! ! !HLBrowser methodsFor: 'widgets'! classesListWidget ^ classesListWidget ifNil: [ classesListWidget := HLClassesListWidget on: self model. classesListWidget next: self protocolsListWidget ] ! methodsListWidget ^ methodsListWidget ifNil: [ methodsListWidget := HLMethodsListWidget on: self model. methodsListWidget next: self sourceWidget ] ! packagesListWidget ^ packagesListWidget ifNil: [ packagesListWidget := HLPackagesListWidget on: self model. packagesListWidget next: self classesListWidget ] ! protocolsListWidget ^ protocolsListWidget ifNil: [ protocolsListWidget := HLProtocolsListWidget on: self model. protocolsListWidget next: self methodsListWidget ] ! sourceWidget ^ sourceWidget ifNil: [ sourceWidget := HLBrowserBottomWidget new model: self model; yourself ] ! ! HLBrowser class slots: {#nextId}! !HLBrowser class methodsFor: 'accessing'! nextId nextId ifNil: [ nextId := 0 ]. ^ 'browser_', (nextId + 1) asString ! tabClass ^ 'browser' ! tabLabel ^ 'Browser' ! tabPriority ^ 0 ! ! !HLBrowser class methodsFor: 'testing'! canBeOpenAsTab ^ true ! ! HLWidget subclass: #HLBrowserBottomWidget slots: {#model. #codeWidget. #documentationWidget} package: 'Helios-Browser'! !HLBrowserBottomWidget commentStamp! I render the code area of a browser and optionally the documentation for the selected class.! !HLBrowserBottomWidget methodsFor: 'accessing'! codeWidget ^ codeWidget ifNil: [ codeWidget := HLBrowserCodeWidget new browserModel: self model; yourself ] ! documentationWidget ^ documentationWidget ifNil: [ documentationWidget := HLDocumentationWidget new model: self model; yourself ] ! model ^ model ! model: aModel model := aModel. self observeModel ! previous "For navigation" ! previous: aWidget "For navigation" ! ! !HLBrowserBottomWidget methodsFor: 'actions'! focus self codeWidget focus ! observeModel self model announcer on: HLShowInstanceToggled send: #onShowInstanceToggled to: self; on: HLShowCommentToggled send: #onShowCommentToggled to: self ! ! !HLBrowserBottomWidget methodsFor: 'reactions'! onShowCommentToggled self refresh ! onShowInstanceToggled self refresh ! ! !HLBrowserBottomWidget methodsFor: 'rendering'! renderContentOn: html self model showComment ifTrue: [ self renderPanesOn: html ] ifFalse: [ html with: self codeWidget ] ! renderPanesOn: html html with: (HLVerticalSplitter with: self codeWidget with: self documentationWidget) ! ! !HLBrowserBottomWidget methodsFor: 'testing'! canHaveFocus ^ true ! ! HLToolModel subclass: #HLBrowserModel slots: {#showInstance. #showComment} package: 'Helios-Browser'! !HLBrowserModel methodsFor: 'accessing'! showComment ^ showComment ifNil: [ showComment := 'helios.browser.showComment' settingValueIfAbsent: false ] ! showComment: aBoolean self withChangesDo: [ showComment := aBoolean. 'helios.browser.showComment' settingValue: aBoolean. self announcer announce: HLShowCommentToggled new ] ! showInstance ^ showInstance ifNil: [ true ] ! showInstance: aBoolean self withChangesDo: [ showInstance := aBoolean. self selectedClass ifNotNil: [ self selectedClass: (aBoolean ifTrue: [ self selectedClass theNonMetaClass ] ifFalse: [ self selectedClass theMetaClass ]) ]. self announcer announce: HLShowInstanceToggled new ] ! ! !HLBrowserModel methodsFor: 'actions'! focusOnClasses self announcer announce: HLClassesFocusRequested new ! focusOnDocumentation self announcer announce: HLDocumentationFocusRequested new ! focusOnMethods self announcer announce: HLMethodsFocusRequested new ! focusOnPackages self announcer announce: HLPackagesFocusRequested new ! focusOnProtocols self announcer announce: HLProtocolsFocusRequested new ! focusOnSourceCode self announcer announce: HLSourceCodeFocusRequested new ! setClassComment: aString self environment setClassCommentOf: self selectedClass theNonMetaClass to: aString ! showClassTemplate self selectedPackage ifNotNil: [ :package | self announcer announce: (HLShowTemplate new template: package classTemplate; yourself) ] ! showMethodTemplate self selectedClass ifNotNil: [ :theClass | self announcer announce: (HLShowTemplate new template: theClass methodTemplate; yourself) ] ! ! !HLBrowserModel methodsFor: 'commands actions'! editComment self announcer announce: HLEditComment new ! ! !HLBrowserModel methodsFor: 'testing'! isBrowserModel ^ true ! ! !HLBrowserModel class methodsFor: 'instance creation'! on: anEnvironment ^ self new environment: anEnvironment; yourself ! ! Object subclass: #HLClassCache slots: {#class. #selectorsCache. #overrideCache. #overriddenCache} package: 'Helios-Browser'! !HLClassCache methodsFor: 'accessing'! overriddenCache ^ overriddenCache ifNil: [ overriddenCache := HashedCollection new ] ! overrideCache ^ overrideCache ifNil: [ overrideCache := HashedCollection new ] ! selectorsCache ^ selectorsCache ! selectorsCache: aCache selectorsCache := aCache ! theClass ^ class ! theClass: aClass class := aClass ! ! !HLClassCache methodsFor: 'actions'! invalidateChildrenSelector: aSelector self theClass subclasses do: [ :each | (self selectorsCache cacheFor: each) removeSelector: aSelector; invalidateChildrenSelector: aSelector ] ! invalidateParentSelector: aSelector self theClass superclass ifNotNil: [ (self selectorsCache cacheFor: self theClass superclass) removeSelector: aSelector; invalidateParentSelector: aSelector ] ! invalidateSelector: aSelector self invalidateParentSelector: aSelector; invalidateChildrenSelector: aSelector; removeSelector: aSelector ! ! !HLClassCache methodsFor: 'private'! removeSelector: aSelector self overriddenCache removeKey: aSelector ifAbsent: [ ]. self overrideCache removeKey: aSelector ifAbsent: [ ] ! ! !HLClassCache methodsFor: 'testing'! isOverridden: aMethod ^ self overriddenCache at: aMethod selector ifAbsentPut: [ aMethod isOverridden ] ! isOverride: aMethod ^ self overrideCache at: aMethod selector ifAbsentPut: [ aMethod isOverride ] ! ! !HLClassCache class methodsFor: 'instance creation'! on: aClass selectorsCache: aSelectorsCache ^ self new theClass: aClass; selectorsCache: aSelectorsCache; yourself ! ! HLToolListWidget subclass: #HLClassesListWidget slots: {} package: 'Helios-Browser'! !HLClassesListWidget commentStamp! I render a list of classes in the selected package.! !HLClassesListWidget methodsFor: 'accessing'! cssClassForItem: aClass ^ aClass theNonMetaClass classTag ! label ^ 'Classes' ! ! !HLClassesListWidget methodsFor: 'actions'! focus super focus. self selectedItem ifNil: [ self model showClassTemplate ] ! focusMethodsListWidget self model announcer announce: HLMethodsListFocus new ! focusProtocolsListWidget self model announcer announce: HLProtocolsListFocus new ! observeModel self model announcer on: HLPackageSelected send: #onPackageSelected: to: self; on: HLShowInstanceToggled send: #onShowInstanceToggled to: self; on: HLShowCommentToggled send: #onShowCommentToggled to: self; on: HLClassSelected send: #onClassSelected: to: self; on: HLClassesFocusRequested send: #onClassesFocusRequested to: self ! observeSystem self model systemAnnouncer on: ClassAdded send: #onClassAdded: to: self; on: ClassRemoved send: #onClassRemoved: to: self; on: ClassMoved send: #onClassMoved: to: self; on: ClassRenamed send: #onClassRenamed: to: self; on: ClassMigrated send: #onClassMigrated: to: self; on: ClassCommentChanged send: #onClassCommentChanged: to: self ! reselectItem: anItem self model softSelectedClass: anItem ! selectItem: aClass self model selectedClass: aClass ! showComment: aBoolean self model showComment: aBoolean ! showInstance: aBoolean self model showInstance: aBoolean ! toggleShowComment self model showComment: self showComment not ! ! !HLClassesListWidget methodsFor: 'private'! setItemsForPackage: aPackage self items: (aPackage ifNil: [ #() ] ifNotNil: [ (aPackage classes collect: [ :each | each theNonMetaClass ]) asArray sort: [ :a :b | a name < b name ] ]). ! setItemsForSelectedPackage self setItemsForPackage: self model selectedPackage ! ! !HLClassesListWidget methodsFor: 'reactions'! onClassAdded: anAnnouncement | class | class := anAnnouncement theClass. (class package = self model selectedPackage or: [ self items includes: class ]) ifFalse: [ ^ self ]. self setItemsForSelectedPackage; refresh; focus ! onClassCommentChanged: anAnnouncement | class | class := anAnnouncement theClass. class package = self model selectedPackage ifFalse: [ ^ self ]. self refresh; focus ! onClassMigrated: anAnnouncement | class oldClass | class := anAnnouncement theClass. oldClass := anAnnouncement oldClass. (self items includes: oldClass) ifFalse: [ ^ self ]. self model selectedClass = oldClass ifTrue: [ self model selectedClass: class ]. self setItemsForSelectedPackage. self refresh; focus ! onClassMoved: anAnnouncement | class oldPackage | class := anAnnouncement theClass. oldPackage := anAnnouncement oldPackage. (oldPackage = self model selectedPackage or: [ class package = self model selectedPackage ]) ifFalse: [ ^ self ]. oldPackage = self model selectedPackage ifTrue: [ self selectedItem: nil; selectItem: nil ]. self setItemsForSelectedPackage. self refresh; focus ! onClassRemoved: anAnnouncement | class | class := anAnnouncement theClass. class package = self model selectedPackage ifFalse: [ ^ self ]. self selectItem: nil; selectedItem: nil. self setItemsForSelectedPackage. self refresh; focus ! onClassRenamed: anAnnouncement anAnnouncement theClass package = self model selectedPackage ifFalse: [ ^ self ]. self setItemsForSelectedPackage. self refresh; focus ! onClassSelected: anAnnouncement | selectedClass | anAnnouncement item ifNil: [ ^ self ]. selectedClass := anAnnouncement item theNonMetaClass. self selectedItem: selectedClass. self hasFocus ifFalse: [ self activateItem: selectedClass; focus ] ! onClassesFocusRequested self focus ! onPackageSelected: anAnnouncement anAnnouncement isSoft ifTrue: [ ^ self ]. self selectedItem: nil. self setItemsForSelectedPackage. self refresh ! onShowCommentToggled self refresh ! onShowInstanceToggled self refresh ! ! !HLClassesListWidget methodsFor: 'rendering'! renderButtonsOn: html | checkbox | html div class: 'btn-group'; at: 'role' put: 'group'; with: [ html button class: (String streamContents: [ :str | str nextPutAll: 'btn btn-default'. self showInstance ifTrue: [ str nextPutAll: ' active' ] ]); with: 'Instance'; onClick: [ self showInstance: true ]. html button class: (String streamContents: [ :str | str nextPutAll: 'btn btn-default'. self showClass ifTrue: [ str nextPutAll: ' active' ] ]); with: 'Class'; onClick: [ self showInstance: false ] ]. html label class: 'checkbox'; with: [ checkbox := html input type: 'checkbox'; onClick: [ self toggleShowComment ]. html with: 'Doc' ]. self showComment ifTrue: [ checkbox at: 'checked' put: 'checked' ] ! renderItemLabel: aClassAndLevel on: html | aClass level indent | aClass := aClassAndLevel first. level := aClassAndLevel second. indent := String fromCharCode: 160. indent := indent, indent, indent, indent. html span with: (String streamContents: [ :str | level timesRepeat: [ str nextPutAll: indent ]. str nextPutAll: aClass name ]) ! renderItems: aCollection level: anInteger on: html aCollection do: [ :each | | aClass subclasses | aClass := each first. subclasses := each second. self renderItemModel: aClass viewModel: {aClass. anInteger} on: html. self renderItems: subclasses level: anInteger + 1 on: html ] ! renderListOn: html self renderItems: (ClassBuilder sortClasses: self items) level: 0 on: html ! ! !HLClassesListWidget methodsFor: 'testing'! showClass ^ self model showInstance not ! showComment ^ self model showComment ! showInstance ^ self model showInstance ! ! HLFocusableWidget subclass: #HLDocumentationWidget slots: {#model} package: 'Helios-Browser'! !HLDocumentationWidget commentStamp! I render the documentation for the selected class! !HLDocumentationWidget methodsFor: 'accessing'! documentation ^ self selectedItem ifNil: [ '' ] ifNotNil: [ :item | item comment ifEmpty: [ self defaultDocumentation ] ] ! head ^ self selectedItem ifNil: [ self defaultHead ] ifNotNil: [ :item | item name ] ! model ^ model ! model: aModel model := aModel. self observeSystem; observeModel ! selectedItem ^ self model selectedClass ifNotNil: [ :class | class theNonMetaClass ] ! ! !HLDocumentationWidget methodsFor: 'actions'! editDocumentation self model editComment ! observeModel self model announcer on: HLClassSelected send: #onClassSelected: to: self; on: HLEditComment send: #onEditDocumentation to: self; on: HLDocumentationFocusRequested send: #onDocumentationFocusRequested to: self ! observeSystem self model systemAnnouncer on: ClassCommentChanged send: #onClassCommentChanged: to: self ! selectClass: aClass self model selectedClass: aClass ! unregister super unregister. self model announcer unregister: self ! ! !HLDocumentationWidget methodsFor: 'defaults'! defaultDocumentation ^ 'No documentation is available for this class.' ! defaultHead ^ 'No class selected' ! ! !HLDocumentationWidget methodsFor: 'reactions'! onClassCommentChanged: anAnnouncement self model selectedClass ifNil: [ ^ self ]. anAnnouncement theClass = self model selectedClass theNonMetaClass ifTrue: [ self refresh ] ! onClassSelected: anAnnouncement self refresh ! onDocumentationFocusRequested self focus ! onEditDocumentation self request: self model selectedClass theNonMetaClass name, ' comment' value: self model selectedClass theNonMetaClass comment do: [ :comment | self setClassComment: comment ] ! setClassComment: aString self model setClassComment: aString ! ! !HLDocumentationWidget methodsFor: 'rendering'! renderClassLinkTo: aClassOrTrait on: html html a with: aClassOrTrait name; onClick: [ self selectClass: aClassOrTrait ] ! renderContentOn: html html div class: 'doc'; with: [ self renderHeadOn: html; renderDocOn: html ] ! renderDocOn: html self selectedItem ifNotNil: [ self renderInheritanceOn: html. html h1 with: 'Overview'; with: [ html button class: 'button default'; with: 'Edit'; onClick: [ self editDocumentation ] ]. (html div class: 'markdown'; asJQuery) html: ((Showdown at: 'converter') new makeHtml: self documentation) ] ! renderHeadOn: html html div class: 'head'; with: self head ! renderInheritanceOn: html html div class: 'inheritance'; with: [ self selectedItem isBehavior ifFalse: [ html with: 'Trait' ] ifTrue: [ html with: 'Subclass of '. self selectedItem superclass ifNil: [ html em with: 'nil' ] ifNotNil: [ :sclass | self renderClassLinkTo: sclass on: html ] ] ]; with: '. '; with: [ self selectedItem traitComposition ifNotEmpty: [ :composition | html with: 'Uses '. composition do: [ :each | self renderClassLinkTo: each trait on: html ] separatedBy: [ html with: ', ' ]. html with: '. ' ] ]; with: [ self selectedItem isBehavior ifTrue: [ self selectedItem theMetaClass traitComposition ifNotEmpty: [ :composition | html with: 'Class-side uses '. composition do: [ :each | self renderClassLinkTo: each trait on: html ] separatedBy: [ html with: ', ' ]. html with: '. ' ] ] ] ! ! HLToolListWidget subclass: #HLMethodsListWidget slots: {#selectorsCache} package: 'Helios-Browser'! !HLMethodsListWidget commentStamp! I render a list of methods for the selected protocol.! !HLMethodsListWidget methodsFor: 'accessing'! allProtocol ^ self model allProtocol ! cssClassForItem: aSelector | override overriden method | method := self methodForSelector: aSelector. override := self isOverride: method. overriden := self isOverridden: method. ^ override ifTrue: [ overriden ifTrue: [ 'override-overridden' ] ifFalse: [ 'override' ] ] ifFalse: [ overriden ifTrue: [ 'overridden' ] ifFalse: [ '' ] ] ! label ^ 'Methods' ! methodForSelector: aSelector ^ self model selectedClass methodDictionary at: aSelector ! methodsInProtocol: aString self model selectedClass ifNil: [ ^ #() ]. ^ aString = self allProtocol ifTrue: [ self model selectedClass methods ] ifFalse: [ self model selectedClass methodsInProtocol: aString ] ! overrideSelectors ^ self selectorsCache at: 'override' ifAbsentPut: [ self model selectedClass allSuperclasses inject: Set new into: [ :acc :each | acc addAll: each selectors; yourself ] ] ! overridenSelectors ^ self selectorsCache at: 'overriden' ifAbsentPut: [ self model selectedClass allSubclasses inject: Set new into: [ :acc :each | acc addAll: each selectors; yourself ] ] ! selectorsCache ^ self class selectorsCache ! selectorsInProtocol: aString ^ ((self methodsInProtocol: aString) collect: [ :each | each selector ]) sorted ! ! !HLMethodsListWidget methodsFor: 'actions'! focus super focus. self selectedItem ifNil: [ self model showMethodTemplate ] ! observeModel self model announcer on: HLProtocolSelected send: #onProtocolSelected: to: self; on: HLShowInstanceToggled send: #onShowInstanceToggled to: self; on: HLMethodSelected send: #onMethodSelected: to: self; on: HLMethodsFocusRequested send: #onMethodsFocusRequested to: self ! observeSystem self model systemAnnouncer on: ProtocolAdded send: #onProtocolAdded: to: self; on: ProtocolRemoved send: #onProtocolRemoved: to: self; on: MethodAdded send: #onMethodAdded: to: self; on: MethodRemoved send: #onMethodRemoved: to: self; on: MethodMoved send: #onMethodMoved: to: self ! reselectItem: aSelector self model softSelectedMethod: (self methodForSelector: aSelector) ! selectItem: aSelector aSelector ifNil: [ ^ self model selectedMethod: nil ]. self model selectedMethod: (self methodForSelector: aSelector) ! ! !HLMethodsListWidget methodsFor: 'private'! setItemsForProtocol: aString ^ self items: (aString ifNil: [ #() ] ifNotNil: [ self selectorsInProtocol: aString ]) ! setItemsForSelectedProtocol self setItemsForProtocol: self model selectedProtocol ! ! !HLMethodsListWidget methodsFor: 'reactions'! onMethodAdded: anAnnouncement self model selectedClass = anAnnouncement method methodClass ifFalse: [ ^ self ]. self setItemsForSelectedProtocol. self refresh ! onMethodMoved: anAnnouncement self model selectedMethod = anAnnouncement method ifFalse: [ ^ self ]. self model selectedProtocol = self model allProtocol ifFalse: [ self selectedItem: nil; selectItem: nil; setItemsForSelectedProtocol; refresh ] ! onMethodRemoved: anAnnouncement | method | method := anAnnouncement method. self items detect: [ :each | each = method selector ] ifNone: [ ^ self ]. self selectedItem ifNotNil: [ (method methodClass = self model selectedClass and: [ method selector = self selectedItem ]) ifTrue: [ self selectedItem: nil; selectItem: nil ] ]. self setItemsForSelectedProtocol. self refresh; focus ! onMethodSelected: anAnnouncement | selector method | method := anAnnouncement item. selector := method isCompiledMethod ifTrue: [ method selector ] ifFalse: [ nil ]. self selectedItem: selector; activateItem: selector ! onMethodsFocusRequested self focus ! onProtocolAdded: anAnnouncement self model selectedClass = anAnnouncement theClass ifFalse: [ ^ self ]. self setItemsForSelectedProtocol. self refresh. self focus ! onProtocolRemoved: anAnnouncement self model selectedClass = anAnnouncement theClass ifFalse: [ ^ self ]. self setItemsForSelectedProtocol. self refresh. self focus ! onProtocolSelected: anAnnouncement anAnnouncement isSoft ifTrue: [ ^ self ]. self selectedItem: nil. self setItemsForSelectedProtocol. self refresh ! onShowInstanceToggled self onProtocolSelected: (HLProtocolSelected on: nil) ! ! !HLMethodsListWidget methodsFor: 'rendering'! renderContentOn: html self model showInstance ifFalse: [ html div class: 'class_side'; with: [ super renderContentOn: html ] ] ifTrue: [ super renderContentOn: html ] ! renderItemLabel: aSelector on: html | origin | origin := (self methodForSelector: aSelector) origin. self model selectedClass = origin ifTrue: [ html with: aSelector ] ifFalse: [ html with: aSelector; with: ' '; with: '(', origin name, ')' ] ! ! !HLMethodsListWidget methodsFor: 'testing'! isOverridden: aMethod ^ self selectorsCache isOverridden: aMethod ! isOverride: aMethod ^ self selectorsCache isOverride: aMethod ! ! HLMethodsListWidget class slots: {#selectorsCache}! !HLMethodsListWidget class methodsFor: 'accessing'! selectorsCache ^ HLSelectorsCache current ! ! HLToolListWidget subclass: #HLPackagesListWidget slots: {} package: 'Helios-Browser'! !HLPackagesListWidget commentStamp! I render a list of the system packages.! !HLPackagesListWidget methodsFor: 'accessing'! cssClassForItem: anItem ^ anItem isDirty ifTrue: [ 'package_dirty' ] ifFalse: [ 'package' ] ! items ^ items ifNil: [ self initializeItems ] ! label ^ 'Packages' ! ! !HLPackagesListWidget methodsFor: 'actions'! focusClassesListWidget self model announcer announce: HLClassesListFocus new ! observeModel self model announcer on: HLPackageSelected send: #onPackageSelected: to: self; on: HLPackagesFocusRequested send: #onPackagesFocusRequested to: self ! observeSystem self model systemAnnouncer on: ClassAdded send: #onClassAdded: to: self. self model systemAnnouncer on: PackageAdded send: #onPackageAdded: to: self. self model systemAnnouncer on: PackageRemoved send: #onPackageRemoved: to: self. self model systemAnnouncer on: PackageClean send: #onPackageStateChanged to: self. self model systemAnnouncer on: PackageDirty send: #onPackageStateChanged to: self. ! reselectItem: anItem self model softSelectedPackage: anItem ! selectItem: aPackage super selectItem: aPackage. self model selectedPackage: aPackage ! ! !HLPackagesListWidget methodsFor: 'initialization'! initializeItems ^ items := self model packages sort: [ :a :b | a name < b name ] ! ! !HLPackagesListWidget methodsFor: 'reactions'! onClassAdded: anAnnouncement "Amber doesn't have yet a global organizer for packages" (self items includes: anAnnouncement theClass package) ifFalse: [ self initializeItems; refresh ] ! onPackageAdded: anAnnouncement self initializeItems; refresh ! onPackageRemoved: anAnnouncement self initializeItems; refresh ! onPackageSelected: anAnnouncement | package | package := anAnnouncement item. self selectedItem: package. self hasFocus ifFalse: [ self activateItem: package; focus ] ! onPackageStateChanged self refresh ! onPackagesFocusRequested self focus ! ! !HLPackagesListWidget methodsFor: 'rendering'! renderItemLabel: aPackage on: html html with: aPackage name ! ! HLToolListWidget subclass: #HLProtocolsListWidget slots: {} package: 'Helios-Browser'! !HLProtocolsListWidget commentStamp! I render a list of protocols for the selected class.! !HLProtocolsListWidget methodsFor: 'accessing'! allProtocol ^ self model allProtocol ! cssClassForItem: anItem anItem = self allProtocol ifTrue: [ ^ '' ]. anItem = 'private' ifTrue: [ ^ 'private' ]. anItem = 'initialization' ifTrue: [ ^ 'initialization' ]. (anItem match: '^\*') ifTrue: [ ^ 'extension' ]. ^ '' ! label ^ 'Protocols' ! selectedItem ^ super selectedItem" ifNil: [ self allProtocol ]" ! ! !HLProtocolsListWidget methodsFor: 'actions'! observeModel self model announcer on: HLClassSelected send: #onClassSelected: to: self; on: HLShowInstanceToggled send: #onShowInstanceToggled: to: self; on: HLProtocolSelected send: #onProtocolSelected: to: self; on: HLProtocolsFocusRequested send: #onProtocolsFocusRequested to: self ! observeSystem self model systemAnnouncer on: ProtocolAdded send: #onProtocolAdded: to: self; on: ProtocolRemoved send: #onProtocolRemoved: to: self ! reselectItem: anItem self model softSelectedProtocol: anItem ! selectItem: aString self model selectedProtocol: aString ! ! !HLProtocolsListWidget methodsFor: 'private'! setItemsForClass: aClass self items: (aClass ifNil: [ Array with: self allProtocol ] ifNotNil: [ (Array with: self allProtocol) addAll: aClass protocols; yourself ]) ! setItemsForSelectedClass self setItemsForClass: self model selectedClass ! ! !HLProtocolsListWidget methodsFor: 'reactions'! onClassSelected: anAnnouncement anAnnouncement isSoft ifTrue: [ ^ self ]. self selectedItem: nil. self setItemsForSelectedClass. self refresh ! onProtocolAdded: anAnnouncement | class | class := anAnnouncement theClass. class = self model selectedClass ifFalse: [ ^ self ]. self setItemsForSelectedClass. self refresh ! onProtocolRemoved: anAnnouncement | class protocol | class := anAnnouncement theClass. protocol := anAnnouncement protocol. class = self model selectedClass ifFalse: [ ^ self ]. self model selectedProtocol = protocol ifTrue: [ self selectedItem: nil; selectItem: nil ]. self setItemsForSelectedClass. self refresh ! onProtocolSelected: anAnnouncement | protocol | protocol := anAnnouncement item. self selectedItem: protocol. protocol ifNil: [ ^ self ]. self hasFocus ifFalse: [ self activateItem: protocol; focus ] ! onProtocolsFocusRequested self focus ! onShowInstanceToggled: anAnnouncement self onClassSelected: (HLClassSelected on: nil) ! ! !HLProtocolsListWidget methodsFor: 'rendering'! renderContentOn: html self model showInstance ifFalse: [ html div class: 'class_side'; with: [ super renderContentOn: html ] ] ifTrue: [ super renderContentOn: html ] ! ! Object subclass: #HLSelectorsCache slots: {#classesCache} package: 'Helios-Browser'! !HLSelectorsCache methodsFor: 'accessing'! cacheFor: aClass aClass ifNil: [ ^ nil ]. ^ self classesCache at: aClass name ifAbsentPut: [ self newCacheFor: aClass ] ! classesCache ^ classesCache ifNil: [ classesCache := HashedCollection new ] ! ! !HLSelectorsCache methodsFor: 'actions'! observeSystem SystemAnnouncer current on: MethodAdded send: #onMethodAdded: to: self; on: MethodRemoved send: #onMethodRemoved: to: self ! ! !HLSelectorsCache methodsFor: 'factory'! newCacheFor: aClass ^ HLClassCache on: aClass selectorsCache: self ! ! !HLSelectorsCache methodsFor: 'initialization'! initialize super initialize. self observeSystem ! ! !HLSelectorsCache methodsFor: 'private'! invalidateCacheFor: aMethod (self cacheFor: aMethod methodClass) invalidateSelector: aMethod selector ! ! !HLSelectorsCache methodsFor: 'reactions'! onMethodAdded: anAnnouncement self invalidateCacheFor: anAnnouncement method ! onMethodRemoved: anAnnouncement self invalidateCacheFor: anAnnouncement method ! ! !HLSelectorsCache methodsFor: 'testing'! isOverridden: aMethod ^ (self cacheFor: aMethod methodClass) isOverridden: aMethod ! isOverride: aMethod ^ (self cacheFor: aMethod methodClass) isOverride: aMethod ! ! HLSelectorsCache class slots: {#current}! !HLSelectorsCache class methodsFor: 'accessing'! current ^ current ifNil: [ current := super new ] ! flush current := nil ! ! !HLSelectorsCache class methodsFor: 'instance creation'! new self shouldNotImplement ! !