Merge pull request #25 from jecisc/package-and-tags

Get rid of categories

src/Hermes-Exporter/HEMethodContainer.extension.st

@@ -5,17 +5,22 @@ HEMethodContainer >> doFromMethodContainer: aMethodContainer [
 	"When a class or a trait is transformed all the methods should be transformed.
 	In both the class and instance side. Also the trait composition should be handled"
 
-	category := aMethodContainer category.
-	traitComposition := aMethodContainer traitComposition
-		asExportedLiteral.
-	classTraitComposition := aMethodContainer classSide traitComposition
-		asExportedLiteral.
+	packageName := aMethodContainer package name.
+	self flag: #pharo11.
+	tagName := SystemVersion current major >= 12
+		           ifTrue: [
+			           aMethodContainer packageTag isRoot
+				           ifTrue: [ '' ]
+				           ifFalse: [ aMethodContainer packageTag name ] ]
+		           ifFalse: [ aMethodContainer tags ifEmpty: [ '' ] ifNotEmpty: [ :tags | tags anyOne ] ].
+	traitComposition := aMethodContainer traitComposition asExportedLiteral.
+	classTraitComposition := aMethodContainer classSide traitComposition asExportedLiteral.
 	methods := aMethodContainer localMethods
-		select: [ :e | e isExtension not ]
-		thenCollect: [ :e | HEMethod for: e ].
+		           select: [ :e | e isExtension not ]
+		           thenCollect: [ :e | HEMethod for: e ].
 	classSideMethods := aMethodContainer classSide localMethods
-		select: [ :e | e isExtension not ]
-		thenCollect: [ :e | HEMethod for: e ]
+		                    select: [ :e | e isExtension not ]
+		                    thenCollect: [ :e | HEMethod for: e ]
 ]
 
 { #category : '*Hermes-Exporter' }
@@ -25,7 +30,9 @@ HEMethodContainer >> doWriteHeaderInto: aWriter [
 
 { #category : '*Hermes-Exporter' }
 HEMethodContainer >> doWriteMethods: aWriter [
-	aWriter writeByteString: category.
+
+	aWriter writeByteString: self packageName.
+	aWriter writeByteString: self tagName.
 
 	aWriter writeInt32: methods size.
 	methods do: [ :e | e writeInto: aWriter ].

src/Hermes-Ring2/HERing2ToHermesBuilder.class.st

@@ -30,21 +30,12 @@ HERing2ToHermesBuilder >> visitClass: aClass [
 
 	aHEClass className: aClass name.
 	aHEClass superclass: (aClass superclass ifNil: '' ifNotNil: #name).
-	aHEClass instanceVariables:
-		((aClass slots collect: #name) joinUsing: ' ').
-	aHEClass classInstancevariables:
-		((aClass metaclass slots collect: #name) joinUsing: ' ').
+	aHEClass instanceVariables: ((aClass slots collect: #name) joinUsing: ' ').
+	aHEClass classInstancevariables: ((aClass metaclass slots collect: #name) joinUsing: ' ').
 	aHEClass classVariables: (aClass classVarNames joinUsing: ' ').
-	aHEClass sharedPools:
-		((aClass sharedPools collect: #name) joinUsing: ' ').
+	aHEClass sharedPools: ((aClass sharedPools collect: #name) joinUsing: ' ').
 	aHEClass layoutClass: aClass layout layoutName.
 
-	aHEClass category: aClass category.
-	aHEClass traitComposition: aClass traitComposition asExportedLiteral.
-	aHEClass classTraitComposition:
-		aClass classSide traitComposition asExportedLiteral.
-
-
 	^ aHEClass
 ]
 
@@ -70,21 +61,16 @@ HERing2ToHermesBuilder >> visitMethod: aMethod [
 HERing2ToHermesBuilder >> visitMethodContainer: aMethodContainer using: aHEClass [
 
 	| instanceMethods classMethods |
-	aHEClass category: aMethodContainer category.
-	aHEClass traitComposition:
-		aMethodContainer traitComposition asExportedLiteral.
-	aHEClass classTraitComposition:
-		aMethodContainer classSide traitComposition asExportedLiteral.
-
-	instanceMethods := aMethodContainer localMethods reject: [ :e | 
-		                   e isExtension ].
-	classMethods := aMethodContainer classSide localMethods reject: [ :e | 
-		                e isExtension ].
-
-	aHEClass methods:
-		(instanceMethods collect: [ :e | e acceptVisitor: self ]).
-	aHEClass classSideMethods:
-		(classMethods collect: [ :e | e acceptVisitor: self ])
+	aHEClass packageName: aMethodContainer package name.
+	aHEClass tagName: (aMethodContainer tags ifEmpty: [ '' ] ifNotEmpty: [ :tags | tags anyOne ]).
+	aHEClass traitComposition: aMethodContainer traitComposition asExportedLiteral.
+	aHEClass classTraitComposition: aMethodContainer classSide traitComposition asExportedLiteral.
+
+	instanceMethods := aMethodContainer localMethods reject: [ :e | e isExtension ].
+	classMethods := aMethodContainer classSide localMethods reject: [ :e | e isExtension ].
+
+	aHEClass methods: (instanceMethods collect: [ :e | e acceptVisitor: self ]).
+	aHEClass classSideMethods: (classMethods collect: [ :e | e acceptVisitor: self ])
 ]
 
 { #category : 'visiting' }

src/Hermes-Tests/HEInstallWholePackageTest.class.st

@@ -14,14 +14,14 @@ HEInstallWholePackageTest >> changeClassesNames: aPackage [
 	aPackage instVarNamed: #packageName put: #'Hermes-Tests-External-Package2'.
 	aPackage classes
 		do: [ :e | 
-			e instVarNamed: #category put: #'Hermes-Tests-External-Package2'.
+			e instVarNamed: #packageName put: #'Hermes-Tests-External-Package2'.
 			e instVarNamed: #className put: (e className , '2') asSymbol.
 			self updateMethodLiterals: e methods.
 			self updateMethodLiterals: e classSideMethods ].
 
 	aPackage traits
 		do: [ :e | 
-			e instVarNamed: #category put: #'Hermes-Tests-External-Package2'.
+			e instVarNamed: #packageName put: #'Hermes-Tests-External-Package2'.
 			e instVarNamed: #traitName put: (e traitName , '2') asSymbol.
 			self updateMethodLiterals: e methods.
 			self updateMethodLiterals: e classSideMethods ].

src/Hermes-Tests/HEInstallerDuplicationTest.class.st

@@ -244,37 +244,46 @@ HEInstallerDuplicationTest >> testCreatingADuplicatedSimpleTraitFailing [
 
 { #category : 'tests-extended-installer' }
 HEInstallerDuplicationTest >> testCreatingADuplicatedSimpleTraitIgnore [
+
 	| exportedTrait |
-	installer := HEExtendedInstaller new.	
+	installer := HEExtendedInstaller new.
 	installer duplicationMode: HEIgnoreOnDuplication new.
-	
-	exportedTrait := HETrait for: THEOneTestTrait. 
+
+	exportedTrait := HETrait for: THEOneTestTrait.
 	self changeNameOf: exportedTrait to: #THEOneTestTraitNew.
-	
-	aTrait := installer buildTrait: exportedTrait.	
+
+	aTrait := installer buildTrait: exportedTrait.
 	installer installMethods: exportedTrait into: aTrait.
 
-	exportedTrait category: (exportedTrait category , 'New') asSymbol.
-	installer buildTrait: exportedTrait.	
+	exportedTrait packageName: (exportedTrait packageName , 'New') asSymbol.
+	installer buildTrait: exportedTrait.
 
-	self assert: (Smalltalk at: #THEOneTestTraitNew ) category equals: THEOneTestTrait category.
+	self assert: (Smalltalk at: #THEOneTestTraitNew) package name equals: THEOneTestTrait package name
 ]
 
 { #category : 'tests-extended-installer' }
 HEInstallerDuplicationTest >> testCreatingADuplicatedSimpleTraitReplace [
-	| exportedTrait newCategory |
+
+	| exportedTrait newPackage |
 	installer := HEExtendedInstaller new.
 	installer duplicationMode: HEReplaceOnDuplication new.
-	
-	exportedTrait := HETrait for: THEOneTestTrait. 
+
+	exportedTrait := HETrait for: THEOneTestTrait.
 	self changeNameOf: exportedTrait to: #THEOneTestTraitNew.
-
-	aTrait := installer buildTrait: exportedTrait.	
-	installer installMethods: exportedTrait into: aTrait.
 
-	newCategory := (exportedTrait category , 'New') asSymbol.
-	exportedTrait category: newCategory.
-	installer buildTrait: exportedTrait.	
+	aTrait := installer buildTrait: exportedTrait.
+	installer installMethods: exportedTrait into: aTrait.
 
-	self assert: (Smalltalk at: #THEOneTestTraitNew ) category equals: newCategory.
+	newPackage := (exportedTrait packageName , 'New') asSymbol.
+	exportedTrait packageName: newPackage.
+	[
+	self flag: #pharo11. "This is a hack caused by the package/tag/category mess that should be fixed in P12 release."
+	self flag: #pahro11. "Update this when Pharo 12 will be the minimal version"
+	SystemVersion current major < 12
+		ifTrue: [ RPackageOrganizer default registerPackageNamed: newPackage ]
+		ifFalse: [ self packageOrganizer ensurePackage: newPackage ].
+	installer buildTrait: exportedTrait.
+
+	self assert: (Smalltalk at: #THEOneTestTraitNew) package name equals: newPackage ] ensure: [
+		(newPackage asPackageIfAbsent: [ nil ]) ifNotNil: [ :package | package removeFromSystem ] ]
 ]

src/Hermes-Tests/HEInstallerSimpleTest.class.st

@@ -253,7 +253,7 @@ HEInstallerSimpleTest >> testUndeclared [
 
 	| exportedClass |
 	"If we run the test multiple times we need to do this to be sure #AnUndeclaredClass is not in the Undeclared dictionary anymore."
-	Undeclared removeUnreferencedKeys.
+	Smalltalk image cleanOutUndeclared.
 	[
 	UndefinedObject compile: 'xxx
 		^ AnUndeclaredClass'.

src/Hermes/HEInstaller.class.st

@@ -25,7 +25,8 @@ Class {
 	#superclass : 'Object',
 	#instVars : [
 		'environment',
-		'originalUndeclareds'
+		'originalUndeclareds',
+		'hasTraits'
 	],
 	#category : 'Hermes-ClassInstaller',
 	#package : 'Hermes',
@@ -49,8 +50,9 @@ HEInstaller >> build: aHEClass [
 			            slots: aHEClass instanceVariables asSlotCollection;
 			            sharedVariablesFromString: aHEClass classVariables;
 			            sharedPools: aHEClass sharedPools;
-			            category: aHEClass category;
+			            package: aHEClass packageName;
 			            classSlots: aHEClass classInstancevariables asSlotCollection.
+		            aHEClass tagName ifNotEmpty: [ :tag | builder tag: tag ].
 		            self supportsTraits ifTrue: [
 			            builder
 				            traitComposition: (self buildTraitCompositionFor: aHEClass traitComposition);
@@ -60,36 +62,27 @@ HEInstaller >> build: aHEClass [
 
 { #category : 'creating traits' }
 HEInstaller >> buildTrait: aTraitDefinition [
-	| newTrait traitComposition traitClass|
-
-	(self existingTrait: aTraitDefinition) ifNotNil: [:x | ^ x ].
-
-	traitClass := Smalltalk globals at: #Trait ifAbsent: [ self error: 'Trait support is not installed' ].
-
-	traitComposition := self buildTraitCompositionFor: aTraitDefinition traitComposition.	
-
-	newTrait := traitClass
-		named: aTraitDefinition traitName
-		uses: traitComposition
-		package: aTraitDefinition category
-		env: environment.
 
-	newTrait classTrait traitComposition: (self buildTraitCompositionFor: aTraitDefinition classTraitComposition).
+	(self existingTrait: aTraitDefinition) ifNotNil: [ :x | ^ x ].
 
-	^ newTrait
+	self supportsTraits ifFalse: [ self error: 'Trait support is not installed' ].
+
+	^ self class classInstaller make: [ :builder |
+		  builder
+			  beTrait;
+			  name: aTraitDefinition traitName;
+			  traitComposition: (self buildTraitCompositionFor: aTraitDefinition traitComposition);
+			  classTraitComposition: (self buildTraitCompositionFor: aTraitDefinition classTraitComposition);
+			  package: aTraitDefinition packageName;
+			  environment: environment.
+
+		  aTraitDefinition tagName ifNotEmpty: [ :tag | builder tag: tag ] ]
 ]
 
 { #category : 'creating traits' }
 HEInstaller >> buildTraitCompositionFor: traitComposition [
 
-	| aLiteral |
-
-	aLiteral := (traitComposition asLiteralIn: environment).
-	aLiteral isArray 
-		ifTrue: [ ^ aLiteral 
-							ifEmpty: [ TaEmptyComposition new ]
-							ifNotEmpty: [ TaSequence withAll: (aLiteral collect: [:each | each asTraitComposition]) ]  ]
-		ifFalse: [ ^ aLiteral asTraitComposition ]
+	^ (traitComposition asLiteralIn: environment) asTraitComposition
 ]
 
 { #category : 'accessing' }
@@ -163,7 +156,9 @@ HEInstaller >> existingTrait: aHETrait [
 HEInstaller >> initialize [
 
 	environment := self class environment.
-	originalUndeclareds := Undeclared copy
+	originalUndeclareds := Undeclared copy.
+	"We need to set it at the initialization and we cannot ask this later during the building because it will cause trouble if the class we are building is Trait."
+	hasTraits := Smalltalk globals hasClassNamed: #Trait
 ]
 
 { #category : 'installing methods' }
@@ -257,7 +252,7 @@ HEInstaller >> shouldBuildMethod: aHEMethod in: aClass [
 { #category : 'testing' }
 HEInstaller >> supportsTraits [
 
-	^ Smalltalk globals hasClassNamed: #Trait
+	^ hasTraits
 ]
 
 { #category : 'reporting undeclared' }

src/Hermes/HEMethodContainer.class.st

@@ -11,23 +11,14 @@ Class {
 		'classSideMethods',
 		'traitComposition',
 		'classTraitComposition',
-		'category'
+		'packageName',
+		'tagName'
 	],
 	#category : 'Hermes-Model',
 	#package : 'Hermes',
 	#tag : 'Model'
 }
 
-{ #category : 'accessing' }
-HEMethodContainer >> category [
-	^ category
-]
-
-{ #category : 'accessing' }
-HEMethodContainer >> category: anObject [
-	category := anObject
-]
-
 { #category : 'accessing' }
 HEMethodContainer >> classSideMethods [
 	^ classSideMethods
@@ -56,9 +47,11 @@ HEMethodContainer >> doReadHeaderFrom: aReader [
 
 { #category : 'reading' }
 HEMethodContainer >> doReadMethodsFrom: aReader [
+
 	| numberOfMethods numberOfClassMethods |
-	"The category of a trait or a class is stored as a byteString."
-	category := aReader readByteSymbol.
+	"The package and tags of a trait or a class are stored as a byteString."
+	packageName := aReader readByteSymbol.
+	tagName := aReader readByteSymbol.
 	"The methods are stored with the quantity before them. First the instance side and the the class side."
 	numberOfMethods := aReader readInt32.
 
@@ -82,12 +75,36 @@ HEMethodContainer >> methods: anObject [
 	methods := anObject
 ]
 
+{ #category : 'accessing' }
+HEMethodContainer >> packageName [
+
+	^ packageName
+]
+
+{ #category : 'accessing' }
+HEMethodContainer >> packageName: anObject [
+
+	packageName := anObject
+]
+
 { #category : 'reading' }
 HEMethodContainer >> readFrom: aReader [
 	self doReadHeaderFrom: aReader.
 	self doReadMethodsFrom: aReader
 ]
 
+{ #category : 'accessing' }
+HEMethodContainer >> tagName [
+
+	^ tagName
+]
+
+{ #category : 'accessing' }
+HEMethodContainer >> tagName: anObject [
+
+	tagName := anObject
+]
+
 { #category : 'accessing' }
 HEMethodContainer >> traitComposition [
 	^ traitComposition

src/Hermes/HEPackage.class.st

@@ -33,7 +33,7 @@ Class {
 
 { #category : 'formatting' }
 HEPackage class >> formatVersion [
-	^ 2
+	^ 3
 ]
 
 { #category : 'adding' }