Smalltalk current createPackage: 'Helios-Browser'! HLWidget subclass: #HLBrowser instanceVariableNames: 'model packagesListWidget classesListWidget protocolsListWidget methodsListWidget sourceWidget bottomDiv' package: 'Helios-Browser'! !HLBrowser methodsFor: 'accessing'! environment ^ self model environment ! model ^ model ifNil: [ model := HLBrowserModel new ] ! model: aModel model := aModel ! ! !HLBrowser methodsFor: 'actions'! focus ^ self packagesListWidget focus ! ! !HLBrowser methodsFor: 'keybindings'! registerBindingsOn: aBindingGroup HLToolCommand registerConcreteClassesOn: aBindingGroup for: self model ! ! !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 instanceVariableNames: 'nextId'! !HLBrowser class methodsFor: 'accessing'! nextId nextId ifNil: [ nextId := 0 ]. ^ 'browser_', (nextId + 1) asString ! tabLabel ^ 'Browser' ! tabPriority ^ 0 ! ! !HLBrowser class methodsFor: 'testing'! canBeOpenAsTab ^ true ! ! HLWidget subclass: #HLBrowserBottomWidget instanceVariableNames: 'model codeWidget documentationWidget selectedWidget' package: 'Helios-Browser'! !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" ! selectedWidget ^ selectedWidget ifNil: [ selectedWidget := self codeWidget ] ! ! !HLBrowserBottomWidget methodsFor: 'actions'! focus self selectedWidget focus ! observeModel self model announcer on: HLShowInstanceToggled do: [ self onShowInstanceToggled ]; on: HLShowCommentToggled do: [ self onShowCommentToggled ] ! selectWidget: aWidget selectedWidget := aWidget. self refresh ! ! !HLBrowserBottomWidget methodsFor: 'reactions'! onShowCommentToggled self selectWidget: self documentationWidget ! onShowInstanceToggled self selectWidget: self codeWidget ! ! !HLBrowserBottomWidget methodsFor: 'rendering'! renderContentOn: html html with: self selectedWidget ! ! !HLBrowserBottomWidget methodsFor: 'testing'! canHaveFocus ^ true ! ! HLToolModel subclass: #HLBrowserModel instanceVariableNames: 'showInstance showComment' package: 'Helios-Browser'! !HLBrowserModel methodsFor: 'accessing'! showComment ^ showComment ifNil: [ false ] ! showComment: aBoolean self withChangesDo: [ showComment := aBoolean. self announcer announce: HLShowCommentToggled new ] ! showInstance ^ showInstance ifNil: [ true ] ! showInstance: aBoolean self withChangesDo: [ showInstance := aBoolean. showComment := false. 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 ! focusOnMethods self announcer announce: HLMethodsFocusRequested new ! focusOnPackages self announcer announce: HLPackagesFocusRequested new ! focusOnProtocols self announcer announce: HLProtocolsFocusRequested new ! focusOnSourceCode self announcer announce: HLSourceCodeFocusRequested new ! ! !HLBrowserModel methodsFor: 'testing'! isBrowserModel ^ true ! ! !HLBrowserModel class methodsFor: 'actions'! on: anEnvironment ^ self new environment: anEnvironment; yourself ! ! Object subclass: #HLClassCache instanceVariableNames: '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 instanceVariableNames: '' package: 'Helios-Browser'! !HLClassesListWidget methodsFor: 'accessing'! getChildrenOf: aClass ^ self items select: [ :each | each superclass = aClass ] ! getRootClassesOf: aCollection ^ aCollection select: [ :each | (aCollection includes: each superclass) not ] ! iconForItem: aClass ^ aClass theNonMetaClass comment isEmpty ifFalse: [ 'icon-none' ] ifTrue: [ 'icon-question-sign' ] ! label ^ 'Classes' ! showClass ^ self model showInstance not and: [ self model showComment not ] ! showComment ^ self model showComment ! showInstance ^ self model showInstance and: [ self model showComment not ] ! ! !HLClassesListWidget methodsFor: 'actions'! focusMethodsListWidget self model announcer announce: HLMethodsListFocus new ! focusProtocolsListWidget self model announcer announce: HLProtocolsListFocus new ! observeModel self model announcer on: HLPackageSelected do: [ :ann | self onPackageSelected: ann item ]; on: HLShowInstanceToggled do: [ :ann | self onShowInstanceToggled ]; on: HLShowCommentToggled do: [ :ann | self onShowCommentToggled ]; on: HLClassSelected do: [ :ann | self onClassSelected: ann item ]; on: HLClassesFocusRequested do: [ :ann | self onClassesFocusRequested ] ! observeSystem self model systemAnnouncer on: ClassAdded do: [ :ann | self onClassAdded: ann theClass ]; on: ClassRemoved do: [ :ann | self onClassRemoved: ann theClass ]; on: ClassMoved do: [ :ann | self onClassMoved: ann theClass from: ann oldPackage ]; on: ClassRenamed do: [ :ann | self onClassRenamed: ann theClass ] ! selectItem: aClass self model selectedClass: aClass ! showComment: aBoolean self model showComment: aBoolean ! showInstance: aBoolean self model showInstance: aBoolean ! ! !HLClassesListWidget methodsFor: 'private'! setItemsForPackage: aPackage self items: (aPackage ifNil: [ #() ] ifNotNil: [ ((aPackage classes collect: [ :each | each theNonMetaClass ]) asSet asArray) sort: [:a :b | a name < b name ] ]). ! setItemsForSelectedPackage self setItemsForPackage: self model selectedPackage ! ! !HLClassesListWidget methodsFor: 'reactions'! onClassAdded: aClass (aClass package = self model selectedPackage or: [ self items includes: aClass ]) ifFalse: [ ^ self ]. self setItemsForSelectedPackage. self refresh ! onClassMoved: aClass from: aPackage (aPackage = self model selectedPackage or: [ aClass package = self model selectedPackage ]) ifFalse: [ ^ self ]. aPackage = self model selectedPackage ifTrue: [ self selectedItem: nil; selectItem: nil ]. self setItemsForSelectedPackage. self refresh ! onClassRemoved: aClass aClass package = self model selectedPackage ifFalse: [ ^ self ]. aClass = self model selectedClass ifTrue: [ self selectItem: nil ]. self setItemsForSelectedPackage. self refresh ! onClassRenamed: aClass aClass package = self model selectedPackage ifFalse: [ ^ self ]. self setItemsForSelectedPackage. self refresh ! onClassSelected: aClass | selectedClass | aClass ifNil: [ ^ self ]. selectedClass := aClass theNonMetaClass. self selectedItem: selectedClass. self hasFocus ifFalse: [ self activateItem: selectedClass; focus ] ! onClassesFocusRequested self focus ! onPackageSelected: aPackage self selectedItem: nil. self setItemsForSelectedPackage. self refresh ! onShowCommentToggled self refresh ! onShowInstanceToggled self refresh ! ! !HLClassesListWidget methodsFor: 'rendering'! renderButtonsOn: html html div class: 'btn-group'; with: [ html button class: (String streamContents: [ :str | str nextPutAll: 'btn'. self showInstance ifTrue: [ str nextPutAll: ' active' ] ]); with: 'Instance'; onClick: [ self showInstance: true ]. html button class: (String streamContents: [ :str | str nextPutAll: 'btn'. self showClass ifTrue: [ str nextPutAll: ' active' ] ]); with: 'Class'; onClick: [ self showInstance: false ]. html button class: (String streamContents: [ :str | str nextPutAll: 'btn'. self showComment ifTrue: [ str nextPutAll: ' active' ] ]); with: 'Doc'; onClick: [ self showComment: true ] ] ! renderItem: aClass level: anInteger on: html | li | li := html li. self registerMappingFrom: aClass to: li. li at: 'list-data' put: (self items indexOf: aClass); class: (self cssClassForItem: aClass); with: [ html a with: [ (html tag: 'i') class: (self iconForItem: aClass). self renderItemLabel: aClass level: anInteger on: html ]; onClick: [ self activateListItem: li asJQuery ] ]. (self getChildrenOf: aClass) do: [ :each | self renderItem: each level: anInteger + 1 on: html ] ! renderItem: aClass on: html super renderItem: aClass on: html. (self getChildrenOf: aClass) do: [ :each | self renderItem: each level: 1 on: html ] ! renderItemLabel: aClass level: anInteger on: html html span asJQuery html: (String streamContents: [ :str | anInteger timesRepeat: [ str nextPutAll: '    ']. str nextPutAll: aClass name ]) ! renderItemLabel: aClass on: html self renderItemLabel: aClass level: 0 on: html ! renderListOn: html (self getRootClassesOf: self items) do: [ :each | self renderItem: each on: html ] ! ! HLFocusableWidget subclass: #HLDocumentationWidget instanceVariableNames: 'model' package: 'Helios-Browser'! !HLDocumentationWidget methodsFor: 'accessing'! documentation ^ self model selectedClass theNonMetaClass comment ifNil: [ self defaultDocumentation ] ! model ^ model ! model: aModel model := aModel ! ! !HLDocumentationWidget methodsFor: 'defaults'! defaultDocumentation ^ '#No documentation available. ##That''s bad. Seriously.' ! ! !HLDocumentationWidget methodsFor: 'rendering'! renderContentOn: html (html div class: 'markdown'; asJQuery) html: ((Showdown at: 'converter') new makeHtml: self documentation) ! ! HLToolListWidget subclass: #HLMethodsListWidget instanceVariableNames: 'selectorsCache' package: 'Helios-Browser'! !HLMethodsListWidget methodsFor: 'accessing'! allProtocol ^ self model allProtocol ! iconForItem: aSelector | override overriden method | method := self methodForSelector: aSelector. override := self isOverride: method. overriden := self isOverridden: method. ^ override ifTrue: [ overriden ifTrue: [ 'icon-resize-vertical' ] ifFalse: [ 'icon-arrow-up' ] ] ifFalse: [ overriden ifTrue: [ 'icon-arrow-down' ] ifFalse: [ 'icon-none' ] ] ! 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'! observeModel self model announcer on: HLProtocolSelected do: [ :ann | self onProtocolSelected: ann item ]; on: HLShowInstanceToggled do: [ :ann | self onProtocolSelected: nil ]; on: HLMethodSelected do: [ :ann | self onMethodSelected: ann item ]; on: HLMethodsFocusRequested do: [ :ann | self onMethodsFocusRequested ] ! observeSystem self model systemAnnouncer on: ProtocolAdded do: [ :ann | self onProtocolAdded: ann theClass ]; on: ProtocolRemoved do: [ :ann | self onProtocolRemoved: ann theClass ]; on: MethodAdded do: [ :ann | self onMethodAdded: ann method ]; on: MethodRemoved do: [ :ann | self onMethodRemoved: ann method ]; on: MethodMoved do: [ :ann | self onMethodMoved: ann method ] ! 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: aMethod self model selectedClass = aMethod methodClass ifFalse: [ ^ self ]. self setItemsForSelectedProtocol. self refresh ! onMethodMoved: aMethod self model selectedMethod = aMethod ifFalse: [ ^ self ]. self model selectedProtocol = self model allProtocol ifFalse: [ self selectedItem: nil; selectItem: nil; setItemsForSelectedProtocol; refresh ] ! onMethodRemoved: aMethod self items detect: [ :each | each = aMethod selector ] ifNone: [ ^ self ]. self selectedItem ifNotNil: [ (aMethod methodClass = self model selectedClass and: [ aMethod selector = self selectedItem ]) ifTrue: [ self selectedItem: nil; selectItem: nil ] ]. self setItemsForSelectedProtocol. self refresh ! onMethodSelected: aMethod | selector | selector := aMethod isCompiledMethod ifTrue: [ aMethod selector ] ifFalse: [ nil ]. self selectedItem: selector; activateItem: selector ! onMethodsFocusRequested self focus ! onProtocolAdded: aClass self model selectedClass = aClass ifFalse: [ ^ self ]. self setItemsForSelectedProtocol. self refresh. self focus ! onProtocolRemoved: aClass self model selectedClass = aClass ifFalse: [ ^ self ]. self setItemsForSelectedProtocol. self refresh. self focus ! onProtocolSelected: aString self selectedItem: nil. self setItemsForSelectedProtocol. self refresh ! ! !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 html with: aSelector ! ! !HLMethodsListWidget methodsFor: 'testing'! isOverridden: aMethod ^ self selectorsCache isOverridden: aMethod ! isOverride: aMethod ^ self selectorsCache isOverride: aMethod ! ! HLMethodsListWidget class instanceVariableNames: 'selectorsCache'! !HLMethodsListWidget class methodsFor: 'accessing'! selectorsCache ^ HLSelectorsCache current ! ! HLToolListWidget subclass: #HLPackagesListWidget instanceVariableNames: '' package: 'Helios-Browser'! !HLPackagesListWidget methodsFor: 'accessing'! items ^ items ifNil: [self initializeItems] ! label ^ 'Packages' ! ! !HLPackagesListWidget methodsFor: 'actions'! commitPackage self model commitPackage ! focusClassesListWidget self model announcer announce: HLClassesListFocus new ! observeModel self model announcer on: HLPackageSelected do: [ :ann | self onPackageSelected: ann item ]; on: HLPackagesFocusRequested do: [ :ann | self onPackagesFocusRequested ] ! observeSystem self model systemAnnouncer on: ClassAdded do: [ :ann | self onClassAdded: ann theClass ] ! 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: aClass "Amber doesn't have yet a global organizer for packages" (self items includes: aClass package) ifFalse: [ self initializeItems; refresh ] ! onPackageSelected: aPackage self selectedItem: aPackage. self hasFocus ifFalse: [ self activateItem: aPackage; focus ] ! onPackagesFocusRequested self focus ! ! !HLPackagesListWidget methodsFor: 'rendering'! renderButtonsOn: html html div class: 'buttons'; with: [ html button class: 'btn'; with: 'Commit'; onClick: [ self commitPackage ] ] ! renderItemLabel: aPackage on: html html with: aPackage name ! ! HLToolListWidget subclass: #HLProtocolsListWidget instanceVariableNames: '' package: 'Helios-Browser'! !HLProtocolsListWidget methodsFor: 'accessing'! allProtocol ^ self model allProtocol ! label ^ 'Protocols' ! selectedItem ^ super selectedItem" ifNil: [ self allProtocol ]" ! ! !HLProtocolsListWidget methodsFor: 'actions'! observeModel self model announcer on: HLClassSelected do: [ :ann | self onClassSelected: ann item ]; on: HLShowInstanceToggled do: [ :ann | self onClassSelected: self model selectedClass ]; on: HLProtocolSelected do: [ :ann | self onProtocolSelected: ann item ]; on: HLProtocolsFocusRequested do: [ :ann | self onProtocolsFocusRequested ] ! observeSystem self model systemAnnouncer on: ProtocolAdded do: [ :ann | self onProtocolAdded: ann protocol to: ann theClass ]; on: ProtocolRemoved do: [ :ann | self onProtocolRemoved: ann protocol from: ann theClass ] ! 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: aClass self selectedItem: nil. self setItemsForSelectedClass. self refresh ! onProtocolAdded: aString to: aClass aClass = self model selectedClass ifFalse: [ ^ self ]. self setItemsForSelectedClass. self refresh ! onProtocolRemoved: aString from: aClass aClass = self model selectedClass ifFalse: [ ^ self ]. self model selectedProtocol = aString ifTrue: [ self selectedItem: nil; selectItem: nil ]. self setItemsForSelectedClass. self refresh ! onProtocolSelected: aString self selectedItem: aString. aString ifNil: [ ^ self ]. self hasFocus ifFalse: [ self activateItem: aString; focus ] ! onProtocolsFocusRequested self focus ! ! !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 instanceVariableNames: '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 do: [ :ann | self onMethodAdded: ann method ]; on: MethodRemoved do: [ :ann | self onMethodRemoved: ann method ] ! ! !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: aMethod self invalidateCacheFor: aMethod ! onMethodRemoved: aMethod self invalidateCacheFor: aMethod ! ! !HLSelectorsCache methodsFor: 'testing'! isOverridden: aMethod ^ (self cacheFor: aMethod methodClass) isOverridden: aMethod ! isOverride: aMethod ^ (self cacheFor: aMethod methodClass) isOverride: aMethod ! ! HLSelectorsCache class instanceVariableNames: 'current'! !HLSelectorsCache class methodsFor: 'accessing'! current ^ current ifNil: [ current := super new ] ! flush current := nil ! ! !HLSelectorsCache class methodsFor: 'instance creation'! new self shouldNotImplement ! !