helios/src/Helios-References.st

Smalltalk createPackage: 'Helios-References'!
HLWidget subclass: #HLReferences
	slots: {#model. #sendersListWidget. #implementorsListWidget. #classReferencesListWidget. #regexpListWidget. #sourceCodeWidget}
	package: 'Helios-References'!

!HLReferences methodsFor: 'accessing'!

classReferencesListWidget
	^ classReferencesListWidget ifNil: [
      	classReferencesListWidget := HLClassReferencesListWidget on: self model.
		classReferencesListWidget next: self regexpListWidget ]
!

implementorsListWidget
	^ implementorsListWidget ifNil: [
      	implementorsListWidget := HLImplementorsListWidget on: self model.
		implementorsListWidget next: self classReferencesListWidget ]
!

model
	^ model ifNil: [
		model := (HLReferencesModel new
			environment: self manager environment;
			yourself) ]
!

model: aModel
	model := aModel
!

regexpListWidget
	^ regexpListWidget ifNil: [
      	regexpListWidget := HLRegexpListWidget on: self model.
		regexpListWidget next: self sourceCodeWidget ]
!

sendersListWidget
	^ sendersListWidget ifNil: [
      	sendersListWidget := HLSendersListWidget on: self model.
		sendersListWidget next: self implementorsListWidget ]
!

sourceCodeWidget
	^ sourceCodeWidget ifNil: [
      	sourceCodeWidget := HLBrowserCodeWidget new
			browserModel: self model;
			yourself ]
! !

!HLReferences methodsFor: 'actions'!

registerBindingsOn: aBindingGroup
	HLToolCommand 
		registerConcreteClassesOn: aBindingGroup 
		for: self model
!

search: aString
	self model search: aString.
	self setTabLabel: aString
! !

!HLReferences methodsFor: 'rendering'!

renderContentOn: html
	html with: (HLContainer with: (HLHorizontalSplitter 
    	with: (HLVerticalSplitter
        	with: (HLVerticalSplitter
            	with: self sendersListWidget
                with: self implementorsListWidget)
            with: (HLVerticalSplitter
            	with: self classReferencesListWidget
                with: self regexpListWidget)) 
        with: self sourceCodeWidget)).
	
	self sendersListWidget focus
! !

!HLReferences class methodsFor: 'accessing'!

tabClass
	^ 'references'
!

tabLabel
	^ 'References'
!

tabPriority
	^ 100
! !

!HLReferences class methodsFor: 'testing'!

canBeOpenAsTab
	^ false
! !

HLToolListWidget subclass: #HLReferencesListWidget
	slots: {}
	package: 'Helios-References'!

!HLReferencesListWidget methodsFor: 'accessing'!

commandCategory
	^ 'Methods'
!

label
	^ 'List'
! !

!HLReferencesListWidget methodsFor: 'actions'!

activateListItem: anItem
	self model withChangesDo: [ super activateListItem: anItem ]
!

observeModel
	self model announcer
		on: HLSearchReferences
		do: [ :ann | self onSearchReferences: ann searchString ];
		on: HLMethodSelected
		do: [ :ann | self onMethodSelected: ann item ]
!

reselectItem: aMethod
	self selectItem: aMethod
!

selectItem: aMethod
	super selectItem: aMethod.
	self model selectedClass: nil; selectedMethod: aMethod
! !

!HLReferencesListWidget methodsFor: 'reactions'!

onMethodSelected: aMethod
	aMethod ifNil: [ ^ self ].
	(self items includes: aMethod) ifFalse: [ ^ self ].
	
	self 
		selectedItem: aMethod;
		activateItem: aMethod
!

onSearchReferences: aString
	self subclassResponsibility
! !

!HLReferencesListWidget methodsFor: 'rendering'!

renderItemLabel: aMethod on: html
	html with: aMethod asString
! !

!HLReferencesListWidget class methodsFor: 'instance creation'!

on: aModel
	^ self new 
		model: aModel; 
		yourself
! !

HLReferencesListWidget subclass: #HLClassReferencesListWidget
	slots: {}
	package: 'Helios-References'!

!HLClassReferencesListWidget methodsFor: 'accessing'!

label
	^ 'Class references'
! !

!HLClassReferencesListWidget methodsFor: 'reactions'!

onSearchReferences: aString
	self selectItem: nil.
	self items: (self model classReferencesOf: aString).
	self refresh
! !

HLReferencesListWidget subclass: #HLImplementorsListWidget
	slots: {}
	package: 'Helios-References'!

!HLImplementorsListWidget methodsFor: 'accessing'!

label
	^ 'Implementors'
! !

!HLImplementorsListWidget methodsFor: 'reactions'!

onSearchReferences: aString
	self selectItem: nil.
	self items: (self model implementorsOf: aString).
	self refresh
! !

HLReferencesListWidget subclass: #HLRegexpListWidget
	slots: {}
	package: 'Helios-References'!

!HLRegexpListWidget methodsFor: 'accessing'!

label
	^ 'Source search'
! !

!HLRegexpListWidget methodsFor: 'reactions'!

onSearchReferences: aString
	self selectItem: nil.
	self items: (self model regexpReferencesOf: aString).
	self refresh
! !

HLReferencesListWidget subclass: #HLSendersListWidget
	slots: {}
	package: 'Helios-References'!

!HLSendersListWidget methodsFor: 'accessing'!

label
	^ 'Senders'
! !

!HLSendersListWidget methodsFor: 'reactions'!

onSearchReferences: aString
	self selectItem: nil.
	self items: (self model sendersOf: aString).
	self refresh
! !

HLToolModel subclass: #HLReferencesModel
	slots: {#methodsCache. #classesAndMetaclassesCache}
	package: 'Helios-References'!

!HLReferencesModel methodsFor: 'accessing'!

allMethods
	^ self methodsCache
!

classReferencesOf: aString
	"Answer all methods referencing the class named aString"
	
	^self allMethods select: [ :each |
			(each referencedClasses includes: aString) ]
!

classesAndMetaclasses
	^ self classesAndMetaclassesCache
!

implementorsOf: aString
	^ self allMethods select: [ :each |
		each selector = aString ]
!

regexpReferencesOf: aString
	^ self allMethods select: [ :each |
		each source match: aString ]
!

sendersOf: aString
	^ self allMethods select: [ :each |
		each messageSends includes: aString ]
! !

!HLReferencesModel methodsFor: 'actions'!

openClassNamed: aString
	| browser |
	
	self withChangesDo: [
		browser := HLBrowser openAsTab.
		browser openClassNamed: aString ]
!

openMethod
	| browser |
	
	self selectedMethod ifNil: [ ^ self ].
	
	self withChangesDo: [
		browser := HLBrowser openAsTab.
		browser openMethod: self selectedMethod ]
!

search: aString
	self updateCaches.
	
	self announcer announce: (HLSearchReferences new
		searchString: aString;
		yourself)
! !

!HLReferencesModel methodsFor: 'cache'!

classesAndMetaclassesCache
	classesAndMetaclassesCache ifNil: [ self updateClassesAndMetaclassesCache ].
	^ classesAndMetaclassesCache
!

methodsCache
	methodsCache ifNil: [ self updateMethodsCache ].
	^ methodsCache
!

updateCaches
	self 
		updateClassesAndMetaclassesCache;
		updateMethodsCache
!

updateClassesAndMetaclassesCache
	classesAndMetaclassesCache := OrderedCollection new.
	
	self environment classes do: [ :eachClass | eachClass includingPossibleMetaDo: [ :each |
		classesAndMetaclassesCache add: each ] ]
!

updateMethodsCache
	methodsCache := OrderedCollection new.
	
	self classesAndMetaclasses
		do: [ :each | methodsCache addAll: each methods ]
! !

!HLReferencesModel methodsFor: 'testing'!

isReferencesModel
	^ true
! !