'From Squeak3.1alpha [latest update: #''Squeak3.1alpha'' of 12 April 2001 update 3892] on 14 April 2001 at 11:42:31 pm'!
"Change Set:		AccessorCodeGen
Date:			29 December 1999.  Revised for 3.x, 2001.04.14
Author:			Andrew P. Black

This changeset adds a menu item 'inst var accessors...' to the class list pane in the browser.
It brings up a control panel that shows which of the instance variables of the current
class have accessor methods ('readers' or 'writers').  It also distinguishes simple accessors
from those that do customized actions.
Simple accessors can be removed or added to the class just by clicking on the control panel"!

Object subclass: #AccessorInfo
	instanceVariableNames: 'class instanceVar readable writable '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
Object subclass: #AccessorPreferences
	instanceVariableNames: 'class accessTable rows '
	classVariableNames: 'Pallet '
	poolDictionaries: ''
	category: 'System-Support'!

!AccessorPreferences commentStamp: 'apb 4/14/2001 23:11' prior: 0!
I am the model for a control panel for the accessor methods of a class.
See also the comment in the openPanel method.
Example:
	(AccessorPreferences for: AccessorPreferences) openPanel

Instance Variables:
 accessTable		<Array> -- an array of AccessorInfos, one for each instance variable
 class			<Class> -- the class whose instance variables I represent
 rows			<Number> -- the number of rows in the display

Class variables:
 Pallet			<Array> -- an array of colors for the rows.
!


!AccessorInfo methodsFor: 'accessing' stamp: 'apb 12/24/1999 21:28'!
class: anObject
	"Set the receiver's instance variable class to anObject."

	class := anObject! !

!AccessorInfo methodsFor: 'accessing' stamp: 'apb 12/25/1999 00:39'!
instanceVar
	"Answer the receiver's instance variable instanceVar."

	^instanceVar! !

!AccessorInfo methodsFor: 'accessing' stamp: 'apb 12/24/1999 21:28'!
instanceVar: anObject
	"Set the receiver's instance variable instanceVar to anObject."

	instanceVar := anObject! !

!AccessorInfo methodsFor: 'accessing' stamp: 'apb 12/29/1999 12:06'!
readable
	"Answer the receiver's instance variable readable."

	^readable! !

!AccessorInfo methodsFor: 'accessing' stamp: 'apb 12/25/1999 00:32'!
writable
	"Answer the receiver's instance variable writable."

	^writable! !

!AccessorInfo methodsFor: 'responding' stamp: 'apb 12/24/1999 22:30'!
possiblyRemoveMethod: messageName 

	| confirmation |
	confirmation _ class confirmRemovalOf: messageName.
	confirmation == 3 ifTrue: [^ self].		"do nothing"
	class removeSelector: messageName.
	confirmation == 2 ifTrue: [Smalltalk browseAllCallsOn: messageName]! !

!AccessorInfo methodsFor: 'responding' stamp: 'apb 12/24/1999 22:21'!
readable: irrelevant setTo: anObject
	"Set the receiver's instance variable readable to anObject.
	This method exists to swallow the additional argument that 
	UpdatingBooleanStringMorph informTarget sends"

	anObject
		ifTrue:[ class makeReadable: instanceVar ]
		ifFalse:[ self possiblyRemoveMethod: instanceVar ].
	self refreshEntries.! !

!AccessorInfo methodsFor: 'responding' stamp: 'apb 12/24/1999 22:18'!
refreshEntries
	| readSelector writeSelector |
	readSelector _ instanceVar asSymbol.
	
 	(readable _ (class includesSelector: readSelector))
	ifTrue: [ (class isGeneratedReaderMethod: readSelector) ifFalse: [readable _ #custom]].

	writeSelector _ (instanceVar , ':') asSymbol.
	(writable _ (class includesSelector: writeSelector))
	ifTrue: [ (class isGeneratedWriterMethod: writeSelector) ifFalse: [writable _ #custom]].! !

!AccessorInfo methodsFor: 'responding' stamp: 'apb 12/24/1999 22:24'!
writable: irrelevant setTo: anObject
	"Set the receiver's instance variable writable to anObject.
	This method exists to swallow the additional argument that 
	UpdatingBooleanStringMorph informTarget sends"

	anObject
		ifTrue:[ class makeWritable: instanceVar withFormal: #anObject]
		ifFalse:[ self possiblyRemoveMethod: (instanceVar , ':') asSymbol ].
	self refreshEntries.! !


!AccessorPreferences methodsFor: 'initializing' stamp: 'apb 12/29/1999 11:09'!
initializeFor: aClass

	class _ aClass.
	accessTable _ class instVarNames collect: [:aVar | AccessorInfo for: aVar in: class].
	rows _ 0! !

!AccessorPreferences methodsFor: 'displaying' stamp: 'apb 12/29/1999 12:21'!
buildRowColor: c with: first with: second with: third 
	| width1 spacer width2 aRow wrapper |

	width1 _ 172.
	spacer _ 20.
	width2 _ 50.
	rows _ rows + 1.
	aRow _ AlignmentMorph newRow.
	aRow color: c.
	aRow addMorph: (wrapper _ Morph new color: c).
	wrapper extent: width1 @ 15.
	wrapper addMorph: first.
	aRow addMorphBack: (Morph new color: c;
		 extent: spacer @ 15).
	aRow addMorphBack: (wrapper _ Morph new color: c).
	wrapper extent: width2 @ 15.
	wrapper addMorphBack: second.
	aRow addMorphBack: (Morph new color: c;
		 extent: spacer @ 15).
	aRow addMorphBack: (wrapper _ Morph new color: c).
	wrapper extent: width2 @ 15.
	wrapper addMorphBack: third.
	^ aRow! !

!AccessorPreferences methodsFor: 'displaying' stamp: 'apb 4/14/2001 23:30'!
colorForRow: i 
	| p n |
	p _ self pallet.
	n _ p size.
	^ p at: (i rem: n) + 1! !

!AccessorPreferences methodsFor: 'displaying' stamp: 'apb 4/14/2001 21:57'!
initialExtent

	^ 330 @ ((rows min: 12) * 19 + 35)! !

!AccessorPreferences methodsFor: 'displaying' stamp: 'apb 4/14/2001 23:37'!
openPanel
	"Based on Preferences class openPreferencesControlPanel. apb 1999.12.23  
	Opens a window that displays one line for each instance variable in  
	the class  
	that I represent. That line contains  
	- the name of the instance var,  
	- true or false depending on whether there is a read accessor method  
	for that variable, and  
	- true or false depending on whether there is a write accessor method  
	for that variable.  
	Clicking on a 'true' or 'false' entry flips the value and 'makes it so'  
	Example: ((AccessorPreferences for: MessageNode) openPanel)"
	| aPanel aWindow wrapper w v m1 m2 title |
	title _ 'Accessor methods for ' , class name.
	Smalltalk verifyMorphicAvailability
		ifFalse: [^ self beep].
	aPanel _ AlignmentMorph newColumn.
	aPanel
		addMorphBack: (self
				buildRowColor: Color gray
				with: (StringMorph
						contents: 'Instance Variable'
						font: (TextStyle default fontAt: 1)
						emphasis: 1)
				with: (StringMorph
						contents: 'readable'
						font: (TextStyle default fontAt: 1)
						emphasis: 1)
				with: (StringMorph
						contents: 'writable'
						font: (TextStyle default fontAt: 1)
						emphasis: 1)).
	aPanel beSticky.
	(accessTable
		asSortedCollection: [:a :b | a instanceVar < b instanceVar])
		keysAndValuesDo: [:i :entry | 
			((v _ entry readable) isKindOf: Boolean)
				ifTrue: [m1 _ UpdatingBooleanStringMorph new.
					m1 contents: v printString.
					m1 getSelector: #readable;
						 putSelector: #readable:setTo:;
						 stepTime: 1800;
						 target: entry]
				ifFalse: [m1 _ StringMorph contents: v printString].
			((v _ entry writable) isKindOf: Boolean)
				ifTrue: [m2 _ UpdatingBooleanStringMorph new.
					m2 contents: v printString.
					m2 getSelector: #writable;
						 putSelector: #writable:setTo:;
						 stepTime: 1800;
						 target: entry]
				ifFalse: [m2 _ StringMorph contents: v printString].
			aPanel
				addMorphBack: (self
						buildRowColor: (self colorForRow: i)
						with: (StringMorph contents: entry instanceVar)
						with: m1
						with: m2)].
	wrapper _ ScrollPane new.
	wrapper scroller addMorph: aPanel.
	Smalltalk isMorphic
		ifTrue: [aWindow _ SystemWindow new model: self.
			aWindow
				addMorph: wrapper
				frame: (0 @ 0 extent: 1 @ 1).
			aWindow setLabel: title.
			aWindow openInWorld]
		ifFalse: [(w _ PasteUpMorph newWorldForProject: nil) addMorph: wrapper.
			wrapper retractable: false;
				 extent: self initialExtent + (wrapper scrollbarWidth @ 0).
			w startSteppingSubmorphsOf: wrapper.
			MorphWorldView openOn: w label: title]! !

!AccessorPreferences methodsFor: 'accessing' stamp: 'apb 12/23/1999 15:14'!
accessDictionary
	"Answer the receiver's instance variable accessDictionary."

	^accessDictionary! !

!AccessorPreferences methodsFor: 'accessing' stamp: 'apb 4/14/2001 23:35'!
pallet
	^ Pallet
		ifNil: [| shades | 
			shades _ Color green lightShades: 10.
			Pallet _ {shades at: 3. shades at: 4}]! !


!Browser methodsFor: 'class functions' stamp: 'apb 12/23/1999 23:37'!
buildAutoAccessors
	| c |
	(c _ self selectedClass) ifNil: [^ self].
	(AccessorPreferences for: c) openPanel! !

!Browser methodsFor: 'class functions' stamp: 'apb 4/14/2001 21:51'!
classListMenu: aMenu shifted: shifted
	"Set up the menu to apply to the receiver's class list, honoring the #shifted boolean"

	shifted
		ifTrue:
			[^ self shiftedClassListMenu: aMenu].
	aMenu addList: #(
		-
		('browse full (b)'			browseMethodFull)
		('browse hierarchy (h)'		spawnHierarchy)
		('browse protocol (p)'		browseFullProtocol)
		-
		('printOut'					printOutClass)
		('fileOut'					fileOutClass)
		-
		('show hierarchy'			hierarchy)
		('show definition'			editClass)
		('show comment'			editComment)
		-
		('inst var refs...'			browseInstVarRefs)
		('inst var defs...'			browseInstVarDefs)
		('inst var accessors...'		buildAutoAccessors)
		-
		('class var refs...'			browseClassVarRefs)
		('class vars'					browseClassVariables)
		('class refs (N)'				browseClassRefs)
		-
		('rename class ...'			renameClass)
		('copy class'				copyClass)
		('remove class (x)'			removeClass)
		-
		('find method...'				findMethod)
		-
		('more...'					offerShiftedClassListMenu)).
	^ aMenu! !


!Class methodsFor: 'method generation' stamp: 'apb 12/22/1999 20:20'!
for: aVariableName create: aPattern classified: aProtocol 
	"Substitute aVariableName into the string aPattern at every occurrence  
	of  '%1', and compile the resulting methods in the given protocol."

	self compile: (aPattern copyReplaceAll: '%1' with: aVariableName asString)
		classified: aProtocol asSymbol! !

!Class methodsFor: 'method generation' stamp: 'apb 12/22/1999 20:25'!
for: aVariableName named: aName create: aPattern classified: aProtocol 
	"Substitute aVariableName into the string aPattern at every occurrence   
	of  '%1', and aName into aPattern at every occurence of '%2',  
	and compile the resulting methods in the given protocol."

	self compile: ((aPattern copyReplaceAll: '%1' with: aVariableName asString)
			copyReplaceAll: '%2' with: aName asString)
		classified: aProtocol asSymbol! !

!Class methodsFor: 'method generation' stamp: 'apb 12/24/1999 21:24'!
isGeneratedReaderMethod: aMessageSelector
	| meth |
	meth _ self compiledMethodAt: aMessageSelector ifAbsent: [^ false].
	^ aMessageSelector numArgs = 0 and: 
			[(self standardReaderDecompileStringfor: aMessageSelector)
			= meth decompileString]! !

!Class methodsFor: 'method generation' stamp: 'apb 12/24/1999 21:25'!
isGeneratedWriterMethod: aMessageSelector 
	| meth |
	meth _ self compiledMethodAt: aMessageSelector ifAbsent: [^ false].
	^ aMessageSelector numArgs = 1 and: 
			[(self standardWriterDecompileStringfor: aMessageSelector allButLast)
			= meth decompileString]! !

!Class methodsFor: 'method generation' stamp: 'apb 12/23/1999 00:20'!
makeReadable: aVariableName
	"Make the instanceVariable named aVariableName readable via a messsage."

	(self includesSelector: aVariableName)
		ifFalse: [self
				for: aVariableName
				create: '%1\	"Answer the receiver''s instance variable %1."\\	^%1' withCRs
				classified: #accessing]! !

!Class methodsFor: 'method generation' stamp: 'apb 12/23/1999 00:41'!
makeWritable: aVariableName withFormal: aParameterName 
	"Make the instanceVariable named aVariableName readable via a messsage."

	(self includesSelector: (aVariableName, ':') asSymbol)
		ifFalse: [self
				for: aVariableName
				named: aParameterName
				create: '%1: %2\	"Set the receiver''s instance variable %1 to %2."\\	%1 := %2' withCRs
				classified: #accessing]! !

!Class methodsFor: 'method generation' stamp: 'apb 12/24/1999 21:06'!
standardReaderDecompileStringfor: aVariableName
	"The decompileString that should be returned from the compiledMethod 
	generated by makeReadable: aVariableName"

	"Test:  the following should eveluateto true:
	 (Association standardReaderDecompileStringfor: #value) = 
	 ((Association compiledMethodAt: #value) decompileString)"

	^ '%1
	^ %1' copyReplaceAll: '%1' with: aVariableName asString! !

!Class methodsFor: 'method generation' stamp: 'apb 12/29/1999 11:44'!
standardWriterDecompileStringfor: aVariableName
	"The decompileString that should be returned from the compiledMethod 
	generated by makeWritable: aVariableName withFormal: t1"

	"Test:  the following should eveluate to true:
	 (Association standardWriterDecompileStringfor: #value) = 
	 ((Association compiledMethodAt: #value:) decompileString)"

	^ '%1: t1 
	%1 _ t1' copyReplaceAll: '%1' with: aVariableName asString! !


!AccessorInfo class methodsFor: 'instance creation' stamp: 'apb 12/24/1999 22:34'!
for: anInstanceVariable in: aClass
	| t |
	t _ super new.
	t class: aClass; instanceVar: anInstanceVariable asSymbol.
	t refreshEntries.
	^ t! !


!AccessorPreferences class methodsFor: 'instance creation' stamp: 'apb 12/29/1999 11:08'!
for: aClass

	| ap |	
	ap _ super new.
	ap initializeFor: aClass.
	^ ap
! !

MessageNode removeSelector: #equalNode!

!AccessorPreferences class reorganize!
('instance creation' for:)
!


!AccessorInfo class reorganize!
('instance creation' for:in:)
!


!Class reorganize!
('initialize-release' declare: obsolete removeFromSystem removeFromSystem: removeFromSystemUnlogged sharing: superclass:methodDict:format:name:organization:instVarNames:classPool:sharedPools: superclass:methodDictionary:format:)
('accessing' classPool name)
('testing' hasMethods isObsolete isSystemDefined officialClass)
('copying' copy)
('class name' externalName nameForViewer rename: uniqueNameForReference)
('instance variables' addInstVarName: removeInstVarName:)
('class variables' addClassVarName: allClassVarNames classVarNames ensureClassPool initialize removeClassVarName:)
('pool variables' addSharedPool: allSharedPools removeSharedPool: sharedPools)
('compiling' canFindWithoutEnvironment: compileAll compileAllFrom: possibleVariablesFor:continuedFrom: scopeHas:ifTrue:)
('subclass creation' newSubclass subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: variableByteSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: variableSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: variableWordSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: weakSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:)
('fileIn/Out' fileOut fileOutAsHtml: fileOutInitializerOn: fileOutOn:moveSource:toFile: fileOutOn:moveSource:toFile:initializing: fileOutPool:onFileStream: fileOutSharedPoolsOn: objectForDataStream: reformatAll removeFromChanges shouldFileOutPool: shouldFileOutPools storeDataOn:)
('accessing class hierarchy' addSubclass: removeSubclass: subclasses subclassesDo: subclassesDoGently:)
('private' setName:)
('method generation' for:create:classified: for:named:create:classified: isGeneratedReaderMethod: isGeneratedWriterMethod: makeReadable: makeWritable:withFormal: standardReaderDecompileStringfor: standardWriterDecompileStringfor:)
('organization' environment environment:)
!

!AccessorPreferences reorganize!
('initializing' initializeFor:)
('displaying' buildRowColor:with:with:with: colorForRow: initialExtent openPanel)
('accessing' accessDictionary pallet)
!


!AccessorInfo reorganize!
('initializing')
('accessing' class: instanceVar instanceVar: readable writable)
('responding' possiblyRemoveMethod: readable:setTo: refreshEntries writable:setTo:)
!