Better support for updating existing pre-generated metamodels

src/Famix-MetamodelBuilder-Core/FamixMetamodelGenerator.class.st

@@ -58,6 +58,16 @@ FamixMetamodelGenerator class >> composedMetaModels [
 	^ self allSubclasses select: [ :mm | mm isAbstract not and: [ mm isComposed ] ]
 ]
 
+{ #category : #generation }
+FamixMetamodelGenerator class >> deleteMetaModel [
+	<script>
+	<ignoreForCoverage>
+
+	"Remove the package that was generated by this generator.
+	This is used to cleanup existing code and testing"
+	self packageName asPackage removeFromSystem
+]
+
 { #category : #generation }
 FamixMetamodelGenerator class >> generate [
 	<script>

src/Famix-MetamodelBuilder-Core/FmxClassRemoval.class.st

@@ -47,6 +47,12 @@ FmxClassRemoval >> classToRemove: anObject [
 	class := anObject
 ]
 
+{ #category : #testing }
+FmxClassRemoval >> isRemoval [
+
+	^ true
+]
+
 { #category : #printing }
 FmxClassRemoval >> printOn: aStream [
 

src/Famix-MetamodelBuilder-Core/FmxCodeChange.class.st

@@ -28,3 +28,9 @@ FmxCodeChange class >> isAbstract [
 FmxCodeChange >> apply [
 	self subclassResponsibility
 ]
+
+{ #category : #testing }
+FmxCodeChange >> isRemoval [
+
+	^ false
+]

src/Famix-MetamodelBuilder-Core/FmxMBRealRingEnvironment.class.st

@@ -9,8 +9,10 @@ Class {
 
 { #category : #accessing }
 FmxMBRealRingEnvironment >> apply [
+
 	self collectChangesToApply.
-	changesToApply do: #apply
+	changesToApply select: [ :e | e isRemoval ] thenDo: #apply.
+	changesToApply select: [ :e | e isRemoval not ] thenDo: #apply
 ]
 
 { #category : #testing }
@@ -41,25 +43,48 @@ FmxMBRealRingEnvironment >> compile: aSource in: aClass classified: aProtocol pa
 ]
 
 { #category : #installing }
-FmxMBRealRingEnvironment >> recordAdoptionOfClassDefinitionFrom: realClass to: anRGClass [
+FmxMBRealRingEnvironment >> recordAdoptionOfClassDefinitionFrom: currentClass to: anRGClassModel [
+
+	| currentCustomSlots currentCustomSlotNames modelSlotDefinitions currentGeneratedSlots modelGeneratedSlots slotRemovals |
+	(currentClass needToAdaptTo: anRGClassModel) ifFalse: [ ^ self ].
+
+	"We are updating a class installed in the system (currentClass) to a new representation defined in the model (anRGClass).
+	This has to be done in order to allow updating the class at run time"
+
+	currentGeneratedSlots := currentClass generatedSlots.
+	currentCustomSlots := currentClass localSlots copyWithoutAll:
+		                      currentGeneratedSlots.
+	currentCustomSlotNames := currentCustomSlots collect: #name.
+
+	modelGeneratedSlots := anRGClassModel slots reject: [ :each |
+		                       currentCustomSlotNames includes: each name ].
+
+	modelSlotDefinitions := (modelGeneratedSlots collect:
+		                         #definitionString) asOrderedCollection.
+	modelSlotDefinitions addAll:
+		(currentCustomSlots collect: #definitionString).
+	modelSlotDefinitions := modelSlotDefinitions sorted.
 
-	| customSlots customSlotNames slotDefinitions |
-	(realClass needToAdaptTo: anRGClass) ifFalse: [ ^ self ].
+	slotRemovals := currentGeneratedSlots reject: [ :e |
+		                modelGeneratedSlots anySatisfy: [ :current |
+			                current name = e name ] ].
 
-	customSlots := realClass localSlots copyWithoutAll: realClass generatedSlots.
-	customSlotNames := customSlots collect: #name.
-	slotDefinitions := ((anRGClass slots reject: [ :each | customSlotNames includes: each name ]) collect: #definitionString) asOrderedCollection.
-	slotDefinitions addAll: (customSlots collect: #definitionString).
-	slotDefinitions := slotDefinitions sorted.
+	slotRemovals ifNotEmpty: [
+		changesToApply add: (FmxSlotRemovals slots: slotRemovals) ].
 
 	self
-		recordClassAdditionFromClass: anRGClass
-		traits: (self traitStringFrom: realClass to: anRGClass)
-		slots: '{' , (slotDefinitions joinUsing: '. ') , '}'
-		classSlots: '{' , ((realClass class localSlots collect: #definitionString) joinUsing: ' . ') , '}'
-		sharedVariables: '{' , ((realClass classVarNames collect: [ :each | '#' , each ]) joinUsing: ' ') , '}'
-		package: realClass package name
-		tag: realClass packageTag name
+		recordClassAdditionFromClass: anRGClassModel
+		traits: (self traitStringFrom: currentClass to: anRGClassModel)
+		slots: '{' , (modelSlotDefinitions joinUsing: '. ') , '}'
+		classSlots:
+			'{' , ((currentClass class localSlots collect: #definitionString)
+				 joinUsing: ' . ') , '}'
+		sharedVariables:
+			'{'
+			, ((currentClass classVarNames collect: [ :each | '#' , each ])
+					 joinUsing: ' ') , '}'
+		package: currentClass package name
+		tag: currentClass packageTag name
 ]
 
 { #category : #installing }

src/Famix-MetamodelBuilder-Core/FmxMethodRemovals.class.st

@@ -41,6 +41,12 @@ FmxMethodRemovals >> apply [
 	self selectors do: [ :selector | class removeSelector: selector ]
 ]
 
+{ #category : #testing }
+FmxMethodRemovals >> isRemoval [
+
+	^ true
+]
+
 { #category : #accessing }
 FmxMethodRemovals >> selectors [
 	^ selectors

src/Famix-MetamodelBuilder-Core/FmxSlotRemovals.class.st

@@ -0,0 +1,47 @@
+"
+Description
+--------------------
+
+I represent a the removal of slots from a class when updating an already generated metamodel.
+
+"
+Class {
+	#name : #FmxSlotRemovals,
+	#superclass : #FmxCodeChange,
+	#instVars : [
+		'slots'
+	],
+	#category : #'Famix-MetamodelBuilder-Core-Changes'
+}
+
+{ #category : #'as yet unclassified' }
+FmxSlotRemovals class >> slots: aCollection [
+
+	^ self new
+		  slots: aCollection;
+		  yourself
+]
+
+{ #category : #accessing }
+FmxSlotRemovals >> apply [
+
+	slots do: [ :e | e owningClass removeInstVarNamed: e name  ]
+]
+
+{ #category : #testing }
+FmxSlotRemovals >> isRemoval [
+
+	^ true
+]
+
+{ #category : #accessing }
+FmxSlotRemovals >> slots [
+
+	^ slots
+]
+
+{ #category : #accessing }
+FmxSlotRemovals >> slots: anObject [
+
+	slots := anObject
+]

src/Famix-TestGenerators/FamixTest9BisGenerator.class.st

@@ -0,0 +1,24 @@
+Class {
+	#name : #FamixTest9BisGenerator,
+	#superclass : #FamixTest9Generator,
+	#category : #'Famix-TestGenerators'
+}
+
+{ #category : #accessing }
+FamixTest9BisGenerator class >> packageName [
+
+	^ #'Famix-Test9-Entities'
+]
+
+{ #category : #accessing }
+FamixTest9BisGenerator class >> prefix [
+
+	^ #'FamixTest9'
+]
+
+{ #category : #definition }
+FamixTest9BisGenerator >> defineRelations [
+
+	"Here everything is the same except for the entities on the relation"
+	subclass *- superclass
+]

src/Famix-TestGenerators/FamixTest9Generator.class.st

@@ -0,0 +1,47 @@
+Class {
+	#name : #FamixTest9Generator,
+	#superclass : #FamixBasicInfrastructureGenerator,
+	#instVars : [
+		'superclass',
+		'subclass'
+	],
+	#category : #'Famix-TestGenerators'
+}
+
+{ #category : #accessing }
+FamixTest9Generator class >> packageName [
+
+	^ #'Famix-Test9-Entities'
+]
+
+{ #category : #accessing }
+FamixTest9Generator class >> prefix [
+
+	^ #'FamixTest9'
+]
+
+{ #category : #testing }
+FamixTest9Generator class >> shouldBeUpToDateInLatestMoose [
+
+	"This generator is used dynamically by the tests"
+	^ false
+]
+
+{ #category : #definition }
+FamixTest9Generator >> defineClasses [
+
+	superclass := self builder newClassNamed: #MySuperclass.
+	subclass := self builder newClassNamed: #MySubclass
+]
+
+{ #category : #definition }
+FamixTest9Generator >> defineHierarchy [
+
+	subclass --|> superclass
+]
+
+{ #category : #definition }
+FamixTest9Generator >> defineRelations [
+
+	subclass *- subclass
+]