From d5cdd4059d7d54c6013935f9adc9ef6c8cd839a4 Mon Sep 17 00:00:00 2001 From: Dale Henrichs Date: Wed, 3 Jul 2024 15:42:57 -0700 Subject: [PATCH] Issue #783: checkpoint ... export Trait definitions for .gs files is working --- ...wModificationTonelWriterVisitorV2.class.st | 4 +- .../RwClassDefinition.class.st | 8 +- .../RwProject.extension.st | 1 + ...sModificationTopazWriterVisitorV2.class.st | 314 +++++++++++++++--- .../RwRowanSample9V3Test.class.st | 39 +++ 5 files changed, 306 insertions(+), 60 deletions(-) diff --git a/rowan/src/Rowan-Core/RwModificationTonelWriterVisitorV2.class.st b/rowan/src/Rowan-Core/RwModificationTonelWriterVisitorV2.class.st index 7af201ce6..19d5e95b8 100644 --- a/rowan/src/Rowan-Core/RwModificationTonelWriterVisitorV2.class.st +++ b/rowan/src/Rowan-Core/RwModificationTonelWriterVisitorV2.class.st @@ -180,7 +180,7 @@ RwModificationTonelWriterVisitorV2 >> _typeTraitDefinitionOf: aTraitDefinition [ at: #'traits' ifPresent: [ :value | definition at: #'traits' put: value ]. aTraitDefinition properties - at: #'classtraits' + at: #'classTraits' ifPresent: [ :value | definition at: #'classTraits' put: value ]. aTraitDefinition instVarNames @@ -385,7 +385,7 @@ RwModificationTonelWriterVisitorV2 >> processProject: aProjectModification [ { #category : 'trait writing' } RwModificationTonelWriterVisitorV2 >> processTrait: aTraitModification [ - "write out the class definition" + "write out the trait definition" self _traitSourceFile writeStreamDo: [:aStream | diff --git a/rowan/src/Rowan-Definitions/RwClassDefinition.class.st b/rowan/src/Rowan-Definitions/RwClassDefinition.class.st index 824d48d36..674480a4b 100644 --- a/rowan/src/Rowan-Definitions/RwClassDefinition.class.st +++ b/rowan/src/Rowan-Definitions/RwClassDefinition.class.st @@ -110,18 +110,18 @@ RwClassDefinition >> _removeSubclassesDisallowed [ { #category : 'accessing' } RwClassDefinition >> classTraits [ - ^ self propertyAt: #'classtraits' ifAbsent: [ '' ] + ^ self propertyAt: #'classTraits' ifAbsent: [ '' ] ] { #category : 'accessing' } RwClassDefinition >> classTraits: aTraitCompositionOrStringOrNil [ "aTraitCompositionOrNil is a Trait or a concrete subclass of TaAbstractComposition." - aTraitCompositionOrStringOrNil ifNil: [ ^ self removeProperty: #'classtraits' ]. + aTraitCompositionOrStringOrNil ifNil: [ ^ self removeProperty: #'classTraits' ]. aTraitCompositionOrStringOrNil isString - ifTrue: [ ^ self propertyAt: #'classtraits' put: aTraitCompositionOrStringOrNil ]. + ifTrue: [ ^ self propertyAt: #'classTraits' put: aTraitCompositionOrStringOrNil ]. ^ self - propertyAt: #'classtraits' + propertyAt: #'classTraits' put: aTraitCompositionOrStringOrNil traitCompositionExpression ] diff --git a/rowan/src/Rowan-GemStone-Core/RwProject.extension.st b/rowan/src/Rowan-GemStone-Core/RwProject.extension.st index e1dbcbf48..0ce0b7b4a 100644 --- a/rowan/src/Rowan-GemStone-Core/RwProject.extension.st +++ b/rowan/src/Rowan-GemStone-Core/RwProject.extension.st @@ -3,6 +3,7 @@ Extension { #name : 'RwProject' } { #category : '*rowan-gemstone-core' } RwProject >> exportTopazFormatTo: filePath [ ^ self + exportTopazFormatTo: filePath logClassCreation: false excludeClassInitializers: false excludeRemoveAllMethods: false diff --git a/rowan/src/Rowan-GemStone-CoreV2/RwGsModificationTopazWriterVisitorV2.class.st b/rowan/src/Rowan-GemStone-CoreV2/RwGsModificationTopazWriterVisitorV2.class.st index d650e50a9..5d474ed7e 100644 --- a/rowan/src/Rowan-GemStone-CoreV2/RwGsModificationTopazWriterVisitorV2.class.st +++ b/rowan/src/Rowan-GemStone-CoreV2/RwGsModificationTopazWriterVisitorV2.class.st @@ -21,6 +21,7 @@ Class { 'classSymbolDictionaryNames', 'classDefinitions', 'classExtensions', + 'traitDefinitions', 'bufferedStream', 'topazFilenamePackageNamesMap', 'classDefPackageNameMap', @@ -124,6 +125,19 @@ RwGsModificationTopazWriterVisitorV2 >> _fileOutMethod: methodDefinition forClas lf ] +{ #category : 'private exporting' } +RwGsModificationTopazWriterVisitorV2 >> _fileOutMethod: methodDefinition forTrait: traitName isMeta: isMeta on: aStream [ + + aStream + nextPutAll: 'category: '; nextPutAll: methodDefinition protocol printString; lf; + nextPutAll: (isMeta ifTrue: ['trclassmethod: '] ifFalse: ['trmethod: ']) ; nextPutAll: traitName; lf; + nextPutAll: methodDefinition source. + methodDefinition source last == Character_lf + ifFalse: [aStream lf]. + aStream nextPut: $% ; lf; + lf +] + { #category : 'private exporting' } RwGsModificationTopazWriterVisitorV2 >> _fileoutRemoveAllMethodsFor: className on: aStream [ self excludeRemoveAllMethods @@ -136,6 +150,69 @@ RwGsModificationTopazWriterVisitorV2 >> _fileoutRemoveAllMethodsFor: className o lf ] ] +{ #category : 'private exporting' } +RwGsModificationTopazWriterVisitorV2 >> _fileOutTraitDeclaration: traitDefinition on: aStream [ + aStream + nextPutAll: 'doit'; + lf; + nextPutAll: '(Trait'; + lf; + nextPutAll: ' name: ' , traitDefinition name printString; + lf; + nextPutAll: ' instVars: #('. + self _stringForVariables: traitDefinition instVarNames to: aStream. + aStream + nextPutAll: ')'; + lf. + aStream nextPutAll: ' classVars: #('. + self _stringForVariables: traitDefinition classVarNames to: aStream. + aStream + nextPutAll: ')'; + lf. + aStream nextPutAll: ' classInstVars: #('. + self _stringForVariables: traitDefinition classInstVarNames to: aStream. + aStream + nextPutAll: ')'; + lf. + aStream + nextPutAll: ' inDictionary: '; + nextPutAll: (self classSymbolDictionaryNames at: traitDefinition name); + lf; + nextPutAll: ')'; + lf; + nextPutAll: ' _category: '; + nextPutAll: traitDefinition category printString. +" + traitDefinition comment size == 0 + ifFalse: [ + aStream + nextput: $; + lf; + nextPutAll: ' comment: '; + nextPutAll: traitDefinition comment printString; + yourself ]. +" + aStream + nextPut: $.; + lf. + aStream + nextPutAll: '%'; + lf. + self _fileoutTraitRemoveAllMethodsFor: traitDefinition name on: aStream +] + +{ #category : 'private exporting' } +RwGsModificationTopazWriterVisitorV2 >> _fileoutTraitRemoveAllMethodsFor: traitName on: aStream [ + self excludeRemoveAllMethods + ifFalse: [ + aStream + nextPutAll: 'trremoveallmethods ' , traitName; + lf; + nextPutAll: 'trremoveallclassmethods ' , traitName; + lf; + lf ] +] + { #category : 'private exporting' } RwGsModificationTopazWriterVisitorV2 >> _setBufferedStreamFor: filename [ @@ -304,60 +381,81 @@ RwGsModificationTopazWriterVisitorV2 >> excludeRemoveAllMethods: aBool [ { #category : 'exporting' } RwGsModificationTopazWriterVisitorV2 >> export [ - - self fileNamesInFileInOrder do: [:filename | - | packageNames classDefinitionsInOrder classExtensionsInOrder classExtensionsList classDefinitionsList | - packageNames := self topazFilenamePackageNamesMap at: filename. - self _setBufferedStreamFor: filename. - self bufferedStream nextPutAll: self topazFileHeader. - - classInitializationDefinitions := Set new. "per file record" - classDefinitionsList := Set new. - - self classDefPackageNameMap keysAndValuesDo: [:className :packageName | - (packageNames includes: packageName) - ifTrue: [ classDefinitionsList add: (self classDefinitions at: className) ] ]. - - classDefinitionsInOrder := (RowanGsGeneralDependencySorter - on: classDefinitionsList - dependsOn: [:candidate | candidate superclassName] - dependent: [:candidate | candidate name]) inOrder. - self exportClassDefinitions: classDefinitionsInOrder; - exportMethodDefinitions: classDefinitionsInOrder. - - "consolidate the classExtensions for a class from multiple packages into a single definition" - classExtensionsList := Set new. - self classExtensions keysAndValuesDo: [:classExtName :extSet | - | extsInConfig | - extsInConfig := Set new. - extSet do: [:ext | - | packageName | - packageName := self classExtPackageNameMap at: ext. - (packageNames includes: packageName) - ifTrue: [ extsInConfig add: ext ] ]. - - extsInConfig size <= 1 - ifTrue: [ classExtensionsList addAll: extsInConfig ] - ifFalse: [ - | ar def | - ar := extsInConfig asArray. - def := (ar at: 1) copy. - 2 to: ar size do: [:index | - | d | - d := (ar at: index). - d classMethodDefinitions values do: [:m | def addClassMethodDefinition: m ]. - d instanceMethodDefinitions values do: [:m | def addInstanceMethodDefinition: m ] ]. - classExtensionsList add: def ] ]. - - classExtensionsInOrder := classExtensionsList sort: [:a :b | a name <= b name ]. - self - exportExtensionMethodDefinitions: classExtensionsInOrder. - - self exportClassInitializations. - - self bufferedStream nextPutAll: self topazFileFooter. - - self bufferedStream flush; close ]. + self fileNamesInFileInOrder + do: [ :filename | + | packageNames classDefinitionsInOrder classExtensionsInOrder classExtensionsList classDefinitionsList traitDefinitionsList traitDefinitionsInOrder | + packageNames := self topazFilenamePackageNamesMap at: filename. + self _setBufferedStreamFor: filename. + self bufferedStream nextPutAll: self topazFileHeader. + + classInitializationDefinitions := Set new. "per file record" + classDefinitionsList := Set new. + traitDefinitionsList := Set new. + + self classDefPackageNameMap + keysAndValuesDo: [ :classOrTraitName :packageName | + (packageNames includes: packageName) + ifTrue: [ + (self classDefinitions + at: classOrTraitName + ifPresent: [ :classDef | classDefinitionsList add: classDef ]) + ifNil: [ traitDefinitionsList add: (self traitDefinitions at: classOrTraitName) ] ] ]. + + traitDefinitionsInOrder := SortedCollection + sortBlock: [ :x :y | x name <= y name ]. + traitDefinitionsInOrder addAll: traitDefinitionsList. + + classDefinitionsInOrder := (RowanGsGeneralDependencySorter + on: classDefinitionsList + dependsOn: [ :candidate | candidate superclassName ] + dependent: [ :candidate | candidate name ]) inOrder. + + self + exportTraitDefinitions: traitDefinitionsInOrder; + exportClassDefinitions: classDefinitionsInOrder; + exportTraitMethodDefinitions: traitDefinitionsInOrder; + exportMethodDefinitions: classDefinitionsInOrder. " + consolidate the classExtensions for a class from multiple packages into a single definition" + classExtensionsList := Set new. + self classExtensions + keysAndValuesDo: [ :classExtName :extSet | + | extsInConfig | + extsInConfig := Set new. + extSet + do: [ :ext | + | packageName | + packageName := self classExtPackageNameMap at: ext. + (packageNames includes: packageName) + ifTrue: [ extsInConfig add: ext ] ]. + + extsInConfig size <= 1 + ifTrue: [ classExtensionsList addAll: extsInConfig ] + ifFalse: [ + | ar def | + ar := extsInConfig asArray. + def := (ar at: 1) copy. + 2 to: ar size do: [ :index | + | d | + d := ar at: index. + d classMethodDefinitions values + do: [ :m | def addClassMethodDefinition: m ]. + d instanceMethodDefinitions values + do: [ :m | def addInstanceMethodDefinition: m ] ]. + classExtensionsList add: def ] ]. + + classExtensionsInOrder := classExtensionsList + sort: [ :a :b | a name <= b name ]. + self exportExtensionMethodDefinitions: classExtensionsInOrder. + + self exportTraitsForClasses: classDefinitionsInOrder. "done last to allow any trait method overrides to be loaded before installing trait methods" + + self exportClassInitializations. + + self bufferedStream nextPutAll: self topazFileFooter. + + self bufferedStream + flush; + close ] ] { #category : 'exporting' } @@ -440,6 +538,89 @@ RwGsModificationTopazWriterVisitorV2 >> exportMethodDefinitions: classDefinition self _fileOutMethod: methodDef forClass: className isMeta: false on: stream ] ]. ] +{ #category : 'exporting' } +RwGsModificationTopazWriterVisitorV2 >> exportTraitDefinitions: traitDefinitionsInOrder [ + | stream | + stream := self bufferedStream. + traitDefinitionsInOrder isEmpty not + ifTrue: [ + stream + nextPutAll: '! Trait Declarations'; + lf; + nextPutAll: '! Generated file, do not Edit'; + lf; + lf ]. + traitDefinitionsInOrder + do: [ :traitDef | self _fileOutTraitDeclaration: traitDef on: stream ] +] + +{ #category : 'exporting' } +RwGsModificationTopazWriterVisitorV2 >> exportTraitMethodDefinitions: traitDefinitionsInOrder [ + + self exportTraitMethodDefinitions: traitDefinitionsInOrder labeled: 'Trait implementation' +] + +{ #category : 'exporting' } +RwGsModificationTopazWriterVisitorV2 >> exportTraitMethodDefinitions: traitDefinitionsInOrder labeled: label [ + | stream | + stream := self bufferedStream. + traitDefinitionsInOrder do: [:traitDef | + | traitName | + traitName := traitDef name. + (traitDef classMethodDefinitions isEmpty not or: [ traitDef instanceMethodDefinitions isEmpty not]) + ifTrue: [ + stream nextPutAll: '! '; nextPutAll: label ; nextPutAll: ' for ' ; nextPutAll: traitName printString; lf; + lf ]. + traitDef classMethodDefinitions isEmpty not + ifTrue: [ + stream nextPutAll: '! Class methods for ' ; nextPutAll: traitName printString; lf; + lf ]. + (traitDef classMethodDefinitions values sort: [:a :b | a selector <= b selector ]) + do: [:methodDef | + self _fileOutMethod: methodDef forTrait: traitName isMeta: true on: stream ]. + traitDef instanceMethodDefinitions isEmpty + ifFalse: [ + stream nextPutAll: '! Instance methods for ' ; nextPutAll: traitName printString; lf; + lf ]. + (traitDef instanceMethodDefinitions values sort: [:a :b | a selector <= b selector ]) + do: [:methodDef | + self _fileOutMethod: methodDef forTrait: traitName isMeta: false on: stream ] ]. +] + +{ #category : 'exporting' } +RwGsModificationTopazWriterVisitorV2 >> exportTraitsForClasses: classDefinitionsInOrder [ + | stream | + stream := self bufferedStream. + classDefinitionsInOrder + do: [ :classDef | + (classDef traits isEmpty and: [ classDef classTraits isEmpty ]) + ifFalse: [ + stream + nextPutAll: '! ------------------- Traits for '; + _fileOutAll: classDef name; + lf. + stream + nextPutAll: 'expectvalue /Class'; + lf; + nextPutAll: 'doit'; + lf. + classDef traits isEmpty + ifFalse: [ + stream + _fileOutAll: classDef name; + nextPutAll: ' addTrait: ' , classDef traits , '.'; + lf ]. + classDef classTraits isEmpty + ifFalse: [ + stream + _fileOutAll: classDef name; + nextPutAll: ' addClassTrait: ' , classDef classTraits , '.'; + lf ]. + stream + nextPut: $%; + lf ] ] +] + { #category : 'accessing' } RwGsModificationTopazWriterVisitorV2 >> filenameExtension [ @@ -515,6 +696,25 @@ RwGsModificationTopazWriterVisitorV2 >> processProject: aProjectModification [ aProjectModification packagesModification acceptVisitor: self ] +{ #category : 'class writing' } +RwGsModificationTopazWriterVisitorV2 >> processTrait: aTraitModification [ + + "write out the trait definition" + + | traitDefinition symbolDictName traitName | + traitDefinition := aTraitModification after. + (self traitDefinitions at: (traitName := traitDefinition name) ifAbsent: []) ifNotNil: [ + self error: 'duplicate trait definition for ', traitName printString, ' encountered.']. + + symbolDictName := self currentProjectDefinition gemstoneSymbolDictNameForPackageNamed: self currentPackageDefinition name. + self classSymbolDictionaryNames at: traitDefinition name put: symbolDictName. + self traitDefinitions at: traitDefinition name put: traitDefinition. + + self classDefPackageNameMap at: traitDefinition name put: currentPackageDefinition name. + + "no need to visit any further as the trait definition records the instance and class methods" +] + { #category : 'accessing' } RwGsModificationTopazWriterVisitorV2 >> repositoryRootPath [ @@ -581,3 +781,9 @@ RwGsModificationTopazWriterVisitorV2 >> topazFileReference [ ^ self repositoryRootPath / self topazFilename, self filenameExtension ] + +{ #category : 'accessing' } +RwGsModificationTopazWriterVisitorV2 >> traitDefinitions [ + + ^ traitDefinitions ifNil: [ traitDefinitions := Dictionary new ] +] diff --git a/rowan/src/Rowan-TestsV3/RwRowanSample9V3Test.class.st b/rowan/src/Rowan-TestsV3/RwRowanSample9V3Test.class.st index 4401b0f27..1e921d96b 100644 --- a/rowan/src/Rowan-TestsV3/RwRowanSample9V3Test.class.st +++ b/rowan/src/Rowan-TestsV3/RwRowanSample9V3Test.class.st @@ -3526,6 +3526,45 @@ RwRowanSample9V3Test >> testSpec_0085_C03_T03_Tr02 [ description: 'Expected a compile error when loading a trait whose instance variables don''t match the target class'. ] +{ #category : 'tests' } +RwRowanSample9V3Test >> testSpec_0085_export [ + "spec_0085 export traits in topaz format " + + "https://github.com/GemTalk/Rowan/issues/783" + + | loadSpec projectName projectNames loadSpecs loadedProjects trait1 project audit | + loadSpec := self _loadSpecNamed: 'spec_0085'. + + projectName := loadSpec projectName. + projectNames := {projectName }. + + projectNames do: [:pn | + (Rowan image loadedProjectNamed: pn ifAbsent: [ ]) + ifNotNil: [ :proj | Rowan image _removeLoadedProject: proj ] ]. + +"resolve project" + loadSpec customConditionalAttributes: { 'C01' . 'T01' . 'Tr01' }. + loadSpecs := loadSpec resolve. + +"load project: C01, T01, Tr01" + loadedProjects := loadSpecs load. + project := loadedProjects projectNamed: projectName. + +"validate" + self assert: (audit := project audit) isEmpty. + self + _standard_validateLoadedProjects: loadedProjects + expectedProjectNames: projectNames. + + trait1 := Rowan globalNamed: 'RowanSample9V3Trait1'. + self assert: ((ClassOrganizer new traits) includes: trait1) description: 'trait1 is unexpectedly not present'. + + self assert: ((System myUserProfile symbolList dictionaryAndSymbolOf: trait1) at: 1) name equals: #'RowanSample9_1'. + +"export" + project exportTopazFormatTo: 'spec_0085.gs' +] + { #category : 'tests' } RwRowanSample9V3Test >> testSpec_0085_move_trait_to_package [ "spec_0085 C01, T01, Tr01 loaded followed by manual move of a trait to a different package"