Merge pull request #121 from ba-st/gs64_tools

Add extensions and tooling to support transient, invariant and non-persistent GS64 options in Tonel
ba-st · Apr 4, 2024 · a3f98ee · a3f98ee
2 parents de082b1 + 9230fe9
commit a3f98ee
Show file tree

Hide file tree

Showing 10 changed files with 113 additions and 23 deletions.
diff --git a/docs/how-to/how-to-support-gs64-options.md b/docs/how-to/how-to-support-gs64-options.md
@@ -0,0 +1,17 @@
+# How to support GS64 class options
+
+GemStone/S 64 includes some options during class creation that change the
+behavior of instances of that class.
+
+Rowan has support to specify these options using the Tonel format
+by filling the `gs_options` metadata in the class creation section. However,
+Pharo will be default remove this metadata when committing code, which loses these
+options. To avoid this behavior and retain the options, load the `Tool` group
+and send in the class `initialize` message one of the following messages:
+
+- `makeInstancesDbTransient`
+- `makeInstancesInvariant`
+- `makeInstancesNonPersistent`
+
+This will configure the options as class properties in Pharo, which will then be
+used by the Tonel Writer to set these options to the metadata.
diff --git a/source/Buoy-Development-Tools/Behavior.extension.st b/source/Buoy-Development-Tools/Behavior.extension.st
@@ -0,0 +1,17 @@
+Extension { #name : 'Behavior' }
+
+{ #category : '*Buoy-Development-Tools' }
+Behavior >> inspectionGs64Options: builder [
+
+	<inspectorPresentationOrder: 916 title: 'GS64 Options'>
+	^ builder newTable
+		  addColumn: ( SpStringTableColumn title: 'Option' evaluated: [ :option | option ] );
+		  items: ( self propertyAt: #gs_options );
+		  yourself
+]
+
+{ #category : '*Buoy-Development-Tools' }
+Behavior >> inspectionGs64OptionsContext: aContext [
+
+	aContext active: ( self hasProperty: #gs_options )
+]
diff --git a/source/Buoy-Development-Tools/Namespace.extension.st b/source/Buoy-Development-Tools/Namespace.extension.st
@@ -1,20 +1,20 @@
-Extension { #name : #Namespace }
+Extension { #name : 'Namespace' }
 
-{ #category : #'*Buoy-Development-Tools' }
+{ #category : '*Buoy-Development-Tools' }
 Namespace >> gtInspectorItemsIn: composite [
 
 	<gtInspectorPresentationOrder: 0>
 	^ bindings gtInspectorItemsIn: composite
 ]
 
-{ #category : #'*Buoy-Development-Tools' }
+{ #category : '*Buoy-Development-Tools' }
 Namespace >> inspectionItems: builder [
 
 	<inspectorPresentationOrder: 0 title: 'Items'>
 	^ bindings inspectionItems: builder
 ]
 
-{ #category : #'*Buoy-Development-Tools' }
+{ #category : '*Buoy-Development-Tools' }
 Namespace >> spotterForKeysFor: aStep [
 
 	<spotterOrder: 15>

diff --git a/source/Buoy-Development-Tools/TonelWriterV3.extension.st b/source/Buoy-Development-Tools/TonelWriterV3.extension.st
@@ -0,0 +1,26 @@
+Extension { #name : 'TonelWriterV3' }
+
+{ #category : '*Buoy-Development-Tools' }
+TonelWriterV3 >> typeClassDefinitionOf: aClassDefinition [
+
+	| definition |
+	definition := OrderedDictionary new.
+	self
+		at: #name put: aClassDefinition className in: definition;
+		at: #superclass put: aClassDefinition superclassName in: definition.
+	aClassDefinition type = #normal ifFalse: [ self at: #type put: aClassDefinition type in: definition ].
+	aClassDefinition hasTraitComposition ifTrue: [ definition at: #traits put: aClassDefinition traitCompositionString ].
+	aClassDefinition hasClassTraitComposition ifTrue: [ definition at: #classTraits put: aClassDefinition classTraitCompositionString ].
+	aClassDefinition instVarNames ifNotEmpty: [ :vars | definition at: #instVars put: vars asArray ].
+	(aClassDefinition variables
+		 select: #isClassVariable
+		 thenCollect: #name) ifNotEmpty: [ :vars | definition at: #classVars put: vars asArray ].
+	(aClassDefinition variables
+		 select: #isPoolImport
+		 thenCollect: #name) ifNotEmpty: [ :vars | definition at: #pools put: vars asArray ].
+	aClassDefinition classInstVarNames ifNotEmpty: [ :vars | definition at: #classInstVars put: vars asArray ].
+	self setPackageInfoOf: aClassDefinition in: definition.
+	"Write gs_options if available as class properties"
+	(aClassDefinition actualClass propertyAt: #gs_options) ifNotNil: [ :options | definition at: #gs_options put: options ].
+	^ self toSTON: definition
+]
diff --git a/source/Buoy-Development-Tools/package.st b/source/Buoy-Development-Tools/package.st
@@ -1 +1 @@
-Package { #name : #'Buoy-Development-Tools' }
+Package { #name : 'Buoy-Development-Tools' }
diff --git a/source/Buoy-Metaprogramming-Pharo-Extensions/Behavior.extension.st b/source/Buoy-Metaprogramming-Pharo-Extensions/Behavior.extension.st
@@ -1,6 +1,6 @@
-Extension { #name : #Behavior }
+Extension { #name : 'Behavior' }
 
-{ #category : #'*Buoy-Metaprogramming-Pharo-Extensions' }
+{ #category : '*Buoy-Metaprogramming-Pharo-Extensions' }
 Behavior >> allLeafSubclasses [
 
 	| leafs |
@@ -9,3 +9,32 @@ Behavior >> allLeafSubclasses [
 	self allSubclassesDo: [ :class | class subclasses ifEmpty: [ leafs add: class ] ].
 	^ leafs
 ]
+
+{ #category : '*Buoy-Metaprogramming-Pharo-Extensions' }
+Behavior >> makeInstancesDbTransient [
+	"In GS64 instances of classes that are DbTransient can be committed — that is, there is no error if they are committed — 
+	but their instance variables are not written to disk.
+
+	These properties are written later by our version of the TonelWriterV3"
+
+	self propertyAt: #gs_options put: #( 'dbTransient' )
+]
+
+{ #category : '*Buoy-Metaprogramming-Pharo-Extensions' }
+Behavior >> makeInstancesInvariant [
+	"In GS64 instances of this class will be made invariant as soon as they are committed.
+
+	These properties are written later by our version of the TonelWriterV3"
+
+	self propertyAt: #gs_options put: #( 'instancesInvariant' )
+]
+
+{ #category : '*Buoy-Metaprogramming-Pharo-Extensions' }
+Behavior >> makeInstancesNonPersistent [
+	"In GS64 instances of this class cannot be committed, so you cannot include references to
+	instances of non-persistent classes within a persistent data structure.
+
+	These properties are written later by our version of the TonelWriterV3"
+
+	self propertyAt: #gs_options put: #( 'instancesNonPersistent' )
+]
diff --git a/source/Buoy-Metaprogramming-Pharo-Extensions/OSPlatform.extension.st b/source/Buoy-Metaprogramming-Pharo-Extensions/OSPlatform.extension.st
@@ -1,6 +1,6 @@
-Extension { #name : #OSPlatform }
+Extension { #name : 'OSPlatform' }
 
-{ #category : #'*Buoy-Metaprogramming-Pharo-Extensions' }
+{ #category : '*Buoy-Metaprogramming-Pharo-Extensions' }
 OSPlatform >> environmentAt: aVariableName ifPresent: aBlock ifAbsent: anAbsentBlock [
 
 	^ self environment
@@ -9,13 +9,13 @@ OSPlatform >> environmentAt: aVariableName ifPresent: aBlock ifAbsent: anAbsentB
 		  ifAbsent: anAbsentBlock
 ]
 
-{ #category : #'*Buoy-Metaprogramming-Pharo-Extensions' }
+{ #category : '*Buoy-Metaprogramming-Pharo-Extensions' }
 OSPlatform >> environmentAt: variableName put: value [
 
 	self environment at: variableName put: value
 ]
 
-{ #category : #'*Buoy-Metaprogramming-Pharo-Extensions' }
+{ #category : '*Buoy-Metaprogramming-Pharo-Extensions' }
 OSPlatform >> removeEnvironmentKey: variableName [
 
 	self environment removeKey: variableName

diff --git a/source/Buoy-Metaprogramming-Pharo-Extensions/PharoPlatform.class.st b/source/Buoy-Metaprogramming-Pharo-Extensions/PharoPlatform.class.st
@@ -1,41 +1,42 @@
 Class {
-	#name : #PharoPlatform,
-	#superclass : #LanguagePlatform,
-	#category : #'Buoy-Metaprogramming-Pharo-Extensions'
+	#name : 'PharoPlatform',
+	#superclass : 'LanguagePlatform',
+	#category : 'Buoy-Metaprogramming-Pharo-Extensions',
+	#package : 'Buoy-Metaprogramming-Pharo-Extensions'
 }
 
-{ #category : #'class initialization' }
+{ #category : 'class initialization' }
 PharoPlatform class >> initialize [
 
 	<ignoreForCoverage>
 	LanguagePlatform setCurrentTo: self new
 ]
 
-{ #category : #reflection }
+{ #category : 'reflection' }
 PharoPlatform >> atInstanceVariableNamed: name on: object put: value [
 
 	object instVarNamed: name put: value
 ]
 
-{ #category : #'process scheduling' }
+{ #category : 'process scheduling' }
 PharoPlatform >> fork: block named: processName at: priority [
 
 	^ block forkAt: priority named: processName
 ]
 
-{ #category : #reflection }
+{ #category : 'reflection' }
 PharoPlatform >> globalNamed: aSymbol ifAbsent: absentBlock [
 
 	^ Smalltalk globals at: aSymbol ifAbsent: absentBlock
 ]
 
-{ #category : #reflection }
+{ #category : 'reflection' }
 PharoPlatform >> includesGlobalNamed: aSymbol [
 
 	^ Smalltalk globals includesKey: aSymbol
 ]
 
-{ #category : #accessing }
+{ #category : 'accessing' }
 PharoPlatform >> os [
 
 	^ OSPlatform current

diff --git a/source/Buoy-Metaprogramming-Pharo-Extensions/Symbol.extension.st b/source/Buoy-Metaprogramming-Pharo-Extensions/Symbol.extension.st
@@ -1,6 +1,6 @@
-Extension { #name : #Symbol }
+Extension { #name : 'Symbol' }
 
-{ #category : #'*Buoy-Metaprogramming-Pharo-Extensions' }
+{ #category : '*Buoy-Metaprogramming-Pharo-Extensions' }
 Symbol >> argumentCount [
 
 	^self numArgs

diff --git a/source/Buoy-Metaprogramming-Pharo-Extensions/package.st b/source/Buoy-Metaprogramming-Pharo-Extensions/package.st
@@ -1 +1 @@
-Package { #name : #'Buoy-Metaprogramming-Pharo-Extensions' }
+Package { #name : 'Buoy-Metaprogramming-Pharo-Extensions' }