This is an experimental goodie that allows metadata to be associated with
individual methods.  It's modelled loosely after VisualWorks pragma
declarations, but doesn't (for now) modify the parser.  Instead,
annotations are added by sending #asAnnotation to an array literal
somewhere in the body of the method.

For example, you might add a method to Browser to generate instance
variable accessors, and wish it to show up in the class list menu.  If the
Browser was annotation-aware, you might do this:

generateAccessors
  #(menuItem: 'generate accessors' menu: #classList) asAnnotation.
  ".... the rest of the method ..."

If this was part of the refactoring browser package, you might mark that
with an annotation as well:

generateAccessors
  #(package: 'Refactory') asAnnotation.
  #(menuItem: 'generate accessors' menu: #classList) asAnnotation.
  ".... the rest of the method ..."

CompiledMethod>>annotations will return a collection of Message objects -
in the above example, there would be two, with selector #package: and
args #('Refactory'), and selector #menuItem:menu: with args #('generate
accessors' #classList).

Behavior>>methodAnnotations will return a collection of associations from
MethodReference to Message for any annotated methods;
#allMethodAnnotations will return the annotations for any superclasses as
well.

If this is at all well received, I intend to enhance PackageInfo to honor
#package: annotations, and to begin to experiment with using annotations
to build dynamic menus.  I'm also curious how they could be used to
provide hints for MorphicWrappers/NakedObjects-like UIs.

This package is also available from
http://beta4.com/squeak/Annotations-ab.3.mcz

Comments?

Avi
-------------- next part --------------
SystemOrganization addCategory: #'Annotations-Tests'!
SystemOrganization addCategory: #'Annotations-Support'!


AbstractInstructionPrinter subclass: #AnnotationLocator
	instanceVariableNames: 'annotations lastLiteral '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Annotations-Support'!

TestCase subclass: #AnnotationTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Annotations-Tests'!

Object subclass: #MockAnnotatedClass
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Annotations-Tests'!

MockAnnotatedClass subclass: #MockAnnotatedSubclass
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Annotations-Tests'!

AnnotationLocator class
	instanceVariableNames: ''!

AnnotationTest class
	instanceVariableNames: ''!

MockAnnotatedClass class
	instanceVariableNames: ''!

MockAnnotatedSubclass class
	instanceVariableNames: ''!


!AnnotationLocator methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 02:17'!
addAnnotation: anArray
	annotations ifNil: [annotations _ OrderedCollection new].
	annotations add: (self messageFromArray: anArray)! !

!Behavior methodsFor: '*annotations' stamp: 'ab 8/20/2003 12:21'!
allMethodAnnotations
	| superAnnotations annotations selectors |
	superclass ifNil: [^ self methodAnnotations].
	superAnnotations _ superclass allMethodAnnotations.
	annotations _ self methodAnnotations.
	selectors _ (annotations collect: [:ea | ea value methodSymbol]) asSet.
	
	^ annotations, (superAnnotations reject:
							[:ea | selectors includes: ea value methodSymbol])! !

!AnnotationLocator class methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 02:22'!
annotationSelector
	^ #asAnnotation! !

!AnnotationLocator methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 02:17'!
annotations
	^ annotations ifNil: [#()]! !

!CompiledMethod methodsFor: '*annotations' stamp: 'ab 8/20/2003 02:01'!
annotations
	| scanner end locator |
	(self hasLiteral: AnnotationLocator annotationSelector) ifFalse: [^ #()].
	
	scanner _ InstructionStream on: self.
	locator _ AnnotationLocator new.
	end _ self endPC.

	[scanner pc <= end] whileTrue: [
		(locator interpretNextInstructionUsing: scanner).
	].
	^locator annotations! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 12:07'!
annotations: aCollection includes: annotationSymbol inMethod: selectorSymbol of: aClass
	^ aCollection anySatisfy:
		[:assoc |
		assoc key selector = annotationSymbol
			and: [assoc value methodSymbol = selectorSymbol]
			and: [assoc value actualClass = aClass]]! !

!Array methodsFor: '*annotations' stamp: 'ab 8/20/2003 02:24'!
asAnnotation! !

!MockAnnotatedClass methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:31'!
bar
	#(testPackage: 'bar') asAnnotation.! !

!AnnotationLocator methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:39'!
convertArgument: literalObject
	#(true false nil) with: {true. false. nil} do:
		[:symbol :obj |
		symbol == literalObject ifTrue: [^ obj]].
	^ literalObject! !

!MockAnnotatedClass methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:31'!
foo
	#(menuItem: 'Foo' menu: #basic) asAnnotation.
	^ 42! !

!MockAnnotatedSubclass methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:31'!
foo
	#(menuItem: 'Foo' menu: #basic) asAnnotation.
	^ 23! !

!CompiledMethod methodsFor: '*annotations' stamp: 'ab 8/20/2003 01:39'!
hasAnnotations
	^ self annotations isEmpty not! !

!AnnotationLocator methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:35'!
messageFromArray: anArray
	| selector arguments |
	selector _ String new writeStream.
	arguments _ Array new writeStream.
	anArray pairsDo:
		[:s :a |
		selector nextPutAll: s.
		arguments nextPut: (self convertArgument: a)].
	^ Message
		selector: selector contents asSymbol
		arguments: arguments contents! !

!Behavior methodsFor: '*annotations' stamp: 'ab 8/20/2003 15:18'!
methodAnnotations
	| annotations |
	annotations _ OrderedCollection new.
	methodDict keysAndValuesDo: 
		[:selector :method |
		method annotations do:
			[:annotation |
			annotations add:
				annotation -> (MethodReference new setStandardClass: self methodSymbol: selector)]].
	^ annotations! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 02:23'!
methodReferencingAnnotationSelector 
	^ #asAnnotation! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:34'!
methodWithBooleanAnnotation
	#(with: nil with: true with: false with: 'nil') asAnnotation.
	^ 42! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:21'!
methodWithMenuAnnotation
	#(testMenuItem: 'Do Stuff' enable: #always menu: #myMenu) asAnnotation.
	self doLotsOfStuff.! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:07'!
methodWithMultipleAnnotations
	#(testPackage: 'foo') asAnnotation.
	#(testOn: mouseDown) asAnnotation.
	^ 23! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:07'!
methodWithPackageAnnotation
	#(testPackage: 'foo') asAnnotation.
	^ 23! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 01:53'!
methodWithoutAnnotations
	^ 42! !

!AnnotationLocator methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 01:37'!
pushConstant: anObject
	lastLiteral _ anObject! !

!AnnotationLocator methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 02:01'!
send: selector super: supered numArgs: numberArguments
	selector = self class annotationSelector ifTrue: [self addAnnotation: lastLiteral].! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 12:12'!
testAllMethodAnnotations
	| superAnnotations subAnnotations |
	superAnnotations _ MockAnnotatedClass allMethodAnnotations.
	subAnnotations _ MockAnnotatedSubclass allMethodAnnotations.
	self assert: (self annotations: superAnnotations includes: #menuItem:menu: inMethod: #foo of: MockAnnotatedClass).
	self assert: (self annotations: superAnnotations includes: #testPackage: inMethod: #bar of: MockAnnotatedClass).
	self assert: (self annotations: subAnnotations includes: #menuItem:menu: inMethod: #foo of: MockAnnotatedSubclass).
	self deny:  (self annotations: subAnnotations includes: #menuItem:menu: inMethod: #foo of: MockAnnotatedClass).
	self assert: (self annotations: subAnnotations includes: #testPackage: inMethod: #bar of: MockAnnotatedClass).
! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:34'!
testBooleanAnnotations
	| a |
	a _ (self class compiledMethodAt: #methodWithBooleanAnnotation) annotations first.
	self assert: a arguments = (Array with: nil with: true with: false with: 'nil').! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 02:23'!
testHasAnnotations
	self assert: (self class compiledMethodAt: #methodWithPackageAnnotation) hasAnnotations.
	#(methodWithoutAnnotations methodReferencingAnnotationSelector ) do:
		[:sel | self deny: (self class compiledMethodAt: sel) hasAnnotations].! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 02:02'!
testInvokeAnnotatedMethod
	self assert: (self methodWithPackageAnnotation) = 23.! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:07'!
testMenuAnnotation
	| a |
	a _ (self class compiledMethodAt: #methodWithMenuAnnotation) annotations first.
	self assert: a selector = #testMenuItem:enable:menu:.
	self assert: a arguments first = 'Do Stuff'.! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 12:12'!
testMethodAnnotations
	| superAnnotations subAnnotations |
	superAnnotations _ MockAnnotatedClass methodAnnotations.
	subAnnotations _ MockAnnotatedSubclass methodAnnotations.
	self assert: (self annotations: superAnnotations includes: #menuItem:menu: inMethod: #foo of: MockAnnotatedClass).
	self assert: (self annotations: superAnnotations includes: #testPackage: inMethod: #bar of: MockAnnotatedClass).
	self assert: (self annotations: subAnnotations includes: #menuItem:menu: inMethod: #foo of: MockAnnotatedSubclass).
	self deny:  (self annotations: subAnnotations includes: #menuItem:menu: inMethod: #foo of: MockAnnotatedClass).
	self deny: (self annotations: subAnnotations includes: #testPackage: inMethod: #bar of: MockAnnotatedClass).
! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:07'!
testMultipleAnnotations
	| a |
	a _ (self class compiledMethodAt: #methodWithMultipleAnnotations) annotations.
	self assert: a size = 2.
	self assert: a first selector = #testPackage:.
	self assert: a second selector = #testOn:.
! !

!AnnotationTest methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 11:06'!
testPackageAnnotation
	| a |
	a _ (self class compiledMethodAt: #methodWithPackageAnnotation) annotations first.
	self assert: a selector = #testPackage:.
	self assert: a argument = 'foo'.! !