Merge branch 'pluggable-exporters-with-new-loaders' into requirejs-wip

Conflicts:
js/Importer-Exporter.deploy.js
js/Importer-Exporter.js
st/Importer-Exporter.st

st/Importer-Exporter.st

@@ -1,4 +1,157 @@
 Smalltalk current createPackage: 'Importer-Exporter'!
+Object subclass: #ChunkExporter
+	instanceVariableNames: ''
+	package: 'Importer-Exporter'!
+!ChunkExporter commentStamp!
+I am an exporter dedicated to outputting Amber source code in the classic Smalltalk chunk format.
+
+I do not output any compiled code.!
+
+!ChunkExporter class methodsFor: 'exporting-accessing'!
+
+extensionCategoriesOfPackage: package
+	"Issue #143: sort protocol alphabetically"
+
+	| name map result |
+	name := package name.
+	result := OrderedCollection new.
+	(Package sortedClasses: Smalltalk current classes) do: [:each |
+		{each. each class} do: [:aClass |
+			map := Dictionary new.
+			aClass protocolsDo: [:category :methods |
+				(category match: '^\*', name) ifTrue: [ map at: category put: methods ]].
+			result addAll: ((map keys sorted: [:a :b | a <= b ]) collect: [:category |
+				#{ 'methods'->(map at: category). 'name'->category. 'class'->aClass}]) ]].
+	^result
+!
+
+methodsOfCategory: category
+	"Issue #143: sort methods alphabetically"
+
+	^(category at: #methods) sorted: [:a :b | a selector <= b selector]
+!
+
+ownCategoriesOfClass: aClass
+	"Issue #143: sort protocol alphabetically"
+
+	| map |
+	map := Dictionary new.
+	aClass protocolsDo: [:category :methods |
+		(category match: '^\*') ifFalse: [ map at: category put: methods ]].
+	^(map keys sorted: [:a :b | a <= b ]) collect: [:category |
+		#{
+			'methods'->(map at: category).
+			'name'->category.
+			'class'->aClass }]
+!
+
+ownCategoriesOfMetaClass: aClass
+	"Issue #143: sort protocol alphabetically"
+
+	^self ownCategoriesOfClass: aClass class
+! !
+
+!ChunkExporter class methodsFor: 'exporting-output'!
+
+exportCategoryEpilogueOf: category on: aStream
+	aStream nextPutAll: ' !!'; lf; lf
+!
+
+exportCategoryPrologueOf: category on: aStream
+	aStream
+		nextPutAll: '!!', (self classNameFor: (category at: #class));
+		nextPutAll: ' methodsFor: ''', (category at: #name), '''!!'
+!
+
+exportDefinitionOf: aClass on: aStream
+	"Chunk format."
+
+	aStream
+		nextPutAll: (self classNameFor: aClass superclass);
+		nextPutAll: ' subclass: #', (self classNameFor: aClass); lf;
+		tab; nextPutAll: 'instanceVariableNames: '''.
+	aClass instanceVariableNames
+		do: [:each | aStream nextPutAll: each]
+		separatedBy: [aStream nextPutAll: ' '].
+	aStream
+		nextPutAll: ''''; lf;
+		tab; nextPutAll: 'package: ''', aClass category, '''!!'; lf.
+	aClass comment notEmpty ifTrue: [
+		aStream
+		nextPutAll: '!!', (self classNameFor: aClass), ' commentStamp!!';lf;
+		nextPutAll: (self chunkEscape: aClass comment), '!!';lf].
+	aStream lf
+!
+
+exportMetaDefinitionOf: aClass on: aStream
+
+	aClass class instanceVariableNames isEmpty ifFalse: [
+		aStream
+			nextPutAll: (self classNameFor: aClass class);
+			nextPutAll: ' instanceVariableNames: '''.
+		aClass class instanceVariableNames
+			do: [:each | aStream nextPutAll: each]
+			separatedBy: [aStream nextPutAll: ' '].
+		aStream
+			nextPutAll: '''!!'; lf; lf]
+!
+
+exportMethod: aMethod on: aStream
+	aStream
+		lf; lf; nextPutAll: (self chunkEscape: aMethod source); lf;
+		nextPutAll: '!!'
+!
+
+exportPackageDefinitionOf: package on: aStream
+	"Chunk format."
+
+	aStream
+		nextPutAll: 'Smalltalk current createPackage: ''', package name, '''!!';
+		lf
+! !
+
+!ChunkExporter class methodsFor: 'fileOut'!
+
+recipe
+	"Export a given package."
+
+	| exportCategoryRecipe |
+	exportCategoryRecipe := {
+		self -> #exportCategoryPrologueOf:on:.
+		{
+			self -> #methodsOfCategory:.
+			self -> #exportMethod:on: }.
+		self -> #exportCategoryEpilogueOf:on: }.
+
+	^{
+		self -> #exportPackageDefinitionOf:on:.
+		{
+			PluggableExporter -> #ownClassesOfPackage:.
+			self -> #exportDefinitionOf:on:.
+			{ self -> #ownCategoriesOfClass: }, exportCategoryRecipe.
+			self -> #exportMetaDefinitionOf:on:.
+			{ self -> #ownCategoriesOfMetaClass: }, exportCategoryRecipe }.
+		{ self -> #extensionCategoriesOfPackage: }, exportCategoryRecipe
+	}
+! !
+
+!ChunkExporter class methodsFor: 'private'!
+
+chunkEscape: aString
+	"Replace all occurrences of !! with !!!! and trim at both ends."
+
+	^(aString replace: '!!' with: '!!!!') trimBoth
+!
+
+classNameFor: aClass
+	^aClass isMetaclass
+		ifTrue: [aClass instanceClass name, ' class']
+		ifFalse: [
+		aClass isNil
+			ifTrue: ['nil']
+			ifFalse: [aClass name]]
+! !
+
 Object subclass: #ChunkParser
 	instanceVariableNames: 'stream'
 	package: 'Importer-Exporter'!
@@ -64,58 +217,38 @@ I am typically used to save code outside of the Amber runtime (committing to dis
 
 Use `#exportAll`, `#exportClass:` or `#exportPackage:` methods.!
 
-!Exporter methodsFor: 'fileOut'!
+!Exporter class methodsFor: 'exporting-accessing'!
 
-exportAll
-	"Export all packages in the system."
+extensionMethodsOfPackage: package
+	"Issue #143: sort classes and methods alphabetically"
 
-	^String streamContents: [:stream |
-		Smalltalk current packages do: [:pkg |
-		stream nextPutAll: (self exportPackage: pkg name)]]
+	| name result |
+	name := package name.
+	result := OrderedCollection new.
+	(Package sortedClasses: Smalltalk current classes) do: [:each |
+		{each. each class} do: [:aClass |
+			result addAll: (((aClass methodDictionary values)
+				sorted: [:a :b | a selector <= b selector])
+				select: [:method | method category match: '^\*', name]) ]].
+	^result
 !
 
-exportClass: aClass
-	"Export a single class. Subclasses override these methods."
+ownMethodsOfClass: aClass
+	"Issue #143: sort methods alphabetically"
 
-	^String streamContents: [:stream |
-		self exportDefinitionOf: aClass on: stream.
-		self exportMethodsOf: aClass on: stream.
-		self exportMetaDefinitionOf: aClass on: stream.
-		self exportMethodsOf: aClass class on: stream]
+	^((aClass methodDictionary values) sorted: [:a :b | a selector <= b selector])
+		reject: [:each | (each category match: '^\*')]
 !
 
-exportPackage: packageName
-	"Export a given package by name."
+ownMethodsOfMetaClass: aClass
+	"Issue #143: sort methods alphabetically"
 
-	| package |
-	^String streamContents: [:stream |
-		package := Smalltalk current packageAt: packageName.
-		self exportAmdPackagePrologueOf: package on: stream.
-		[
-			self exportPackageDefinitionOf: package on: stream.
-
-			"Export classes in dependency order.
-			Update (issue #171): Remove duplicates for export"
-			package sortedClasses asSet do: [:each |
-						stream nextPutAll: (self exportClass: each)].
-			self exportPackageExtensionsOf: package on: stream
-		] ensure: [
-			self exportAmdPackageEpilogueOn: stream
-		]]
+	^self ownMethodsOfClass: aClass class
 ! !
 
-!Exporter methodsFor: 'private'!
-
-classNameFor: aClass
-	^aClass isMetaclass
-		ifTrue: [aClass instanceClass name, '.klass']
-		ifFalse: [
-		aClass isNil
-			ifTrue: ['nil']
-			ifFalse: [aClass name]]
-!
+!Exporter class methodsFor: 'exporting-output'!
 
-exportAmdPackageEpilogueOn: aStream
+exportAmdPackageEpilogueOf: aPackage on: aStream
 	aStream
 		nextPutAll: '});';
 		lf
@@ -131,6 +264,7 @@ exportAmdPackagePrologueOf: aPackage on: aStream
 
 exportDefinitionOf: aClass on: aStream
 	aStream
+		lf;
 		nextPutAll: 'smalltalk.addClass(';
 		nextPutAll: '''', (self classNameFor: aClass), ''', ';
 		nextPutAll: 'smalltalk.', (self classNameFor: aClass superclass);
@@ -154,6 +288,7 @@ exportDefinitionOf: aClass on: aStream
 !
 
 exportMetaDefinitionOf: aClass on: aStream
+	aStream lf.
 	aClass class instanceVariableNames isEmpty ifFalse: [
 		aStream
 		nextPutAll: 'smalltalk.', (self classNameFor: aClass class);
@@ -164,7 +299,7 @@ exportMetaDefinitionOf: aClass on: aStream
 		aStream nextPutAll: '];', String lf]
 !
 
-exportMethod: aMethod of: aClass on: aStream
+exportMethod: aMethod on: aStream
 	aStream
 		nextPutAll: 'smalltalk.addMethod(';lf;
 		"nextPutAll: aMethod selector asSelector asJavascript, ',';lf;"
@@ -179,19 +314,10 @@ exportMethod: aMethod of: aClass on: aStream
 	aStream
 		lf;
 		nextPutAll: '}),';lf;
-		nextPutAll: 'smalltalk.', (self classNameFor: aClass);
+		nextPutAll: 'smalltalk.', (self classNameFor: aMethod methodClass);
 		nextPutAll: ');';lf;lf
 !
 
-exportMethodsOf: aClass on: aStream
-	"Issue #143: sort methods alphabetically"
-
-	((aClass methodDictionary values) sorted: [:a :b | a selector <= b selector]) do: [:each |
-		(each category match: '^\*') ifFalse: [
-			self exportMethod: each of: aClass on: aStream]].
-	aStream lf
-!
-
 exportPackageDefinitionOf: package on: aStream
 	aStream
 		nextPutAll: 'smalltalk.addPackage(';
@@ -199,140 +325,52 @@ exportPackageDefinitionOf: package on: aStream
 		lf
 !
 
-exportPackageExtensionsOf: package on: aStream
-	"Issue #143: sort classes and methods alphabetically"
+exportPackageEpilogueOf: aPackage on: aStream
+	aStream
+		nextPutAll: '})(global_smalltalk,global_nil,global__st);';
+		lf
+!
 
-	| name |
-	name := package name.
-	(Package sortedClasses: Smalltalk current classes) do: [:each |
-		{each. each class} do: [:aClass |
-			((aClass methodDictionary values) sorted: [:a :b | a selector <= b selector]) do: [:method |
-				(method category match: '^\*', name) ifTrue: [
-					self exportMethod: method of: aClass on: aStream ]]]]
+exportPackagePrologueOf: aPackage on: aStream
+	aStream
+		nextPutAll: '(function(smalltalk,nil,_st){';
+		lf
 ! !
 
-Exporter subclass: #ChunkExporter
-	instanceVariableNames: ''
-	package: 'Importer-Exporter'!
-!ChunkExporter commentStamp!
-I am an exporter dedicated to outputting Amber source code in the classic Smalltalk chunk format.
-
-I do not output any compiled code.!
-
-!ChunkExporter methodsFor: 'private'!
-
-chunkEscape: aString
-	"Replace all occurrences of !! with !!!! and trim at both ends."
+!Exporter class methodsFor: 'fileOut'!
+
+recipe
+	"Export a given package."
+
+	^{
+		self -> #exportAmdPackagePrologueOf:on:.
+		self -> #exportPackageDefinitionOf:on:.
+		{
+			PluggableExporter -> #ownClassesOfPackage:.
+			self -> #exportDefinitionOf:on:.
+			{
+				self -> #ownMethodsOfClass:.
+				self -> #exportMethod:on: }.
+			self -> #exportMetaDefinitionOf:on:.
+			{
+				self -> #ownMethodsOfMetaClass:.
+				self -> #exportMethod:on: } }.
+		{
+			self -> #extensionMethodsOfPackage:.
+			self -> #exportMethod:on: }.
+		self -> #exportAmdPackageEpilogueOf:on:
+	}
+! !
 
-	^(aString replace: '!!' with: '!!!!') trimBoth
-!
+!Exporter class methodsFor: 'private'!
 
 classNameFor: aClass
 	^aClass isMetaclass
-		ifTrue: [aClass instanceClass name, ' class']
+		ifTrue: [aClass instanceClass name, '.klass']
 		ifFalse: [
 		aClass isNil
 			ifTrue: ['nil']
 			ifFalse: [aClass name]]
-!
-
-exportAmdPackageEpilogueOn: aStream
-!
-
-exportAmdPackagePrologueOf: aPackage on: aStream
-!
-
-exportDefinitionOf: aClass on: aStream
-	"Chunk format."
-
-	aStream
-		nextPutAll: (self classNameFor: aClass superclass);
-		nextPutAll: ' subclass: #', (self classNameFor: aClass); lf;
-		tab; nextPutAll: 'instanceVariableNames: '''.
-	aClass instanceVariableNames
-		do: [:each | aStream nextPutAll: each]
-		separatedBy: [aStream nextPutAll: ' '].
-	aStream
-		nextPutAll: ''''; lf;
-		tab; nextPutAll: 'package: ''', aClass category, '''!!'; lf.
-	aClass comment notEmpty ifTrue: [
-		aStream
-		nextPutAll: '!!', (self classNameFor: aClass), ' commentStamp!!';lf;
-		nextPutAll: (self chunkEscape: aClass comment), '!!';lf].
-	aStream lf
-!
-
-exportMetaDefinitionOf: aClass on: aStream
-
-	aClass class instanceVariableNames isEmpty ifFalse: [
-		aStream
-			nextPutAll: (self classNameFor: aClass class);
-			nextPutAll: ' instanceVariableNames: '''.
-		aClass class instanceVariableNames
-			do: [:each | aStream nextPutAll: each]
-			separatedBy: [aStream nextPutAll: ' '].
-		aStream
-			nextPutAll: '''!!'; lf; lf]
-!
-
-exportMethod: aMethod of: aClass on: aStream
-	aStream
-		lf; lf; nextPutAll: (self chunkEscape: aMethod source); lf;
-		nextPutAll: '!!'
-!
-
-exportMethods: methods category: category of: aClass on: aStream
-	"Issue #143: sort methods alphabetically"
-
-	aStream
-		nextPutAll: '!!', (self classNameFor: aClass);
-		nextPutAll: ' methodsFor: ''', category, '''!!'.
-		(methods sorted: [:a :b | a selector <= b selector]) do: [:each |
-				self exportMethod: each of: aClass on: aStream].
-	aStream nextPutAll: ' !!'; lf; lf
-!
-
-exportMethodsOf: aClass on: aStream
-	"Issue #143: sort protocol alphabetically"
-
-	| map |
-	map := Dictionary new.
-	aClass protocolsDo: [:category :methods |
-		(category match: '^\*') ifFalse: [ map at: category put: methods ]].
-	(map keys sorted: [:a :b | a <= b ]) do: [:category | | methods |
-		methods := map at: category.
-		self
-			exportMethods: methods
-			category: category
-			of: aClass
-			on: aStream ]
-!
-
-exportPackageDefinitionOf: package on: aStream
-	"Chunk format."
-
-	aStream
-		nextPutAll: 'Smalltalk current createPackage: ''', package name, '''!!';
-		lf
-!
-
-exportPackageExtensionsOf: package on: aStream
-	"We need to override this one too since we need to group
-	all methods in a given protocol under a leading methodsFor: chunk
-	for that class."
-
-	"Issue #143: sort protocol alphabetically"
-
-	| name map |
-	name := package name.
-	(Package sortedClasses: Smalltalk current classes) do: [:each |
-		{each. each class} do: [:aClass |
-			map := Dictionary new.
-			aClass protocolsDo: [:category :methods |
-				(category match: '^\*', name) ifTrue: [ map at: category put: methods ]].
-			(map keys sorted: [:a :b | a <= b ]) do: [:category | | methods |
-				methods := map at: category.
-				self exportMethods: methods category: category of: aClass on: aStream ]]]
 ! !
 
 Exporter subclass: #StrippedExporter
@@ -341,10 +379,11 @@ Exporter subclass: #StrippedExporter
 !StrippedExporter commentStamp!
 I export Amber code into a JavaScript string, but without any optional associated data like the Amber source code.!
 
-!StrippedExporter methodsFor: 'private'!
+!StrippedExporter class methodsFor: 'exporting-output'!
 
 exportDefinitionOf: aClass on: aStream
 	aStream
+		lf;
 		nextPutAll: 'smalltalk.addClass(';
 		nextPutAll: '''', (self classNameFor: aClass), ''', ';
 		nextPutAll: 'smalltalk.', (self classNameFor: aClass superclass);
@@ -359,7 +398,7 @@ exportDefinitionOf: aClass on: aStream
 	aStream lf
 !
 
-exportMethod: aMethod of: aClass on: aStream
+exportMethod: aMethod on: aStream
 	aStream
 		nextPutAll: 'smalltalk.addMethod(';lf;
 		"nextPutAll: aMethod selector asSelector asJavascript, ',';lf;"
@@ -368,7 +407,7 @@ exportMethod: aMethod of: aClass on: aStream
 		nextPutAll: 'fn: ', aMethod fn compiledSource, ',';lf;
 		nextPutAll: 'messageSends: ', aMethod messageSends asJavascript;
 		nextPutAll: '}),';lf;
-		nextPutAll: 'smalltalk.', (self classNameFor: aClass);
+		nextPutAll: 'smalltalk.', (self classNameFor: aMethod methodClass);
 		nextPutAll: ');';lf;lf
 ! !
 
@@ -414,7 +453,8 @@ commit: aPackage
 	self commitChannels
 		do: [ :commitStrategyFactory || fileContents commitStrategy |
 			commitStrategy := commitStrategyFactory value: aPackage.
-			fileContents := (commitStrategy key exportPackage: aPackage name).
+			fileContents := String streamContents: [ :stream |
+				(PluggableExporter newUsing: commitStrategy key) exportPackage: aPackage on: stream ].
 			self ajaxPutAt: commitStrategy value data: fileContents ]
 		displayingProgress: 'Committing package ', aPackage name
 ! !
@@ -472,9 +512,9 @@ I should not be used directly. Instead, use the corresponding `Package` methods.
 
 commitChannels
 	^{ 
-		[ :pkg | Exporter new -> (pkg commitPathJs, '/', pkg name, '.js') ].
-		[ :pkg | StrippedExporter new -> (pkg commitPathJs, '/', pkg name, '.deploy.js') ].
-		[ :pkg | ChunkExporter new -> (pkg commitPathSt, '/', pkg name, '.st') ]
+		[ :pkg | Exporter recipe -> (pkg commitPathJs, '/', pkg name, '.js') ].
+		[ :pkg | StrippedExporter recipe -> (pkg commitPathJs, '/', pkg name, '.deploy.js') ].
+		[ :pkg | ChunkExporter recipe -> (pkg commitPathSt, '/', pkg name, '.st') ]
 	}
 !
 
@@ -566,6 +606,60 @@ loadPackages: aCollection prefix: aString
 	^ self new loadPackages: aCollection prefix: aString
 ! !
 
+Object subclass: #PluggableExporter
+	instanceVariableNames: 'recipe'
+	package: 'Importer-Exporter'!
+
+!PluggableExporter methodsFor: 'accessing'!
+
+recipe
+	^recipe
+!
+
+recipe: anArray
+	recipe := anArray
+! !
+
+!PluggableExporter methodsFor: 'fileOut'!
+
+export: anObject usingRecipe: anArray on: aStream
+	| args |
+	args := { anObject. aStream }.
+	anArray do: [ :each | | val |
+		val := each value.
+		val == each
+			ifFalse: [ "association"
+				each key perform: val withArguments: args ]
+			ifTrue: [ "sub-array"
+				| selection |
+				selection := each first key perform: each first value withArguments: { anObject }.
+				selection do: [ :eachPart |	self export: eachPart usingRecipe: each allButFirst on: aStream ]]]
+!
+
+exportAll
+	"Export all packages in the system."
+
+	^String streamContents: [:stream |
+		Smalltalk current packages do: [:pkg |
+		self exportPackage: pkg on: stream]]
+!
+
+exportPackage: aPackage on: aStream
+	self export: aPackage usingRecipe: self recipe on: aStream
+! !
+
+!PluggableExporter class methodsFor: 'exporting-accessing'!
+
+newUsing: recipe
+	^self new recipe: recipe; yourself
+!
+
+ownClassesOfPackage: package
+	"Export classes in dependency order.
+	Update (issue #171): Remove duplicates for export"
+	^package sortedClasses asSet
+! !
+
 !Package methodsFor: '*Importer-Exporter'!
 
 commit