Merge pull request #576 from herby/pluggable-exporters-with-new-loaders

Pluggable exporters

bin/amberc.js

@@ -54,19 +54,19 @@ function Combo(callback) {
 
 Combo.prototype = {
   add: function () {
-    var self = this,
-        id = this.items;
-    this.items++;
-    return function () {
-      self.check(id, arguments);
-    };
+	var self = this,
+		id = this.items;
+	this.items++;
+	return function () {
+	  self.check(id, arguments);
+	};
   },
   check: function (id, arguments) {
-    this.results[id] = Array.prototype.slice.call(arguments);
-    this.items--;
-    if (this.items == 0) {
-      this.callback.apply(this, this.results);
-    }
+	this.results[id] = Array.prototype.slice.call(arguments);
+	this.items--;
+	if (this.items == 0) {
+	  this.callback.apply(this, this.results);
+	}
   }
 };
 
@@ -84,10 +84,10 @@ function AmberC(amber_dir, closure_jar) {
 	this.amber_dir = amber_dir;
 	this.closure_jar = closure_jar || '';
 	this.kernel_libraries = ['@boot', 'Kernel-Objects', 'Kernel-Classes', 'Kernel-Methods',
-	                         'Kernel-Collections', 'Kernel-Exceptions', 'Kernel-Transcript',
-	                         'Kernel-Announcements'];
+							 'Kernel-Collections', 'Kernel-Exceptions', 'Kernel-Transcript',
+							 'Kernel-Announcements'];
 	this.compiler_libraries = this.kernel_libraries.concat(['@parser', 'Importer-Exporter', 'Compiler-Exceptions',
-	                          'Compiler-Core', 'Compiler-AST', 'Compiler-IR', 'Compiler-Inlining', 'Compiler-Semantic']);
+							  'Compiler-Core', 'Compiler-AST', 'Compiler-IR', 'Compiler-Inlining', 'Compiler-Semantic']);
 }
 
 
@@ -497,9 +497,14 @@ AmberC.prototype.category_export = function() {
 		console.log('Exporting ' + (defaults.deploy ? '(debug + deploy)' : '(debug)')
 			+ ' category ' + category + ' as ' + jsFile
 			+ (defaults.deploy ? ' and ' + jsFileDeploy : ''));
-		fs.writeFile(jsFile, defaults.smalltalk.Exporter._new()._exportPackage_(category), function(err) {
+		var smalltalk = defaults.smalltalk;
+		var pluggableExporter = smalltalk.PluggableExporter;
+		var packageObject = smalltalk.Package._named_(category);
+		fs.writeFile(jsFile, smalltalk.String._streamContents_(function (stream) {
+			pluggableExporter._newUsing_(smalltalk.Exporter._recipe())._exportPackage_on_(packageObject, stream); }), function(err) {
 			if (defaults.deploy) {
-				fs.writeFile(jsFileDeploy, defaults.smalltalk.StrippedExporter._new()._exportPackage_(category), callback);
+				fs.writeFile(jsFileDeploy, smalltalk.String._streamContents_(function (stream) {
+					pluggableExporter._newUsing_(smalltalk.StrippedExporter._recipe())._exportPackage_on_(packageObject, stream); }), callback);
 			} else {
 				callback(null, null);
 			}

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,59 +217,40 @@ 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 |
-		self exportPackagePrologueOn: stream.
-		[
-			package := Smalltalk current packageAt: packageName.
-			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 exportPackageEpilogueOn: 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'!
 
 exportDefinitionOf: aClass on: aStream
 	aStream
+		lf;
 		nextPutAll: 'smalltalk.addClass(';
 		nextPutAll: '''', (self classNameFor: aClass), ''', ';
 		nextPutAll: 'smalltalk.', (self classNameFor: aClass superclass);
@@ -140,6 +274,7 @@ exportDefinitionOf: aClass on: aStream
 !
 
 exportMetaDefinitionOf: aClass on: aStream
+	aStream lf.
 	aClass class instanceVariableNames isEmpty ifFalse: [
 		aStream
 		nextPutAll: 'smalltalk.', (self classNameFor: aClass class);
@@ -150,7 +285,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;"
@@ -165,19 +300,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(';
@@ -185,152 +311,52 @@ exportPackageDefinitionOf: package on: aStream
 		lf
 !
 
-exportPackageEpilogueOn: aStream
+exportPackageEpilogueOf: aPackage on: aStream
 	aStream
 		nextPutAll: '})(global_smalltalk,global_nil,global__st);';
 		lf
 !
 
-exportPackageExtensionsOf: package on: aStream
-	"Issue #143: sort classes and methods alphabetically"
-
-	| 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 ]]]]
-!
-
-exportPackagePrologueOn: 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 -> #exportPackagePrologueOf: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 -> #exportPackageEpilogueOf: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]]
-!
-
-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
-!
-
-exportPackageEpilogueOn: aStream
-!
-
-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 ]]]
-!
-
-exportPackagePrologueOn: aStream
 ! !
 
 Exporter subclass: #StrippedExporter
@@ -339,10 +365,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);
@@ -357,7 +384,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;"
@@ -366,7 +393,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
 ! !
 
@@ -412,7 +439,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
 ! !
@@ -470,9 +498,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') ]
 	}
 !
 
@@ -564,6 +592,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