'From VisualWorks(R), Release 2.5.1 of 26-9-1995 on 23-1-2000 at 11:27:24'!

AGPrintPolicy variableSubclass: #AGCoveragePrintPolicy
	instanceVariableNames: 'emphasis '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Zork_Analysis'!

AGCoveragePrintPolicy comment: 'Comment:
	Instances of AGCoveragePrintPolicy print traced methods with a suitable emphasis, to distinguish between methods that have not been called, methods that have been activated completely, and methods that have been activated partially.

Instance variables:
	emphasis	<Symbol>	Global emphasis for the text. Can be overridden by sub-expressions.'!


!AGCoveragePrintPolicy methodsFor: 'printing'!

printAssignment: anAGAssignment on: aStream indent: level 
	"Print the assignment expression on the stream with given indent."

	anAGAssignment variable printOn: aStream indent: level policy: self.
	self do: [ aStream nextPutAll: ' := ' ] stream: aStream emphasis: (self partialEmphasisFor: anAGAssignment).
	anAGAssignment value printOn: aStream indent: level + 2 policy: self!

printAssignment: anAGAssignment on: aStream indent: level precedence: p 
	"Print the assignment expression on the stream with given indent, taking into account the precedence level.
	Precedence levels < 4 imply the statement is being used as a receiver or argument expression."

	p < 4 ifTrue: [ self do: [ aStream nextPut: $( ] stream: aStream emphasis: (self partialEmphasisFor: anAGAssignment)].
	self printAssignment: anAGAssignment on: aStream indent: level.
	p < 4 ifTrue: [ self do: [ aStream nextPut: $) ] stream: aStream emphasis: (self partialEmphasisFor: anAGAssignment)].!

printBlock: anAGBlock on: aStream indent: level 
	"Print the block expression on the stream with given indent level."

	anAGBlock size > 1 ifTrue: [ aStream crtab: level ].
	self do: [ aStream nextPut: $[ ] stream: aStream emphasis: (self partialEmphasisFor: anAGBlock).
	self do: [ self printArguments: anAGBlock on: aStream indent: level ] stream: aStream emphasis: (self partialEmphasisFor: anAGBlock).
	(anAGBlock size > 1 and: [ anAGBlock arguments size > 0 ])
		ifTrue: [ aStream crtab: level ].
	self printBody: anAGBlock on: aStream indent: level.
	self do: [ aStream nextPut: $] ] stream: aStream emphasis: (self partialEmphasisFor: anAGBlock).!

printCascadedExpression: anAGCascadedExpression on: aStream indent: level
	"Print the cascaded expression on the stream with given indent."

	self do: [ super printCascadedExpression: anAGCascadedExpression on: aStream indent: level ] stream: aStream emphasis: (self partialEmphasisFor: anAGCascadedExpression)!

printCascadedExpression: anAGCascadedExpression on: aStream indent: level precedence: p
	"Print the cascaded expression on the stream with given indent, taking into account the precedence level.
	Precedence levels < 4 imply the statement is being used as a receiver or argument expression."

	self do: [ super printCascadedExpression: anAGCascadedExpression on: aStream indent: level precedence: p ] stream: aStream emphasis: (self partialEmphasisFor: anAGCascadedExpression)!

printLiteral: anAGLiteral on: aStream indent: level 
	"Print the literal on the stream with given indent."

	self do: [ super printLiteral: anAGLiteral on: aStream indent: level ] stream: aStream emphasis: (self partialEmphasisFor: anAGLiteral)!

printMessageExpression: anAGMessageExpression on: aStream indent: level precedence: p 
	"Print the message expression on the stream with given indent, taking into account the precedence."

	| parenthesize |

	parenthesize := anAGMessageExpression precedence > p
						or: [ p = 3 and: [ anAGMessageExpression precedence = 3 ]].
	parenthesize ifTrue: [ self do: [ aStream nextPut: $( ] stream: aStream emphasis: (self partialEmphasisFor: anAGMessageExpression)].
	self printMessageExpression: anAGMessageExpression on: aStream indent: level.
	parenthesize ifTrue: [ self do: [ aStream nextPut: $) ] stream: aStream emphasis: (self partialEmphasisFor: anAGMessageExpression)]!

printMethod: anAGMethod on: aStream indent: level
	"Print the method on the stream with given indent."

	| nextLevel |

	self printSelector: anAGMethod on: aStream indent: level.
	nextLevel := level + 1.
	aStream crtab: nextLevel; crtab: nextLevel.
	self do: [ self printBody: anAGMethod on: aStream indent: nextLevel ] stream: aStream emphasis: (self globalEmphasisFor: anAGMethod)!

printPseudoVariable: anAGPseudoVariable on: aStream indent: level
	"Print the name (self or super) of the receiver on the stream with given indent."

	self do: [ super printPseudoVariable: anAGPseudoVariable on: aStream indent: level ] stream: aStream emphasis: (self partialEmphasisFor: anAGPseudoVariable)!

printReturn: anAGReturn on: aStream indent: level 
	"Print the return expression on the stream with given indent."

	self do: [ aStream nextPutAll: '^ ' ] stream: aStream emphasis: (self partialEmphasisFor: anAGReturn).
	anAGReturn value printOn: aStream indent: level policy: self!

printVariable: anAGVariable on: aStream indent: level
	"Print the name of the variable on the stream with given indent."

	self do: [ super printVariable: anAGVariable on: aStream indent: level ] stream: aStream emphasis: (self partialEmphasisFor: anAGVariable)! !

!AGCoveragePrintPolicy methodsFor: 'private'!

do: aBlock stream: aStream emphasis: aSymbol
	"Execute the block using given emphasis if necessary. Ignore the emphasis if the global emphasis is #full, i.e. the method has been activated completely."

	| needsEmphasis |

	needsEmphasis := aSymbol ~~ #partial or: [ emphasis == #empty ].
	needsEmphasis
		ifTrue: [ aStream emphasis: (self perform: aSymbol)].
	aBlock value.
	needsEmphasis
		ifTrue: [ aStream emphasis: (self perform: emphasis)]! !

!AGCoveragePrintPolicy methodsFor: 'private-emphasis'!

empty
	"Answer the emphasis for expressions that have not been activated."

	^ #color -> ColorValue navy!

full
	"Answer the emphasis for expressions that have been activated completely."

	^ #color -> ColorValue darkGreen!

getGlobalEmphasisFor: anAGMethod
	"Determine a suitable emphasis for the global method."

	^ anAGMethod visitedNodeCount = anAGMethod nodeCount
		ifTrue: [ #full ]
		ifFalse: [ #empty ]!

globalEmphasisFor: anAGMethod
	"Answer a suitable emphasis for the global method."

	^ emphasis isNil
		ifTrue: [ emphasis := self getGlobalEmphasisFor: anAGMethod ]
		ifFalse: [ emphasis ]!

partial
	"Answer the emphasis for expressions that have been partially completely."

	^ #color -> ColorValue red!

partialEmphasisFor: anAGExpression
	"Determine the emphasis for given expression."

	^ anAGExpression activations > 0
		ifTrue: [ #partial ]
		ifFalse: [ #empty ]! !

!AGCoveragePrintPolicy methodsFor: 'private-printing'!

printBody: anAGCode on: aStream indent: level
	"Print the temporary variables and body of given method or block on a stream with given indent."

	| indent |
	
	indent := false.
	anAGCode temporaries isEmpty
		ifFalse: [ self do: [ indent ifTrue: [ aStream crtab: level ].
										aStream nextPutAll: '| '.
										anAGCode temporaries do:
											[ :temp | aStream nextPutAll: temp; space ].
										aStream nextPut: $|; crtab: level ]
					  stream: aStream
					  emphasis: (self partialEmphasisFor: anAGCode).
				   indent := true ].
	1 to: anAGCode size do: 
		[ :i | | statement |
			 statement := anAGCode at: i.
			 indent ifTrue: [ aStream crtab: level ].
			 (i = anAGCode size and: [ statement isSelf ])
					ifFalse: [ statement printOn: aStream indent: level policy: self ].
			 i < anAGCode size ifTrue: [ aStream nextPut: $. ].
			 indent := true ]!

printMessage: anAGMessageExpression on: aStream indent: level 
	"Print the selector and arguments of given message expression on the stream with given indent."

	| prev arg indent thisKey keywords |

	anAGMessageExpression arguments size = 0 
		ifTrue: [ self do: [ aStream space; nextPutAll: anAGMessageExpression selector. ^ self ] stream: aStream emphasis: (self partialEmphasisFor: anAGMessageExpression)].
	keywords := anAGMessageExpression selector keywords.
	prev := anAGMessageExpression receiver.
	1 to: anAGMessageExpression arguments size do:
		[ :i | arg := anAGMessageExpression arguments at: i.
			 thisKey := keywords at: i.
			 (prev notNil and:
					[ prev isBlock or:
		 			[(prev isMessageExpression and: [ prev precedence >= 3 ]) or:
		 			[(arg isBlock and: [ arg size > 1 and: [ thisKey ~= #do:]]) or:
		   			[ anAGMessageExpression arguments size > 2 or:
		    			[ anAGMessageExpression selector == #ifTrue:ifFalse: ]]]]])
				ifTrue: [ aStream crtab: level+1. indent := 1 ] "newline after big arguments"
				ifFalse: [ aStream space. indent := 0 ].
			 self do: [ aStream nextPutAll: thisKey; space ] stream: aStream emphasis: (self partialEmphasisFor: anAGMessageExpression).
			 arg
				printOn: aStream
				indent: level + 1 + indent
				precedence: (anAGMessageExpression precedence = 2 ifTrue: [1] ifFalse: [ anAGMessageExpression precedence ])
				policy: self.
			 prev := arg ]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AGCoveragePrintPolicy class
	instanceVariableNames: ''!


MethodWrapper variableSubclass: #CoverageMethodWrapper
	instanceVariableNames: 'expression '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Zork_Analysis'!

CoverageMethodWrapper comment: 'Comment:
	Instances of CoverageMethodWrapper dispatch the call to an interpreter. The interpreter keeps track of activations of the various elements in the expression tree.

Instance variables:
	expression	<AGMethod>	Instance of the abstract grammar expressions representing methods.'!


!CoverageMethodWrapper methodsFor: 'accessing'!

activations
	"Answer the total number of activations in the method's expression tree."

	^ expression isNil
		ifTrue: [ 0 ]
		ifFalse: [ expression activations ]!

totalExpressionCount
	"Answer the numer of nodes in the message tree."

	^ self isCalled
		ifTrue: [ self expression nodeCount ]
		ifFalse: [ 0 ]!

tracedExpressionCount
	"Answer the numer of activated nodes in the message tree."

	^ self isCalled
		ifTrue: [ self expression visitedNodeCount ]
		ifFalse: [ 0 ]!

tracedMethods
	"Answer a dictionary of messages that have been sent and the corresponding actual method invocations."

	| methods |

	self isCalled
		ifFalse: [ ^ Dictionary new ].
	methods := Dictionary new.
	self expression messageExpressions do:
		[ :exp | exp methods isEmpty
					ifFalse: [(methods at: exp selector ifAbsentPut: [ Set new ]) addAll: exp methods ]].
	^ methods! !

!CoverageMethodWrapper methodsFor: 'accessing-literals'!

symbolLiterals
	"Answer the symbol literals referenced by the receiver
	 (ie. sent or referenced)."

	^ clientMethod symbolLiterals! !

!CoverageMethodWrapper methodsFor: 'EM-Internal'!

filePointer
	"Answer the file pointer for the receiver's record."

	^ clientMethod filePointer! !

!CoverageMethodWrapper methodsFor: 'evaluating'!

valueWithReceiver: anObject arguments: anArrayOfObjects
	"Evaluate the method. The argument is an Array whose elements are the
	arguments for the method."

	^ self expression valueWithReceiver: anObject arguments: anArrayOfObjects! !

!CoverageMethodWrapper methodsFor: 'private'!

printPolicy
	"Answer a suitable print policy for displaying the source."

	^ AGCoveragePrintPolicy new! !

!CoverageMethodWrapper methodsFor: 'private-accessing'!

expression
	"Answer the expression. Compile the source on demand."

	expression isNil
		ifTrue: [ expression := AGCompiler new compile: self getSource in: self methodClass notifying: nil ifFail: [ nil ]].
	^ expression! !

!CoverageMethodWrapper methodsFor: 'source code management'!

getSource
	"Answer the source."

	^ clientMethod getSource!

getSourceText
	"Answer a suitably formatted representation of the receiver."

	^ self expression printText: self printPolicy! !

!CoverageMethodWrapper methodsFor: 'testing'!

isCalled
	"Answer whether this method has already been called."

	^ self activations > 0! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CoverageMethodWrapper class
	instanceVariableNames: ''!


EtApplicationManager subclass: #CoverageApplicationBrowser
	instanceVariableNames: 'showingMethodCoverage '
	classVariableNames: ''
	poolDictionaries: 'NlsCatEMT LabelsForMenuOptions '
	category: 'Zork_Analysis'!

CoverageApplicationBrowser comment: 'Comment:
	Instances of CoverageApplicationBrowser support browsing through applications / classes / protocols / methods.

	The top lists show the the number of activations or the ratio (number of methods called vs. total number) of methods in the selected protocols / classes / applications). Simply reactivating the window recomputes the ratios.
	Colors are used to convey the folllowing information:
		- black: no tracing performed
		- navy: traced but not called
		- dark green: traced and fully covered
		- red: traced and partially covered.

	The code is given as is (and only partially documented), since it is meant as a trial exercise. '!


!CoverageApplicationBrowser methodsFor: 'ET-Internal'!

annotatedSourceStringFor: method
	"Private - Return the source code for the method."

	| source comment |

	(source := method getSourceText) notNil ifTrue: [
		^source asText makeSelectorBoldIn: method methodClass].
	(method isBaseImageAddition not and: [method isLoaded]) ifTrue: [
		^source := (method methodClass decompile: method selector) decompiledCode asText
			makeSelectorBoldIn: method methodClass].
	(comment := method comment) isEmpty ifTrue: [
		^'Cannot access source code for #', method selector].
	^'Cannot access source code for #', method selector,
		'.\\-------------------- comment --------------------\' addLineDelimiters,
		comment!

applicationPrintBlock
	"Return a print block that will display an application's signature."

	^ [ :appl | (System isClassInstalled: appl)
					ifTrue: [ self printApplication: appl ]
					ifFalse: [ MxEMT143 ]]  "$NLS$ Deleted Application"!

applicationsButtonLabel
	"Answer the label for the applications list."

	^ 'Applications'!

applicationsMenu
	"Answer the applications menu."

	| newMenu onlyOne atLeastOne |

	(newMenu := self newMenu)
		title: 'App~lications';
		subMenuSelector: #applicationsMenu;
		owner: self;
		configureBlock: [
			self managerInterface flushCache.
			self checkForObsoleteClassesAndApplications.
			onlyOne := self isOneApplicationSelected.

			(atLeastOne := self isApplicationSelected) ifTrue: [
				self groupMembers size > 1.
				self selectedApplications conform: [:app |
						self managerInterface isVersion: app].
				self selectedApplications conform: [:app |
						(self managerInterface isEdition: app) not and: [
							self managerInterface userManages: app]]]].

	self class updateOnWindowActivation ifFalse: [
		newMenu add: #updateListOfApplications label: UpdateListOfApplications].

	^ newMenu
		add: #findApplication label: FindApplication;
		add: #findClassInApplication label: FindClassInApplication;
		add: #hideShowApplications label: HideShowApplications enable: [atLeastOne];
		addLine;
		addSubMenu: #fileOutApplicationsSubMenu    label: FileOutApplicationsSubMenu    enable: true    for: self;
		addLine;
		add: #editApplication label: BrowseApplication enable: [onlyOne];
		selection: self class applicationMenuSelection;
		selectionUpdateMessage: (DirectedMessage selector: #applicationMenuSelection: arguments: #() receiver: self class);
		yourself!

classesButtonLabel
	"Answer the label for the classes list."

	^ 'Classes'!

classesMenu

	"Answer the classes menu."

	| onlyOneApp onlyOneClass onlyOneLoadedClass atLeastOneClass
	 selectedApp userOwnsSelectedClasses |

	^self newMenu
		title: MxEMT127;  "$NLS$ ~Classes"
		subMenuSelector: #classesMenu;
		owner: self;
		configureBlock: [
			self managerInterface flushCache.
			onlyOneApp := self isOneApplicationSelected.
			onlyOneClass := self isOneClassSelected.
			onlyOneLoadedClass := onlyOneClass and: [self selectedClass isLoaded].
			atLeastOneClass := self isClassSelected.

			onlyOneApp & atLeastOneClass ifTrue: [
				selectedApp := self selectedApplication.
				self selectedClasses conform: [:cl |
					cl isLoaded and: [(self isClassHidden: cl) not and: [cl ~~ selectedApp]]].
				(self managerInterface isEdition: selectedApp) ifTrue: [
					userOwnsSelectedClasses := self managerInterface userOwns: self selectedClasses in: selectedApp.
					(self selectedClasses conform: [:cl | (self isClassHidden: cl) not]) ifTrue: [
						userOwnsSelectedClasses and: [
							(self selectedClasses includes: selectedApp) not]]]]];
		add: #findClass    label: MxEMT505    enable: [onlyOneApp];  "$NLS$ ~Find..."
		add: #hideShowClasses    label: MxEMT506    enable: [atLeastOneClass & self useHierarchy];  "$NLS$ E~xpand/Collapse"
		addLine;
		addSubMenu: #fileOutClassesSubMenu    label: MxEMT449    enable: true    for: self;  "$NLS$ File ~Out"
		addLine;
		addSubMenu: #browseRefsSubMenu    label: MxEMT509    enable: true    for: self;  "$NLS$ Browse ~References"
		addSubMenu: #localMessagesSubMenu    label: MxEMT510    enable: true    for: self;  "$NLS$ Browse ~Messages"
		add: #browseClass    label: MxEMT452    enable: [onlyOneClass];  "$NLS$ Browse ~Class"
		add: #browseHierarchy    label: MxEMT453    enable: [onlyOneLoadedClass];  "$NLS$ Browse Hierarch~y"
		selection: self class classMenuSelection;
		selectionUpdateMessage: (DirectedMessage selector: #classMenuSelection: arguments: #() receiver: self class);
		yourself!

classPrintBlock
	"Return the print block used to display a class's name."

	^ [ :cls | self printClass: cls ]!

findClassInApplication

	self halt.
super findClassInApplication!

hierarchicalListWidget: listSelector
	changeSelector: changeSelector
	menuSelector: menuSelector
	printBlock: printBlock
	statusBlock: statusBlock
	min: min
	max: max
	doubleClick: doubleSelectSelector
	initialSelection: initialSelection
	hasChildrenSelector: hasChildrenSelector
	childrenSelector: childrenSelector
	parentSelector: parentSelector
	showing: showing
	grayItem: grayItemSelector
	hierarchySelector: hierarchySelector

	"Private - Answer a new hierarchical list widget using the arguments."

	| listView edgeDecorator |
	listView := CoverageHierarchicalListView 
		on:  self
		printItems: false
		oneItem: false
		aspect: listSelector 
		change: changeSelector
		list: listSelector
		menu: menuSelector
		initialSelection: initialSelection
		useIndex: false
		max: -1
		min: 0
		hasChildrenSelector: hasChildrenSelector
		childrenSelector: childrenSelector
		parentSelector: parentSelector
		showing: showing
		doubleSelect: doubleSelectSelector
		doubleClick: doubleSelectSelector notNil
		grayItem: grayItemSelector
		hierarchySelector: hierarchySelector
		printBlock: printBlock.

	edgeDecorator := LookPreferences edgeDecorator on: listView.
	^edgeDecorator!

implementorsLocal

	"Browse the implementors of the selected method names
	 in the selected class' heirarchy."

	self localImplementorsOf: self selectedMethod!

implementorsSubMenu
	"Answer the menu for browsing the implementors of the selected method."

	| loadedMethodSelected |

	^ self newMenu
		configureBlock: [ loadedMethodSelected := self isOneMethodSelected and: [ self selectedMethod notNil and: [ self selectedMethod isLoaded ]]];
		add: #implementorsLocal label: 'local' enable: [ loadedMethodSelected ];
		add: #implementors label: 'all' enable: [ loadedMethodSelected ];
		yourself!

label
	"Return the title of the window."

	^ 'Coverage browser'!

messagesSubMenu
	"Answer the menu with the options to browse the messages of
	 the selected method."
	"Note: The 'self selectedMethod notNil' check is required to handle
	 the case if the selected method does not have an implementation in
	 the image. A method name is selected but not a method."


	| loadedMethodSelected |

	^ self newMenu
		configureBlock: [ loadedMethodSelected := self isOneMethodSelected and: [ self selectedMethod notNil and: [ self selectedMethod isLoaded ]]];
		add: #tracedMessageImplementors label: 'traced implementors...' enable: [ loadedMethodSelected and: [ self isCalledWrapper: self selectedMethod ]];
		addLine;
		add: #messageImplementors label: 'implementors...' enable: [ loadedMethodSelected ];
		add: #messageSenders label: 'senders...' enable: [ loadedMethodSelected ]!

methodButtonLabel
	"Answer the label for the selected method class."

	| class |

	^ self selectedMethod isNil
		ifTrue: [ '' ]
		ifFalse: [ class := self selectedMethod methodClass.
				 class name, '>>', (self protocolOf: self selectedMethod)]!

methodCoverageButtonLabel
	"Answer the label for the method coverage button."

	^ self showingMethodCoverage
			ifTrue: [ 'coverage' ]  "$NLS$ instance/class"
			ifFalse: [ 'activations']!

methodCoverageButtonSelected: button
	"Switch between method coverage and activations."

	self changeRequest ifFalse: [ ^ self ].
	self execShortOperation: [
		self 
			showingMethodCoverage: self showingMethodCoverage not;
			updateMethodCoverageButton;
			reactivateWindow ]!

methodPrintBlock
	"Return the print block used to display a method's selector."

	^ [ :cls | self printMethod: cls ]!

methodsButtonLabel
	"Answer the label for the methods list."

	^ 'Methods'!

methodsMenu

	"Answer the methods menu."

	| menu onlyOneClass classIsVisible onlyOneMethod atLeastOneMethod |
	(menu := self newMenu)
		title: '~Methods';
		subMenuSelector: #methodsMenu;
		owner: self;
		configureBlock: [
			onlyOneClass := self isOneClassSelected.
			classIsVisible := onlyOneClass and: [(self isClassHidden: self selectedClass) not].
			onlyOneMethod := self isOneMethodSelected.
			atLeastOneMethod := self isMethodSelected];
		add: #findMethod    label: FindMethod    enable: [classIsVisible].

	menu
		addLine;
		add: #fileOutSelectors    label: FileOutSelectors    enable: [atLeastOneMethod];
		addLine;
		addSubMenu: #sendersSubMenu    label: SendersSubMenu    enable: true    for: self;
		addSubMenu: #implementorsSubMenu    label: ImplementorsSubMenu    enable: true    for: self;
		addSubMenu: #messagesSubMenu    label: MessagesSubMenu    enable: true    for: self;
		add: #browseReferencedClasses		label: BrowseReferencedClasses		enable: [onlyOneMethod].

	^menu
		selection: self class methodMenuSelection;
		selectionUpdateMessage: (DirectedMessage selector: #methodMenuSelection: arguments: #() receiver: self class);
		yourself!

multiSelectionListWidget: listSelector
	changeSelector: changeSelector
	menuSelector: menuSelector
	printBlock: printBlock
	statusBlock: statusBlock
	min: min
	max: max
	doubleClick: doubleSelectSelector
	initialSelection: initialSelection

	"Private - Answer a new multiSelection list widget using the arguments."

	| listView edgeDecorator |

	listView := CoverageMultiSelectionListView 
		on:  self
		aspect: listSelector 
		change: changeSelector
		list: listSelector
		menu: menuSelector
	 	initialSelection: initialSelection
		printBlock: printBlock.

	listView
		max: max;
		min: min;
		doubleSelect: doubleSelectSelector;
		doubleClick: doubleSelectSelector notNil.

	edgeDecorator := LookPreferences edgeDecorator on: listView.
	^edgeDecorator!

protocolPrintBlock
	"Return the print block used to display a protocol."

	^ [ :prot | self printProtocol: prot ]!

protocolsButtonLabel
	"Answer the label for the protocols list."

	^ 'Protocols'!

protocolsMenu
	"Answer the menu for the protocols of the selected class."

	| atLeastOneProtocol |

	atLeastOneProtocol := self isProtocolSelected.

	^self newMenu 
		add: #fileOutProtocol		label: FileOutProtocol		enable: atLeastOneProtocol;
		add: #printOutProtocol		label: PrintOutProtocol		enable: atLeastOneProtocol;
		add: #browseProtocols		label: BrowseProtocol		enable: atLeastOneProtocol;
		selection: self class protocolMenuSelection;
		selectionUpdateMessage: (DirectedMessage selector: #protocolMenuSelection: arguments: #() receiver: self class);
		yourself!

reactivateWindow
	"Ensure each time the window is selected that the current visible applications are displayed."

	self execShortOperation: [
		self updateApplications: self selectedApplications restoreToTop: false;
			updateClassesSimply: self selectedClasses restoreToTop: false;
			updateProtocolsSimply: self selectedProtocols restoreToTop: false;
			updateMethods: self selectedMethods restoreToTop: false ]!

recomputeMethodsSelecting: selectIfPossible
	"Private - Recompute the methods.
	 Try to select the ones in selectIfPossible."

	| stillExist choices seen itsSelector index equal |

	self methods: self methodsForSelectedProtocols.
	stillExist := OrderedCollection new.

	(selectIfPossible notEmpty and: [self methods notEmpty]) ifTrue: [
		choices := self methods.
		seen := Set new.
		selectIfPossible do: [:cm |
			"this is essentially a reverseDetect:... when all implementations of a method
			 are displayed, they are ordered by superclass - but we want to select the one
			 understood by the actual class not the uppermost implementation.
			 When multiple implementations of the same method are selected, only one
			 remains selected."
			itsSelector := cm selector.
			index := self methods size + 1.
			[(index := index - 1) <= 0 or: [itsSelector = (equal := choices at: index) selector]]
				whileFalse: [].
			(index <= 0 or: [seen includes: index]) ifFalse: [
				seen add: index.
				stillExist add: equal]]].

	self selectedMethods: stillExist.
	self updateMethodButton!

recomputeProtocolsSelecting: selectIfPossible
	"Private - Recompute the protocols for the selected class
	 and its superclasses upto the specified inherited class.
	 Try to select the ones in selectIfPossible."

	| stillExist all allSorted privateProtocols |

	self protocols: #().
	stillExist := OrderedCollection new.
	all := Set new.
	self selectedClassesOrMetaClassesDo:
		 [ :cls | all addAll: cls methodCategories ].
	allSorted := all asSortedCollection.
	(privateProtocols := allSorted select: [ :each | '*private*' match: each ] )
		do: [ :each | allSorted remove: each ].
	self protocols: (allSorted asOrderedCollection addAllLast: privateProtocols; yourself ) asArray.
	selectIfPossible
		do: [ :p | (self protocols includes: p)
					ifTrue: [ stillExist add: p ]].
	self selectedProtocols: stillExist!

selectedMethod

	^ self selectedMethods size = 1
		ifTrue: [ self selectedMethods first ]
		ifFalse: [ nil ]!

sendersSubMenu
	"Answer the menu for browsing the senders of the selected methods."
	"Note: The 'self selectedMethod notNil' check is required to handle
	 the case if the selected method does not have an implementation in
	 the image. A method name is selected but not a method."


	| loadedMethodSelected |

	^ self newMenu
		configureBlock: [ loadedMethodSelected := self isOneMethodSelected and: [ self selectedMethod notNil and: [ self selectedMethod isLoaded ]]];
		add: #tracedSenders label: 'traced senders' enable: [ loadedMethodSelected ];
		addLine;
		add: #sendersLocal label: 'local senders' enable: [ loadedMethodSelected ];
		add: #senders label: 'senders' enable: [ loadedMethodSelected ];
		yourself!

sourceStringFor: method
	"Private - Return the source code for the method."

	^ (self isWrapper: method)
		ifTrue: [ self annotatedSourceStringFor: method ]
		ifFalse: [ super sourceStringFor: method ]!

text
	"Return the text to display in the text field."

	^ self sourceStringFor: self selectedMethod!

textMenu
	"Answer a Menu of operations on the source code that is to
	be displayed when the operate menu button is pressed."

	^ EtTools menuClass
		labelList: ParagraphEditor editGroupLabels, #(('do it' 'print it' inspect) (cancel) (format explain) (hardcopy))
		values: ParagraphEditor editGroupSelectors, #(doIt printIt inspectIt cancel format:from: explain:fromController: hardcopy)!

textWidget: textSelector
	menuSelector: menuSelector
	canChange: canChange
	wordWrap: shouldWrap
	horizontalScrollBar: useHorizontalScrollBar
	"Private - Answer a new text widget using the arguments."

	| textView edgeDecorator |
	textView :=
		(useHorizontalScrollBar ifTrue: [EtHorizontalScrollingTextView] ifFalse: [CoverageTextView])
			on: self
			aspect: textSelector
			change: (canChange ifTrue: [#acceptText:from:] ifFalse: [nil])
			menu: menuSelector
			initialSelection: nil.
	textView wordWrap: shouldWrap.

	edgeDecorator := LookPreferences edgeDecorator on: textView.
	useHorizontalScrollBar ifTrue: [
		edgeDecorator useHorizontalScrollBar].
	^edgeDecorator!

tracedMessageImplementors
	"Browse the implementors of one of the traced methods
	 invoked by the selected method."

	| methods methodName |

	self execShortOperation: [
		(methods := self selectedMethod tracedMethods) isEmpty
			ifTrue: [ System message: 'No methods traced' ]
			ifFalse: [ methodName := self prompt: 'Select method name' chooseFrom: methods keys asSortedCollection.
					 methodName notNil ifTrue: [ self browseTracedMethods: (methods at: methodName) selector: methodName implementors: true ]]]!

tracedSenders
	"Browse the traced methods invoking the selected method."

	| methods |

	self execShortOperation: [
		(methods := self tracedSendersOf: self selectedMethod) isEmpty
			ifTrue: [ System message: 'No methods traced' ]
			ifFalse: [ self browseTracedMethods: methods selector: self selectedMethod selector implementors: false ]]!

updateClasses: selectIfPossible restoreToTop: restoreToTop

	super updateClasses: selectIfPossible restoreToTop: restoreToTop.
	self classesSelected: selectIfPossible!

updateMethods: selectIfPossible restoreToTop: restoreToTop
	"Private - Update the methods and try to select the ones in
	 selectIfPossible. If none will be selected then restore the list to the
	 top or to its current position depending on the boolean restoreToTop."

	super updateMethods: selectIfPossible restoreToTop: restoreToTop.
	self updateMethodButton!

updateProtocols: selectIfPossible restoreToTop: restoreToTop

	self updateProtocolsSimply: selectIfPossible restoreToTop: restoreToTop.
	self protocolsSelected: selectIfPossible asOrderedCollection!

updateProtocolsSimply: selectIfPossible restoreToTop: restoreToTop

	super updateProtocols: selectIfPossible restoreToTop: restoreToTop! !

!CoverageApplicationBrowser methodsFor: 'private'!

activationsOfApplication: anApplication

	| activations |

	activations := 0.
	(self classesOf: anApplication) do:
		[ :cls | activations := activations + (self activationsOfClass: cls)].
	^ activations!

activationsOfClass: aBehavior

	| activations |

	activations := 0.
	(Array with: aBehavior with: aBehavior class) do:
		[ :cls | cls methodDictionary do:
					[ :cm | activations := activations + (self activationsOfMethod: cm)]].
	^ activations!

activationsOfClass: aBehavior protocol: protocol

	| activations |

	activations := 0.
	(self methodsOf: aBehavior classifiedUnder: protocol) do:
		[ :cm | activations := activations + (self activationsOfMethod: cm)].
	^ activations!

activationsOfMethod: aCompiledMethod

	^ (self isWrapper: aCompiledMethod)
		ifTrue: [ aCompiledMethod activations ]
		ifFalse: [ 0 ]!

activationsOfProtocol: protocol

	| activations |

	activations := 0.
	self selectedClassesOrMetaClassesDo:
		[ :cls | activations := activations + (self activationsOfClass: cls protocol: protocol)].
	^ activations!

classesOf: aSubApplication

	^ aSubApplication defined reject: [ :cls | cls inheritsFrom: SubApplication ]!

colorValue: percentage

	percentage = -1
		ifTrue: [ ^ ColorValue black ].
	percentage = 0
		ifTrue: [ ^ ColorValue navy ].
	percentage = 100
		ifTrue: [ ^ ColorValue darkGreen ].
	^ ColorValue red!

emphasisForCount: anInteger

	| treshold color |

	treshold := (maxActivations * 0.5) rounded.
	color := anInteger = 0
				ifTrue: [ #navy ]
				ifFalse: [ anInteger <= treshold
							ifTrue: [ #red ]
							ifFalse: [ #darkGreen ]].
	^ #color -> (ColorValue perform: color)!

methodsForSelectedProtocols

	| methods |

	methods := OrderedCollection new.
	self selectedClassesOrMetaClassesDo:
		[ :cls | self selectedProtocols
					do: [ :prot | methods addAll: (self methodsOf: cls classifiedUnder: prot)]].
	^ methods!

methodsOf: aBehavior classifiedUnder: heading

	^ (aBehavior methodNamesClassifiedUnder: heading)
		collect: [ :sel | aBehavior compiledMethodAt: sel ]!

percentageString: anInteger string: aString

	| stream |

	stream := WriteStream on: (String new: 6).
	stream nextPut: $[.
	anInteger printOn: stream.
	stream nextPutAll: '%]'; tab; nextPutAll: aString.
	^ stream contents!

printApplication: anApplication

	^ self showingMethodCoverage
		ifTrue: [ self printString: anApplication name statistics: (self tracedCallsOfApplication: anApplication)]
		ifFalse: [ self printString: anApplication name count: (self activationsOfApplication: anApplication) statistics: (self tracedCallsOfApplication: anApplication)]!

printClass: aBehavior

	^ self showingMethodCoverage
		ifTrue: [ self printString: aBehavior name statistics: (self tracedCallsOfClass: aBehavior)]
		ifFalse: [ self printString: aBehavior name count: (self activationsOfClass: aBehavior) statistics: (self tracedCallsOfClass: aBehavior)]!

printMethod: aCompiledMethod

	^ self showingMethodCoverage
		ifTrue: [ self printString: aCompiledMethod selector statistics: (self tracedCallsOfMethod: aCompiledMethod)]
		ifFalse: [ self printString: aCompiledMethod selector count: (self activationsOfMethod: aCompiledMethod) statistics: (self tracedCallsOfMethod: aCompiledMethod)]!

printProtocol: protocol

	^ self showingMethodCoverage
		ifTrue: [ self printString: protocol statistics: (self tracedCallsOfProtocol: protocol)]
		ifFalse: [ self printString: protocol count: (self activationsOfProtocol: protocol) statistics: (self tracedCallsOfProtocol: protocol)]!

printString: aString count: anInteger statistics: statistics

	| stream |

	statistics first = 0
		ifTrue: [ ^ aString asText emphasizeAllWith: #color -> (self colorValue: -1)].

	stream := WriteStream on: (String new: 128).
	stream nextPut: $[.
	anInteger printOn: stream.
	stream nextPut: $]; tab; nextPutAll: aString.
	^ stream contents asText emphasizeAllWith: #color -> (self colorValue: (statistics last / statistics first * 100) rounded)!

printString: aString statistics: statistics

	| percentage |

	^ statistics first = 0
		ifTrue: [ aString asText emphasizeAllWith: #color -> (self colorValue: -1)]
		ifFalse: [ percentage := (statistics last / statistics first * 100) rounded.
				 (self percentageString: percentage string: aString) asText emphasizeAllWith: #color -> (self colorValue: percentage)]!

protocolOf: aCompiledMethod

	| class |

	class := aCompiledMethod methodClass.
	^ class methodCategories detect: [ :cat | (self methodsOf: class classifiedUnder: cat) includes: aCompiledMethod ]!

tracedCallsOfApplication: anApplication

	| total called |

	total := called := 0.
	(self classesOf: anApplication) do:
		[ :cls | | tracedCalls |
			    tracedCalls := self tracedCallsOfClass: cls.
			    total := total + tracedCalls first.
			    called := called + tracedCalls last ].
	^ Array with: total with: called!

tracedCallsOfClass: aBehavior

	| traced called |

	traced := called := 0.
	(Array with: aBehavior with: aBehavior class) do:
		[ :cls | cls methodDictionary do:
					[ :cm | (self isWrapper: cm)
								ifTrue: [ traced := traced + 1.
										cm isCalled
											ifTrue: [ called := called + 1 ]]]].
	^ Array with: traced with: called!

tracedCallsOfClass: aBehavior protocol: protocol

	| traced called |

	traced := called := 0.
	(self methodsOf: aBehavior classifiedUnder: protocol) do:
		[ :cm | (self isWrapper: cm)
					ifTrue: [ traced := traced + 1.
							cm isCalled
								ifTrue: [ called := called + 1 ]]].
	^ Array with: traced with: called!

tracedCallsOfMethod: aCompiledMethod

	^ (self isWrapper: aCompiledMethod)
		ifTrue: [ aCompiledMethod isCalled
					ifTrue: [ Array with: aCompiledMethod totalExpressionCount with: aCompiledMethod tracedExpressionCount ]
					ifFalse: [ #(1 0)]]
		ifFalse: [ #(0 0)]!

tracedCallsOfProtocol: protocol

	| total called |

	total := called := 0.
	self selectedClassesOrMetaClassesDo:
		[ :cls | | tracedCalls |
			    tracedCalls := self tracedCallsOfClass: cls protocol: protocol.
			    total := total + (tracedCalls at: 1).
			    called := called + (tracedCalls at: 2)].
	^ Array with: total with: called!

wrapperClass

	^ CoverageMethodWrapper! !

!CoverageApplicationBrowser methodsFor: 'private-enumerating'!

selectedClassesOrMetaClassesDo: aBlock

	self selectedClasses
		do: [ :cls | aBlock value: (self showingInstanceMethods ifTrue: [ cls ] ifFalse: [ cls class ])]! !

!CoverageApplicationBrowser methodsFor: 'private-ET-Internal'!

browseTracedMethods: listOfCompiledMethod selector: aSymbol implementors: aBoolean
	"Open a browser on given list of methods."

	| label |

	label := (aBoolean ifTrue: [ 'Traced implementors of #%1' ] ifFalse: [ 'Traced senders of #%1' ]) bindWith: aSymbol.
	(CoverageMethodBrowser on: listOfCompiledMethod label: label) open!

changedSelectedClasses
	"Private - The selected classes have been changed, update the receiver."

	self exitMethodTemplateMode.
	self updateProtocols: #() restoreToTop: true!

changedSelectedMethods
	"Private - The selected methods have been changed, update the receiver."

	super changedSelectedMethods.
	self updateMethodButton!

classes: newClasses
	"Private - Set the classes visible in the receiver."

	classes := newClasses asSortedCollection: self classSortBlock!

classSortBlock
	"Private - Return the sort block for the receiver's classes."


	^ self showingMethodCoverage
		ifTrue: [ Class sortBlock ]
		ifFalse: [[ :x :y | (self activationsOfClass: x) > (self activationsOfClass: y)]]!

createWindow 
	"Initialize the browser by defining the type, behavior and relative size of each view. Answer the topView."

	| topView composite columnRatio heightRatio lineHeight lineHeightWithMenuBar |

	topView := self initializeBrowser.
	composite := topView component.
	columnRatio := 33/100.
	heightRatio := 50/100.
	lineHeight := self lineHeight.
	lineHeightWithMenuBar := self lineHeightWithMenuBar.
	composite add: self applicationsLabelWidget in:
		(LayoutFrame new
			leftFraction: 0;
			rightFraction: columnRatio;
			topFraction: 0;
			bottomFraction: 0 offset: lineHeight).
	composite add: self classesLabelWidget in:
		(LayoutFrame new
			leftFraction: columnRatio;
			rightFraction: 2 * columnRatio;
			topFraction: 0;
			bottomFraction: 0 offset: lineHeight).
	composite add: self protocolsLabelWidget in: 
		(LayoutFrame new
			leftFraction: 2 * columnRatio;
			rightFraction: 1;
			topFraction: 0;
			bottomFraction: 0 offset: lineHeight).
	composite add: self applicationsListWidget in:
		(LayoutFrame new
			leftFraction: 0;
			rightFraction: columnRatio;
			topFraction: 0 offset: lineHeight;
			bottomFraction: heightRatio).
	composite add: self classesListWidget in:
		(LayoutFrame new
			leftFraction: columnRatio;
			rightFraction: 2 * columnRatio;
			topFraction: 0 offset: lineHeight;
			bottomFraction: heightRatio).
	composite add: self protocolsListWidget in:
		(LayoutFrame new
			leftFraction: 2 * columnRatio;
			rightFraction: 1;
			topFraction: 0 offset: lineHeight;
			bottomFraction: heightRatio offset: lineHeightWithMenuBar negated).
	composite add: self methodInstanceButtonWidget in: 
		(LayoutFrame new
			leftFraction: 2 * columnRatio;
			rightFraction: 1;
			topFraction: heightRatio offset: lineHeightWithMenuBar negated;
			bottomFraction: heightRatio).
	composite add: self methodsLabelWidget in:
		(LayoutFrame new
			leftFraction: 0;
			rightFraction: columnRatio;
			topFraction: heightRatio;
			bottomFraction: heightRatio offset: lineHeightWithMenuBar).
	composite add: self methodsListWidget in:
		(LayoutFrame new
			leftFraction: 0;
			rightFraction: columnRatio;
			topFraction: heightRatio offset: lineHeightWithMenuBar;
			bottomFraction: 1 offset: lineHeightWithMenuBar negated).
	composite add: self methodCoverageButtonWidget in: 
		(LayoutFrame new
			leftFraction: 0;
			rightFraction: columnRatio;
			topFraction: 1 offset: lineHeightWithMenuBar negated;
			bottomFraction: 1).
	composite add: self methodLabelWidget in:
		(LayoutFrame new
			leftFraction: columnRatio;
			rightFraction: 1;
			topFraction: heightRatio;
			bottomFraction: heightRatio offset: lineHeightWithMenuBar).
	composite add: self textWidget in: 
		(LayoutFrame new
			leftFraction: columnRatio;
			rightFraction: 1;
			topFraction: heightRatio offset: lineHeightWithMenuBar;
			bottomFraction: 1).
	^ topView!

currentVisibleClasses
	"Private - Answer all the current visible classes for the receiver given
	 the current class visibility."

	| list |

	list := OrderedCollection new.
	self selectedApplications do:
		[ :appl | list addAll: (self classesOf: appl)].
	^ list!

initialize
	"Private - Initialize the receiver's instance variables
	 to their default values."

	self showingMethodCoverage: false.
	super initialize.
	self
		methods: #();
		selectedMethods: #();
		textSelector: #sourceString;
		informationSelector: #editionString;
		showingAllImplementations: self class showingAllImplementations;
		showingInstanceMethods: true!

localImplementorsOf: aCompiledMethod
	"Private - Browse the methods in the selected class' hierarchy
	 with same method selector."

	| implementors |
	self execShortOperation: [
		(implementors := aCompiledMethod methodClass allMethodsNamed: aCompiledMethod selector) isEmpty
			ifTrue: [
				System message: 
					( ( NlsCatEMT  residentMsg: 'MxEMT250' )   "$NLS$ No local methods are named #%1."
						bindWith: aCompiledMethod selector)
			]
			ifFalse: [
				((self browser: #methods)
					on: implementors
					labeled: 
						( ( NlsCatEMT  residentMsg: 'MxEMT251' )   "$NLS$ Implementors of #%1 local to %2"
							bindWith: aCompiledMethod selector
								with: aCompiledMethod methodClass name))
						open]]!

methodCoverageButtonWidget 

	"Private - Return a toggle button for switching between
	coverage and activations views."

	^self
		button: #methodCoverageButtonLabel
		bold: true
		selected: #methodCoverageButtonSelected:!

methodLabelWidget 
	"Private - Return a dynamic label for the method class."

	^self
		label: #methodButtonLabel
		bold: false!

methodsLabelWidget 
	"Private - Return a static label for methods."

	^self
		label: #methodsButtonLabel
		bold: false!

methodSortBlock
	"Private - Return the sort block for the receiver's methods."


	^ self showingMethodCoverage
		ifTrue: [ super methodSortBlock ]
		ifFalse: [[ :x :y | (self activationsOfMethod: x) > (self activationsOfMethod: y)]]!

protocols: newProtocols
	"Private - Set the protocols visible in the receiver."

	protocols := newProtocols asSortedCollection: self protocolSortBlock!

protocolsLabelWidget 
	"Private - Return a static label for protocols."

	^self
		label: #protocolsButtonLabel
		bold: false!

protocolSortBlock
	"Private - Return the sort block for the receiver's protocols."


	^ self showingMethodCoverage
		ifTrue: [[ :x :y | x < y ]]
		ifFalse: [[ :x :y | (self activationsOfProtocol: x) > (self activationsOfProtocol: y)]]!

selectClass: aClass
	"Private - Update the classes making aClass be the selected one."

	self updateClasses: (Array with: aClass) restoreToTop: true!

selectMethods: methodsToBeSelected clearRest: clearRest

	"Private - Select the methods after selecting their protocols.
	 If clearRest is true then only select the protocols and applications
	 (if appropriate) for the methodsToBeSelected, otherwise try to reselect
	 the currently selected ones."

	| toSelect |
	self methodProtocolsEnabled ifTrue: [
		toSelect := clearRest ifTrue: [Set new] ifFalse: [self selectedProtocols asSet].
		methodsToBeSelected do: [:cm |  
			toSelect add: (cm methodClass whichCategoryIncludesSelector: cm selector)].
		self updateProtocols: toSelect restoreToTop: true].
	self updateMethods: methodsToBeSelected restoreToTop: true!

showingMethodCoverage
	"Private - Return whether the receiver is showing method coverage."

	^ showingMethodCoverage!

showingMethodCoverage: aBoolean
	"Private - Set whether the receiver is showing method coverage."

	showingMethodCoverage := aBoolean!

tracedSendersOf: aCompiledMethod
	"Browse the traced methods invoking the selected method.
	Note: the allInstances call should be replaced by something more 'structured'."

	| methods |

	methods := OrderedCollection new.
	self wrapperClass allInstances do:
		[ :cm | cm tracedMethods do:
					[ :meths | (meths includes: aCompiledMethod)
								ifTrue: [ methods addLast: cm ]]].
	^ methods!

updateMethodButton
	"Private - Update the method button."

	self refreshWidget: #methodButtonLabel!

updateMethodCoverageButton
	"Private - Update the method coverage button."

	self refreshWidget: #methodCoverageButtonLabel! !

!CoverageApplicationBrowser methodsFor: 'private-testing'!

isCalledWrapper: aCompiledMethod

	^ (self isWrapper: aCompiledMethod) and: [ aCompiledMethod activations > 0 ]!

isWrapper: aCompiledMethod

	^ aCompiledMethod isKindOf: self wrapperClass! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CoverageApplicationBrowser class
	instanceVariableNames: ''!


CoverageApplicationBrowser subclass: #CoverageMethodBrowser
	instanceVariableNames: 'label '
	classVariableNames: ''
	poolDictionaries: 'NlsCatEMT LabelsForMenuOptions '
	category: 'Zork_Analysis'!

CoverageMethodBrowser comment: 'Comment:
	Instances of CoverageMethodBrowser display arbitrary lists of methods.'!


!CoverageMethodBrowser methodsFor: 'ET-Internal'!

label
	"Answer the window label."

	^ label!

reactivateWindow
	"Ensure each time the window is selected that the methods are refreshed."

	self execShortOperation: [
		self updateMethods: self selectedMethods restoreToTop: false ]! !

!CoverageMethodBrowser methodsFor: 'private'!

methodsForSelectedProtocols
	"Answer the fixed list of methods."

	^ self methods! !

!CoverageMethodBrowser methodsFor: 'private-ET-Internal'!

createWindow 
	"Initialize the browser by defining the type, behavior and relative size of each view. Answer the topView."

	| topView composite columnRatio lineHeightWithMenuBar |

	topView := self initializeBrowser.
	composite := topView component.
	columnRatio := 33/100.
	lineHeightWithMenuBar := self lineHeightWithMenuBar.
	composite add: self methodsLabelWidget in:
		(LayoutFrame new
			leftFraction: 0;
			rightFraction: columnRatio;
			topFraction: 0;
			bottomFraction: 0 offset: lineHeightWithMenuBar).
	composite add: self methodsListWidget in:
		(LayoutFrame new
			leftFraction: 0;
			rightFraction: columnRatio;
			topFraction: 0 offset: lineHeightWithMenuBar;
			bottomFraction: 1 offset: lineHeightWithMenuBar negated).
	composite add: self methodCoverageButtonWidget in: 
		(LayoutFrame new
			leftFraction: 0;
			rightFraction: columnRatio;
			topFraction: 1 offset: lineHeightWithMenuBar negated;
			bottomFraction: 1).
	composite add: self methodLabelWidget in:
		(LayoutFrame new
			leftFraction: columnRatio;
			rightFraction: 1;
			topFraction: 0;
			bottomFraction: 0 offset: lineHeightWithMenuBar).
	composite add: self textWidget in: 
		(LayoutFrame new
			leftFraction: columnRatio;
			rightFraction: 1;
			topFraction: 0 offset: lineHeightWithMenuBar;
			bottomFraction: 1).
	^ topView!

on: listOfCompiledMethod label: aString
	"Initialize the list of methods and the window label. Select the first method, if any."

	self methods: listOfCompiledMethod.
	self methods isEmpty
		ifFalse: [ self selectedMethods: (Array with: self methods first)].
	label := aString! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CoverageMethodBrowser class
	instanceVariableNames: ''!


!CoverageMethodBrowser class methodsFor: 'instance creation'!

on: listOfCompiledMethod label: aString
	"Answer a new browser on given list of compiled method, with windowlabel aString."

	^ self new on: listOfCompiledMethod label: aString! !

Application subclass: #Zork_Analysis
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Zork_Analysis'!


EtHierarchicalObjectsList subclass: #CoverageHierarchicalObjectsList
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Zork_Analysis'!

CoverageHierarchicalObjectsList comment: 'Comment:
	A subclass just to work with text instead of strings ...'!


!CoverageHierarchicalObjectsList methodsFor: 'private'!

basicTextAt: lineIndex
	"Compute the text at given index."

	| object level padding hierarchy text emphasis |

	object := lines at: lineIndex.
	level := model itemDepth: object.
	padding := level * self class padding.
	hierarchy := String new: padding.
	1 to: padding do: [ :i | hierarchy at: i put: $ ].
	text := printBlock isNil
				ifTrue: [ object isString
							ifTrue: [ object asText ]
							ifFalse: [ object printString asText ]]
				ifFalse: [ printBlock value: object ].
	emphasis := text emphasisAt: 1.
	text := (hierarchy, text string) asText.
	text emphasizeAllWith: emphasis.
	textLines at: lineIndex put: text.
	^ text!

textAt: lineIndex
	"Answer the text at line lineIndex."

	| text item emphasis |

	(text := textLines at: lineIndex) isNil 
		ifTrue: [ text := self basicTextAt: lineIndex ].
	item :=  lines at: lineIndex.
	((model hasChildren: item) and: [(model isShowing: item) not])
 		ifTrue: [ 	emphasis := text emphasisAt: 1.
				text := text, '...'.
				text emphasizeAllWith: emphasis ].
	^ text! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CoverageHierarchicalObjectsList class
	instanceVariableNames: ''!


TextView subclass: #CoverageTextView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Zork_Analysis'!

CoverageTextView comment: 'Comment:
	A subclass just to change the selection background color (also hard-coded ...) ...'!


!CoverageTextView methodsFor: 'visual properties'!

selectionBackgroundColor
	"Answer the receiver's selection background color."
	
	^ ColorValue veryLightGray! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CoverageTextView class
	instanceVariableNames: ''!


EtMultiSelectionListView subclass: #CoverageMultiSelectionListView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Zork_Analysis'!

CoverageMultiSelectionListView comment: 'Comment:
	A subclass just to change the selection background color (also hard-coded ...) ...'!


!CoverageMultiSelectionListView methodsFor: 'visual properties'!

selectionBackgroundColor
	"Answer the receiver's background color."

	^ ColorValue veryLightGray! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CoverageMultiSelectionListView class
	instanceVariableNames: ''!


EtHierarchicalListView subclass: #CoverageHierarchicalListView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Zork_Analysis'!

CoverageHierarchicalListView comment: 'Comment:
	A subclass just to change the selection background color (also hard-coded ...) and invoke some other print code ...'!


!CoverageHierarchicalListView methodsFor: 'private'!

initialize
	"Install appropriate print block and list." 
	 
	super initialize.
	showing := Set new.
	hierarchy := IdentityDictionary new.
	list := CoverageHierarchicalObjectsList onList: Array new.
	list 
		model: self;
		printBlock: [ :anObject | (anObject isKindOf: Text) ifTrue: [ anObject ] ifFalse: [ anObject printString asText ]].! !

!CoverageHierarchicalListView methodsFor: 'visual properties'!

selectionBackgroundColor
	"Answer the receiver's background color."

	^ ColorValue veryLightGray! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CoverageHierarchicalListView class
	instanceVariableNames: ''!


Object subclass: #WrapperTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Zork_Analysis'!

WrapperTest comment: 'Comment:
	This is a test class for method coverage analysis using the interpreter / method wrapper combination.

Usage:
	To use the system, execute: ''WrapperTest new installWrappers''. This will install method coverage wrappers on a list of methods (about 20000 in our case, cfr. #selectedMethodsDo:). Whenever a call is made to any of these wrapped methods, the interpreter will kick in and evaluate the parse tree (parse trees are generated on demand). Each method wrapper holds on to its own parse tree. The elements in the parse tree keep track of the number activations.

	Run the application to be analyzed and open the coverage browser at any time. If the application is interactive, the browser can be reactivated at any time; this will automatically update the statistics. The browsers retrieves its information directly from the method wrappers. De-installing the wrappers (send #uninstallWrappers to the wrapper test instance) will discard this information.

Example:

	| wrapper |

	wrapper := WrapperTest new.
	wrapper installWrappers.
	CoverageApplicationBrowser open. "no methods are marked as traced at this time"
	YourApplication start.
	....
	wrapper uninstallWrappers

Caveats:
	Apart from the obvious recursion problem (interpreting your own code), some things should currently be avoided:
		- primitives (in particular externals, since they require a dedicated parser)
		- thisContext (is currently not supported)
		- relying on a blockclosure''s #copiedValues.
	Other issues will most probably arise, but this is very early pre-alpha anyway ...'!


!WrapperTest methodsFor: 'actions'!

installWrappers
	"Install the coverage wrappers on the selected methods."

	self selectedMethodsDo: [ :sel :class | (self wrapperClass on: sel inClass: class) install ]!

uninstallWrappers
	"Uninstall all the coverage wrappers."

	self wrapperClass uninstallAllWrappers! !

!WrapperTest methodsFor: 'private'!

selectedClasses
	"Answer the classes we want to spy on. Currently these are most of our framework classes.
	If we want to spy on system Smalltalk classes, make sure to avoid kernel classes / methods since we do not want to get into infinite recursion. See the CoverageMethodWrapper class and AGExpression class hierarchy to know which class / method combinations to avoid."

	^ Object withAllSubclasses select: [ :cls | ('Fw*' match: cls name) or: [ 'MM*' match: cls name ]]!

selectorsOf: aClass
	"Answer the class's method selectors to spy on.
	Avoid primitives, since we can not step into these anyway. Gathering e.g. run-time type information of primitives can be handled by appropriate primitive method wrappers."

	^ aClass selectors select: [ :sel | (aClass compiledMethodAt: sel) primitiveNumber isNil ]! !

!WrapperTest methodsFor: 'private-enumerating'!

selectedMethodsDo: aBlock
	"Iterate over the class / method combinations we want are interested in."

	self selectedClasses do:
		[ :cls | (self selectorsOf: cls) do:
					[ :sel | aBlock value: sel value: cls ]]! !

!WrapperTest methodsFor: 'private-factory classes'!

wrapperClass
	"Answer the type of method wrapper we are interested in."

	^ CoverageMethodWrapper! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WrapperTest class
	instanceVariableNames: ''!