Pharo Cocoa Bridgesupport Class Spec Creator

cocoa-class-spec-creator.st

"
 Cocoa Framework Class Specification Loader
 ------------------------------------------
 If you execute all of the following script
 (highlight and select 'doIt'), it will
 create several classes based on the input XML.
 These are not Cocoa class proxies, but rather
 classes whose instances can eventually be used
 to create such proxy classes -- we hope!
 
 NOTE: You need to install XMLParser from the
 Pharo catalog to get this to work!

 ALSO NOTE: I'm using a hard-coded path to the Foundation
 framework here. You can change as you wish.
"
path := '/System/Library/Frameworks/Foundation.framework/Resources/BridgeSupport/Foundation.bridgesupport' asFileReference.
doc := XMLDOMParser parse: path.

"Helpers"
getChildren := [ :el |
	el elements select: [ :desc |
		desc parent = el ] ].
getChildNames := [ :el |
	(getChildren value: el) collect: [ :childEl |
		childEl name ] ].

camelCaseName := [ :name |
	| tmp |
	tmp := name copy.
	tmp := tmp replaceAll: $_ with: $ .
	tmp := tmp asCamelCase.
	tmp
		at: 1
		put: (tmp at: 1) lowercase.
	tmp ].

"Part Elements"
classElements := doc root allElementsSelect: [ :el | el name = 'class' ].
retvalElements := doc root allElementsSelect: [ :el | el name = 'retval' ].
methodElements := doc root allElementsSelect: [ :el | el name = 'method' ].
argElements := doc root allElementsSelect: [ :el | el name = 'arg' ].

"Class element info"
classAttributeNames := Set new.
classChildNames := Set new.
classElements do: [ :el |
	| children |
	classAttributeNames addAll: (el attributes keys collect: [ :key | 
		('_' join: (key splitOn: ' ')) ])..
	children := el elements do: [ :descElement |
		descElement parent = el ].
	classChildNames addAll: (children collect: [ :child | child name ]) ].
classAttributesAsSelectors := classAttributeNames collect: camelCaseName.

"Method element info"
methodAttributeNames := Set new.
methodChildNames := Set new.
methodElements do: [ :el |
	methodAttributeNames addAll: (el attributes keys collect: [ :key | 
		('_' join: (key splitOn: ' ')) ])..
	methodChildNames addAll: (getChildNames value: el) ].

"Arg element info"
argAttributeNames := Set new.
argChildNames := Set new.
argElements do: [ :el |
	argAttributeNames addAll: (el attributes keys collect: [ :key | 
		('_' join: (key splitOn: ' ')) ]).
	argChildNames addAll: (getChildNames value: el) ].

"Retval element info"
retvalAttributeNames := Set new.
retvalChildNames := Set new.
retvalElements do: [ :el |
	retvalAttributeNames addAll: (el attributes keys collect: [ :key | 
		('_' join: (key splitOn: ' ')) ])..
	retvalChildNames addAll: (getChildNames value: el) ].

"Misc"
retvalsWithChildren := retvalElements select: [ :el | el hasChildren ].
retvalsWithChildren size.

"Create spec classes for each thing"
addAttrSelectorsForClass := [ :classObj :attributeNames |
	attributeNames do: [ :name |
		| selectorName |
		selectorName := camelCaseName value: name.
		classObj compile: (String streamContents: [ :s |
			 s
				nextPutAll: selectorName;
				nextPutAll: String cr;
				nextPut: Character tab;
				nextPutAll: '^ ';
				nextPutAll: name ]).
		classObj compile: (String streamContents: [ :s | 
			 s
				nextPutAll: selectorName;
				nextPut: $:;
				nextPut: $ ;
				nextPut: $a;
				nextPutAll: (selectorName asCamelCase);
				nextPutAll: String cr;
				nextPut: Character tab;
				nextPutAll: name;
				nextPutAll: ' := ';
				nextPut: $a;
				nextPutAll: (selectorName asCamelCase)]). ] ].
	
createSpecClass := [ :name :attributeNames :childNames |
	| attrSelectors childPluralNames className ivarNames createdClass |
	attrSelectors := attributeNames collect: camelCaseName.
	childPluralNames := childNames collect: [ :childName | 
		(childName,'s') ].
	ivarNames := (' ' join: attributeNames), ' ', (' ' join: childPluralNames).
	className := ('CFW',(name asCamelCase),'Spec').
	createdClass := Object
							subclass: className
							instanceVariableNames: ivarNames
							classVariableNames: ''
							package: 'Cocoa-Frameworks'.
	createdClass ].

addInitMethodWithChildren := [ :classObj :childNames |
	| initSubString |
	initSubString := (String cr) join: (childNames collect: [ :childName | 
		(String streamContents: [ :s | 
			s
				nextPut: Character tab;
				nextPutAll: (childName,'s');
				nextPutAll: ' := OrderedCollection new.']).
			]).
	classObj compile: (String streamContents: [ :s | 
		s
			nextPutAll: 'initialize';
			nextPutAll: String cr;
			nextPut: Character tab;
			nextPutAll: 'super initialize.';
			nextPutAll: String cr;
			nextPutAll: initSubString
		]).
].

addChildrenForClass := [ :classObj :childNames |
	"First, we should create an initialize method
	 so that we can set any child inst vars to be
	 ordered collections"
	childNames do: [ :childName | 
		| childPluralName |
		childPluralName := (childName,'s').
		addInitMethodWithChild value: classObj value: childPluralName.
		"Add accessors"
		classObj compile: (String streamContents: [ :s |
			s
				nextPutAll: childPluralName;
				nextPutAll: String cr;
				nextPut: Character cr;
				nextPut: $^;
				nextPut: $ ;
				nextPutAll: childPluralName ]).
		classObj compile: (String streamContents: [ :s | 
			s
				nextPutAll: childPluralName;
				nextPut: $:;
				nextPut: $ ;
				nextPutAll: 'anOrderedCollection';
				nextPutAll: String cr;
				nextPut: Character tab;
				nextPutAll: childPluralName;
				nextPutAll: ' := anOrderedCollection.']). 
	]
].

"
Create the classes
-------------------
We use the two blocks defined above to:
1) Create each class with appropriate instance vars
2) Add Pharo accessor methods for those variables
"

"Args"
argClass := createSpecClass valueWithArguments: { 'arg'. argAttributeNames. argChildNames }.
addAttrSelectorsForClass value: argClass value: argAttributeNames.
addChildrenForClass value: argClass value: argChildNames.
addInitMethodWithChildren value: argClass value: argChildNames.

"Methods"
methodClass := createSpecClass valueWithArguments: { 'method'. methodAttributeNames. methodChildNames }.
addAttrSelectorsForClass value: methodClass value: methodAttributeNames.
addChildrenForClass value: methodClass value: methodChildNames.
addInitMethodWithChildren value: methodClass value: methodChildNames.

"Retvals"
retvalClass := createSpecClass valueWithArguments: { 'retval'. retvalAttributeNames. retvalChildNames }.
addAttrSelectorsForClass value: retvalClass value: retvalAttributeNames.
addChildrenForClass value: retvalClass value: retvalChildNames.
addInitMethodWithChildren value: retvalClass value: retvalChildNames.

"Classes"
classClass := createSpecClass valueWithArguments: { 'class'. classAttributeNames. classChildNames }.
addAttrSelectorsForClass value: classClass value: classAttributeNames.
addChildrenForClass value: classClass value: classChildNames.
addInitMethodWithChildren value: classClass value: classChildNames.