amber/st/Helios-Browser.st

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: '&nbsp;&nbsp;&nbsp;&nbsp;'].
			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
! !