Cached Mementos - To Copy or Not To Copy?

source/Magritte-Model/MACachedMemento.class.st

@@ -27,23 +27,11 @@ MACachedMemento >> commit [
 	self reset
 ]
 
-{ #category : #private }
-MACachedMemento >> cookRawPull: aDictionary [
-
-	super cookRawPull: aDictionary.
-	aDictionary keysAndValuesDo: [ :key :value |
-		| isCollectionOfRelations |
-		self flag: 'duplicate logic with cookRawPull:'.
-		isCollectionOfRelations := value isCollection and: [ key isKindOf: MAToManyRelationDescription ].
-		isCollectionOfRelations ifTrue: [ 
-			aDictionary at: key put: value copy ] ].
-]
-
 { #category : #testing }
 MACachedMemento >> hasChanges [
 	"Answer ==true==, if the cached data is different to the data in the model."
 
-	^ self isDifferent: self cache to: self pullRaw
+	^ self has: self cache changedFrom: self pullRaw
 ]
 
 { #category : #private }

source/Magritte-Model/MACheckedMemento.class.st

@@ -19,7 +19,7 @@ MACheckedMemento >> hasConflict [
 
 { #category : #testing }
 MACheckedMemento >> hasModelChangedElsewhere [
-	^ self isDifferent: self original to: self pullRaw
+	^ self has: self original changedFrom: self pullRaw
 ]
 
 { #category : #accessing }
@@ -29,10 +29,24 @@ MACheckedMemento >> original [
 
 { #category : #actions }
 MACheckedMemento >> reset [
+
+	| dict |
 	super reset.
-	self setOriginal: (self pullRawTransforming: [ :e | e copy ]).
 
-	"Implementation note: We copy the field values because checked mementos compare this to the current object to see if it has changed elsewhere. Unless we make a copy each time, this comparison would not be possible for complex objects, because any changes to them from outside will be reflected equally in this `original` dictionary. E.g. if `original at: #person == self model person` and outside someone does `self model person age: 25`, the check above would pass even though it should fail."
+	dict := self pullRawTransforming: [ :value :desc |
+		| isCollectionOfRelations |
+		isCollectionOfRelations := value isCollection and: [ (desc isKindOf: MAReferenceDescription) and: [ desc isMultiple ] ].
+		isCollectionOfRelations 
+			ifTrue: [ value copy ]
+			ifFalse: [ value ] ].
+
+	self setOriginal: dict.
+
+	"Implementation note: We copy some field values because checked mementos compare them to the current object to see if it has changed elsewhere. If a field references a collection, and we hold onto that actual collection, and the elements in the collection are changed from the outside, our 'original' will also change and validation will never fail and so offers no protection. We limit the copying to just this case because copying can cause other unforeseen problems.
+
+	One example is illustrated in MAMementoTest>>testSingletonValue.
+
+	Another is that we had at one time done the copying in MACachedMemento>>#cookPullRaw:, but it proved too dangerous because the *cache* also contained copies, not just the *original* as here. For example (ignoring the question of whether this is good design), what if the model required that a field point to a *particular* collection? We might replace that particular collection with a copy, which then goes out of sync with the 'real' collection. Now, outside changes also 'bleed' into caches, but it seems not to matter. If a user was worried about outside changes, they would use an MACheckedMemento which would flag the problem during validation, not an MACachedMemento. Choosing a cached memento means we are specifically *not* checking for whether the model has changed elsewhere. Since the cache is changing with the model, there will be nothing to commit unless we explicitly change the field in the memento, which seems like the expected behavior."
 ]
 
 { #category : #initialization }
@@ -43,10 +57,13 @@ MACheckedMemento >> setOriginal: aDictionary [
 { #category : #'private-testing' }
 MACheckedMemento >> shouldPush: anObject using: aDescription [
 
-	| originalValue cachedValue |
+	| originalValue cachedValue didChangeHere |
 	originalValue := self original at: aDescription.
 	cachedValue := self cache at: aDescription.
-	^ (originalValue = cachedValue) not and: [ super shouldPush: anObject using: aDescription ]
+
+	didChangeHere := aDescription shouldWrite: cachedValue over: originalValue.
+
+	^ didChangeHere and: [ super shouldPush: anObject using: aDescription ]
 ]
 
 { #category : #actions }

source/Magritte-Model/MAElementDescription.class.st

@@ -121,6 +121,34 @@ MAElementDescription >> printFor: anObject on: aWriteStream [
 	(self read: anObject) ifNotNil: [ :value | aWriteStream nextPutAll: (self toString: value) ]
 ]
 
+{ #category : #utility }
+MAElementDescription >> shouldWrite: anObject over: anotherObject [
+
+	| defaultValues areBothDefaultValues isIgnorableDefault |
+
+	self isVisible ifFalse: [ ^ false ].
+	self isReadOnly ifTrue: [ ^ false ].
+
+	defaultValues := OrderedCollection
+		with: nil
+		with: self undefinedValue.
+
+	isIgnorableDefault := self shouldCacheDefault not and: [ anObject = self default ].
+	isIgnorableDefault ifTrue: [ defaultValues add: self default ].
+
+	areBothDefaultValues := { anObject. anotherObject } allSatisfy: [ :obj | defaultValues includes: obj ].
+
+	areBothDefaultValues ifTrue: [ ^ false ].
+	(anObject == anotherObject or: [ anObject = anotherObject ])
+		ifTrue: [ ^ false ].
+
+	^ true
+
+	"Implementation note: We compare via both #== and #= to cover two scenarios:
+		1) a referenced object that changes on the outside. From our perspective, as long as we are still refering to the same object there is no relevant change. Unless we accept identity equality, any changes to complex objects from outside will bleed into this object. E.g. if outside someone does `self person age: 25`, this object will appear to be changed. This would wreak havoc with mementos, forms, etc.
+		2) objects (e.g. strings and other value objects) that override #= to mean something other than identity comparison."
+]
+
 { #category : #printing }
 MAElementDescription >> storeOn: aStream [
 	aStream 

source/Magritte-Model/MAMemento.class.st

@@ -35,10 +35,13 @@ MAMemento >> commit [
 
 { #category : #private }
 MAMemento >> cookRawPull: aDictionary [
+	"The reason for the somewhat cryptic message name is that each subclass is free to perform any needed actions. Here we just replace undefinedValues with default values"
 
-	aDictionary keysAndValuesDo: [ :key :value |
-		value isNil
-			ifTrue: [ aDictionary at: key put: key default yourself ] ]
+	aDictionary keysAndValuesDo: [ :elemDescription :value |
+		value = elemDescription undefinedValue ifTrue: [ 
+			aDictionary 
+				at: elemDescription 
+				put: elemDescription default ] ]
 ]
 
 { #category : #'reflective operations' }
@@ -50,13 +53,14 @@ MAMemento >> doesNotUnderstand: aMessage [
 ]
 
 { #category : #private }
-MAMemento >> isDifferent: firstDictionary to: secondDictionary [
-	| firstValue secondValue |
-	self magritteDescription do: [ :each |
-		(each isVisible and: [ each isReadOnly not ]) ifTrue: [
-			firstValue := firstDictionary at: each ifAbsent: [ nil ].
-			secondValue := secondDictionary at: each ifAbsent: [ nil ].
-			firstValue = secondValue ifFalse: [ ^ true ] ] ].
+MAMemento >> has: firstDictionary changedFrom: secondDictionary [
+
+	self magritteDescription do: [ :desc |
+		| firstValue secondValue hasFieldChanged |
+		firstValue := firstDictionary at: desc ifAbsent: [ nil ].
+		secondValue := secondDictionary at: desc ifAbsent: [ nil ].
+		hasFieldChanged := desc shouldWrite: firstValue over: secondValue.
+		hasFieldChanged ifTrue: [ ^ true ] ].
 	^ false
 ]
 
@@ -97,11 +101,11 @@ MAMemento >> pullRaw [
 MAMemento >> pullRawTransforming: aBlock [
 	| result |
 	result := Dictionary new.
-	self magritteDescription do: [ :each |
+	self magritteDescription do: [ :elemDescription |
 		| value transformedValue |
-		value := self model readUsing: each.
-		transformedValue := aBlock value: value.
-		result at: each put: transformedValue ].
+		value := self model readUsing: elemDescription.
+		transformedValue := aBlock cull: value cull: elemDescription.
+		result at: elemDescription put: transformedValue ].
 	^ result
 ]
 
@@ -136,7 +140,10 @@ MAMemento >> setModel: aModel [
 
 { #category : #'private-testing' }
 MAMemento >> shouldPush: anObject using: aDescription [
-	^ aDescription isVisible and: [ aDescription isReadOnly not ]
+
+	| modelValue |
+	modelValue := self model readUsing: aDescription.
+	^ aDescription shouldWrite: anObject over: modelValue.
 ]
 
 { #category : #actions }

source/Magritte-Model/MAOptionDescription.class.st

@@ -133,11 +133,6 @@ MAOptionDescription >> isExtensible [
 	^ self extensible
 ]
 
-{ #category : #testing }
-MAOptionDescription >> isMultiple [
-	^false
-]
-
 { #category : #testing }
 MAOptionDescription >> isSorted [
 	^ self sorted

source/Magritte-Model/MAReferenceDescription.class.st

@@ -112,6 +112,11 @@ MAReferenceDescription >> initializer: valuable [
 	self propertyAt: #initializer put: valuable
 ]
 
+{ #category : #testing }
+MAReferenceDescription >> isMultiple [
+	^false
+]
+
 { #category : #copying }
 MAReferenceDescription >> postCopy [
 	super postCopy.

source/Magritte-Model/MAStraightMemento.class.st

@@ -4,7 +4,7 @@ I am a memento that forwards read- and write-access directly to the model. I can
 Class {
 	#name : #MAStraightMemento,
 	#superclass : #MAMemento,
-	#category : 'Magritte-Model-Memento'
+	#category : #'Magritte-Model-Memento'
 }
 
 { #category : #testing }
@@ -20,5 +20,6 @@ MAStraightMemento >> readUsing: aDescription [
 
 { #category : #private }
 MAStraightMemento >> write: anObject using: aDescription [
+	(self shouldPush: anObject using: aDescription) ifFalse: [ ^ self ].
 	self model write: anObject using: aDescription
 ]

source/Magritte-Model/MAToManyRelationDescription.class.st

@@ -129,6 +129,11 @@ MAToManyRelationDescription >> isDefinitive [
 	^ self definitive.
 ]
 
+{ #category : #accessing }
+MAToManyRelationDescription >> isMultiple [
+	^true
+]
+
 { #category : #testing }
 MAToManyRelationDescription >> isOrdered [
 	^ self ordered

source/Magritte-Tests-Model/MACheckedMementoTest.class.st

@@ -80,3 +80,26 @@ MACheckedMementoTest >> testValidateConflictReset [
 	self memento reset.
 	self shouldnt: [ self memento validate ] raise: MAValidationError
 ]
+
+{ #category : #'tests-actions' }
+MACheckedMementoTest >> testValidateFailsOnReferencedCollectionChange [
+
+	| occupants obj |
+	occupants := #(Bill Fred) asOrderedCollection.
+
+	obj := MAMockAddress new
+		occupants: occupants;
+		yourself.
+
+	memento := self actualClass
+		model: obj
+		description: obj magritteDescription.
+
+	"Field-referenced collection changes outside of memento"
+	obj occupants add: 'Jim'.
+
+	"Now we change the same field via the memento"
+	memento write: #(Tom) using: obj occupantsDescription.
+
+	self should: [ memento validate ] raise: MAConflictError.
+]

source/Magritte-Tests-Model/MADescriptionBuilderTest.class.st

@@ -1,7 +1,7 @@
 Class {
 	#name : #MADescriptionBuilderTest,
 	#superclass : #TestCase,
-	#category : 'Magritte-Tests-Model-Utility'
+	#category : #'Magritte-Tests-Model-Utility'
 }
 
 { #category : #'acessing-magritte' }
@@ -85,7 +85,7 @@ MADescriptionBuilderTest >> testExtension [
 MADescriptionBuilderTest >> testNilled [
 	| description |
 	description := MAMockAddress new magritteDescription.
-	self assert: description size = 3
+	self assert: description size = 5
 ]
 
 { #category : #tests }

source/Magritte-Tests-Model/MAMementoTest.class.st

@@ -6,7 +6,7 @@ Class {
 		'value',
 		'description'
 	],
-	#category : 'Magritte-Tests-Model-Memento'
+	#category : #'Magritte-Tests-Model-Memento'
 }
 
 { #category : #testing }
@@ -94,6 +94,31 @@ MAMementoTest >> setUp [
 	memento := self mementoInstance
 ]
 
+{ #category : #'tests-actions' }
+MAMementoTest >> testCachedDefaultValues [
+
+	| obj plzDescription |
+	obj := MAMockAddress new.
+
+	memento := self actualClass
+		model: obj
+		description: obj magritteDescription.
+
+	memento := self actualClass
+		model: obj
+		description: obj magritteDescription.
+
+	plzDescription := obj descriptionPlz
+		default: 1;
+		shouldCacheDefault: true;
+		yourself.
+
+	memento push: {
+		plzDescription -> plzDescription default } asDictionary.
+
+	self assert: obj plz equals: plzDescription default
+]
+
 { #category : #'tests-actions' }
 MAMementoTest >> testCommit [
 	self subclassResponsibility
@@ -120,6 +145,41 @@ MAMementoTest >> testReset [
 	self subclassResponsibility
 ]
 
+{ #category : #'tests-actions' }
+MAMementoTest >> testSingletonValue [
+
+	| obj |
+	obj := MAMockAddress new
+		plzType: Number;
+		yourself.
+
+	memento := obj mementoClass
+		model: obj
+		description: obj magritteDescription.
+
+	self assert: (memento original at: obj plzTypeDescription) == obj plzType.
+]
+
+{ #category : #'tests-actions' }
+MAMementoTest >> testUncachedDefaultValues [
+
+	| obj plzDescription |
+	obj := MAMockAddress new.
+
+	memento := self actualClass
+		model: obj
+		description: obj magritteDescription.
+
+	plzDescription := obj descriptionPlz
+		default: 1;
+		yourself.
+
+	memento push: {
+		plzDescription -> plzDescription default } asDictionary.
+
+	self assert: obj plz equals: nil
+]
+
 { #category : #'tests-actions' }
 MAMementoTest >> testValidateIncluded [
 	self write: self includedInstance.