Deep copier in its own package

src/BaselineOfMorphicCore/BaselineOfMorphicCore.class.st

@@ -30,6 +30,7 @@ BaselineOfMorphicCore >> baseline: spec [
 			spec package: 'Graphics-Canvas'.
 			spec package: 'FormCanvas-Core'.
 			spec package: 'System-Model'.
+			spec package: 'DeepCopier'.
 			spec package: 'FileSystem-Zip'.
-			spec package: 'Morphic-Core' with: [ spec requires: #( 'System-Model' ) ] ]
+			spec package: 'Morphic-Core' with: [ spec requires: #( 'System-Model' 'DeepCopier') ] ]
 ]

src/System-Model/Array.extension.st → src/DeepCopier/Array.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : 'Array' }
 
-{ #category : '*System-Model' }
+{ #category : '*DeepCopier' }
 Array >> copyWithDependent: newElement [
 
 	self isEmpty ifTrue: [ ^ DependentsArray with: newElement ].

src/System-Model/Boolean.extension.st → src/DeepCopier/Boolean.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : 'Boolean' }
 
-{ #category : '*System-Model' }
+{ #category : '*DeepCopier' }
 Boolean >> veryDeepCopyWith: deepCopier [
 	"Return self.  I can't be copied.  Do not record me."
 ]

src/System-Model/Character.extension.st → src/DeepCopier/Character.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : 'Character' }
 
-{ #category : '*System-Model' }
+{ #category : '*DeepCopier' }
 Character >> veryDeepCopyWith: deepCopier [
 	"Answer the receiver, because Characters are unique."
 	^self

src/System-Model/Collection.extension.st → src/DeepCopier/Collection.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : 'Collection' }
 
-{ #category : '*System-Model' }
+{ #category : '*DeepCopier' }
 Collection >> copyWithDependent: newElement [
 	"Answer a new collection with newElement added (as last
 	element if sequenceable)."

src/System-Model/CompiledMethod.extension.st → src/DeepCopier/CompiledMethod.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : 'CompiledMethod' }
 
-{ #category : '*System-Model' }
+{ #category : '*DeepCopier' }
 CompiledMethod >> veryDeepCopyWith: deepCopier [
 	"Return self.  I am always shared.  Do not record me.  Only use this for blocks.  Normally methodDictionaries should not be copied this way."
 ]

src/System-Model/DeepCopier.class.st → src/DeepCopier/DeepCopier.class.st

@@ -34,10 +34,34 @@ Class {
 	#instVars : [
 		'references'
 	],
-	#category : 'System-Model',
-	#package : 'System-Model'
+	#category : 'DeepCopier',
+	#package : 'DeepCopier'
 }
 
+{ #category : 'accessing' }
+DeepCopier >> at: akey ifAbsent: aBlock [
+
+	^ references at: akey ifAbsent: aBlock
+]
+
+{ #category : 'accessing' }
+DeepCopier >> at: akey ifAbsentPut: aBlock [
+
+	^ references at: akey ifAbsentPut: aBlock
+]
+
+{ #category : 'accessing' }
+DeepCopier >> at: akey ifPresent: aBlock [
+
+	^ references at: akey ifPresent: aBlock
+]
+
+{ #category : 'accessing' }
+DeepCopier >> at: akey put: aValue [
+
+	references at: akey put: aValue
+]
+
 { #category : 'checking' }
 DeepCopier >> basicCheckClass: aClass [
 	"Every class that implements veryDeepInner: or veryDeepCopyWith: must copy all its inst vars.
@@ -88,7 +112,7 @@ DeepCopier >> checkClass: aClass [
 				signal ]
 ]
 
-{ #category : 'like fullCopy' }
+{ #category : 'checking' }
 DeepCopier >> checkDeep [
 	"Write exceptions in the Transcript.  Every class that implements veryDeepInner: must copy all its inst vars.  Danger is that a user will add a new instance variable and forget to copy it.  This check is only run by hand once in a while to make sure nothing was forgotten.
 (Please do not remove this method.)
@@ -112,6 +136,17 @@ DeepCopier >> checkDeep [
 												(aClass allInstVarNames at: index) printOn: stream ] ] ] ] ])
 ]
 
+{ #category : 'copy' }
+DeepCopier >> copyObject: anObject [ 
+
+	| new | 
+	new := anObject veryDeepCopyWith: self.
+	references associationsDo: [ :assoc |
+		assoc value veryDeepFixupWith: self ].
+	self  fixDependents.
+	^ new
+]
+
 { #category : 'checking' }
 DeepCopier >> doesMethod: aSelector writeAllInstanceVariablesOfClass: aClass [
 
@@ -126,7 +161,7 @@ DeepCopier >> doesMethod: aSelector writeAllInstanceVariablesOfClass: aClass [
 	^ hasNoInstanceVariables or: [ method writesField: lastFieldIndex ]
 ]
 
-{ #category : 'like fullCopy' }
+{ #category : 'copy' }
 DeepCopier >> fixDependents [
 	"They are not used much, but need to be right"
 
@@ -156,7 +191,7 @@ DeepCopier >> raiseWarningsIfAny: warnings [
 			signal ]
 ]
 
-{ #category : 'like fullCopy' }
+{ #category : 'accessing' }
 DeepCopier >> references [
 	^ references
 ]

src/DeepCopier/DeepCopierTest.class.st

@@ -0,0 +1,84 @@
+Class {
+	#name : 'DeepCopierTest',
+	#superclass : 'TestCase',
+	#category : 'DeepCopier',
+	#package : 'DeepCopier'
+}
+
+{ #category : 'tests' }
+DeepCopierTest >> testDeepCopyDoubleParentReference [
+
+	| parent child1 child2 copy |
+	parent := DeepCopierTestData new.
+	child1 := DeepCopierTestData new.
+	child2 := DeepCopierTestData new.
+
+	parent refer: { child1 . child2 }.
+	child1 refer: parent. 
+	child2 refer: parent. 
+
+	copy := parent veryDeepCopy.
+
+	"Created a new collection"
+	self assert: copy refer ~= parent refer.
+	self assert: copy refer first class equals: DeepCopierTestData.
+	self assert: copy refer size equals: 2.
+	self assert: copy refer first class equals: parent refer first class.
+
+	self assert: copy refer first refer identicalTo: copy.
+	self assert: copy refer second refer identicalTo: copy.  
+]
+
+{ #category : 'tests' }
+DeepCopierTest >> testDeepCopyOnPoint [
+	"by default do nothing but let us get a test"
+
+	| point copy |
+	point := 100@200.
+	copy := point veryDeepCopy.
+	self assert: point x equals: copy x.
+	self assert: point y equals: copy y.
+]
+
+{ #category : 'tests' }
+DeepCopierTest >> testDeepCopyOnSimpleCycle [
+
+	| cyclic copy |
+	cyclic := DeepCopierTestData aPointsToBThatPointsToA.
+	copy := cyclic veryDeepCopy.
+	self assert: copy refer ~= cyclic refer.
+	self assert: copy refer class equals: DeepCopierTestData.
+	self assert: copy refer class equals: cyclic refer class.
+
+
+	self assert: copy refer refer ~= cyclic refer refer.
+	self assert: copy refer refer class equals: DeepCopierTestData.
+	self assert: copy refer refer class equals: cyclic refer refer class.
+
+	self assert: copy refer refer identicalTo: copy
+
+]
+
+{ #category : 'tests' }
+DeepCopierTest >> testDeepCopyOnTripleCycle [
+
+	| cyclic copy |
+	cyclic := DeepCopierTestData tripleCircle.
+	copy := cyclic veryDeepCopy.
+
+	self assert: copy refer ~= cyclic refer.
+	self assert: copy refer class equals: DeepCopierTestData.
+	self assert: copy refer class equals: cyclic refer class.
+
+
+	self assert: copy refer refer ~= cyclic refer refer.
+	self assert: copy refer refer class equals: DeepCopierTestData.
+	self assert: copy refer refer class equals: cyclic refer refer class.
+
+	self assert: copy refer refer refer ~= cyclic refer refer refer.
+	self assert: copy refer refer refer class equals: DeepCopierTestData.
+	self assert: copy refer refer refer class equals: cyclic refer refer refer class.
+
+	self assert: copy refer refer refer identicalTo: copy
+
+]

src/DeepCopier/DeepCopierTestData.class.st

@@ -0,0 +1,45 @@
+Class {
+	#name : 'DeepCopierTestData',
+	#superclass : 'Object',
+	#instVars : [
+		'refer'
+	],
+	#category : 'DeepCopier',
+	#package : 'DeepCopier'
+}
+
+{ #category : 'samples' }
+DeepCopierTestData class >> aPointsToBThatPointsToA [
+
+	| a b |
+	a := self new. 
+	b := self new.
+	a refer: b.
+	b refer: a.
+	^ a
+]
+
+{ #category : 'samples' }
+DeepCopierTestData class >> tripleCircle [
+
+	| a b c |
+	a := self new. 
+	b := self new.
+	c := self new. 
+	a refer: b.
+	b refer: c.
+	c refer: a.
+	^ a
+]
+
+{ #category : 'accessing' }
+DeepCopierTestData >> refer [
+
+	^ refer 
+]
+
+{ #category : 'accessing' }
+DeepCopierTestData >> refer: anObject [
+
+	refer := anObject 
+]

src/System-Model/Float.extension.st → src/DeepCopier/Float.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : 'Float' }
 
-{ #category : '*System-Model' }
+{ #category : '*DeepCopier' }
 Float >> veryDeepCopyWith: deepCopier [
 	"Return self.  Do not record me."
 

src/System-Model/HashedCollection.extension.st → src/DeepCopier/HashedCollection.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : 'HashedCollection' }
 
-{ #category : '*System-Model' }
+{ #category : '*DeepCopier' }
 HashedCollection >> veryDeepCopyWith: deepCopier [
 	| copyOfSelf|
 	copyOfSelf := super veryDeepCopyWith: deepCopier.

src/DeepCopier/Object.extension.st

@@ -0,0 +1,75 @@
+Extension { #name : 'Object' }
+
+{ #category : '*DeepCopier' }
+Object >> veryDeepCopy [
+	"Do a complete tree copy using a dictionary.  An object in the tree twice is only copied once.  All references to the object in the copy of the tree will point to the new copy."
+
+	^ DeepCopier new copyObject: self. 
+]
+
+{ #category : '*DeepCopier' }
+Object >> veryDeepCopyWith: deepCopier [
+	"Copy me and the entire tree of objects I point to.  An object in the tree twice is copied once, and both references point to him.  deepCopier holds a dictionary of objects we have seen.  Some classes refuse to be copied.  Some classes are picky about which fields get deep copied."
+
+	| class selfNumberOfInstanceVariables fieldOfSelf copyOfSelf currentClass hasVeryDeepInnerMethod currentNumberOfInstanceVariables |
+
+	"already copied" 
+	deepCopier at: self ifPresent: [ :newer | 	^ newer].
+
+	class := self class.
+
+	"Do not copy a metaclase"
+	class isMeta ifTrue: [ ^ self ].
+
+	copyOfSelf := self shallowCopy.
+	deepCopier at: self put: copyOfSelf.
+
+	(class isVariable and: [class isPointers]) ifTrue: [
+		self basicSize to: 1 by: -1 do: [ :i |
+			fieldOfSelf := self basicAt: i.
+			copyOfSelf
+				basicAt: i
+				put: (deepCopier
+					at: fieldOfSelf
+					ifAbsent: [ fieldOfSelf veryDeepCopyWith: deepCopier ])]].
+
+	"Ask each superclass if it wants to share (weak copy) any inst vars"
+	copyOfSelf veryDeepInner: deepCopier.
+
+	"other superclasses want all instance variables deep copied"
+	currentClass := class.
+	selfNumberOfInstanceVariables := class instSize.
+
+	[ selfNumberOfInstanceVariables == 0 ] whileFalse: [
+		hasVeryDeepInnerMethod := currentClass includesSelector: #veryDeepInner:.
+		currentNumberOfInstanceVariables := currentClass instSize - currentClass superclass instSize.
+		hasVeryDeepInnerMethod
+			ifTrue: ["skip inst vars"
+				selfNumberOfInstanceVariables := selfNumberOfInstanceVariables - currentNumberOfInstanceVariables]
+			ifFalse: [
+				currentNumberOfInstanceVariables timesRepeat: [
+					fieldOfSelf := self instVarAt: selfNumberOfInstanceVariables.
+					copyOfSelf
+						instVarAt: selfNumberOfInstanceVariables
+						put: (deepCopier
+							at: fieldOfSelf
+							ifAbsent: [ fieldOfSelf veryDeepCopyWith: deepCopier ]).
+					selfNumberOfInstanceVariables := selfNumberOfInstanceVariables - 1 ]].
+		currentClass := currentClass superclass ].
+
+	^ copyOfSelf
+]
+
+{ #category : '*DeepCopier' }
+Object >> veryDeepFixupWith: deepCopier [
+	"I have no fields and no superclass.  Catch the super call."
+
+	"avoid to use me we will deprecate it in the future"
+]
+
+{ #category : '*DeepCopier' }
+Object >> veryDeepInner: deepCopier [
+	"No special treatment for inst vars of my superclasses.  Override when some need to be weakly copied.  Object>>veryDeepCopyWith: will veryDeepCopy any inst var whose class does not actually define veryDeepInner:"
+
+	"avoid to use me we will deprecate it in the future"
+]

src/System-Model/Point.extension.st → src/DeepCopier/Point.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : 'Point' }
 
-{ #category : '*System-Model' }
+{ #category : '*DeepCopier' }
 Point >> veryDeepCopyWith: deepCopier [
 	"Return self.  I am immutable in the Morphic world.  Do not record me."
 	^ self

src/System-Model/SmallFloat64.extension.st → src/DeepCopier/SmallFloat64.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : 'SmallFloat64' }
 
-{ #category : '*System-Model' }
+{ #category : '*DeepCopier' }
 SmallFloat64 >> veryDeepCopyWith: deepCopier [
 	"Answer the receiver, because SmallFloat64s are unique."
 	^self

src/System-Model/SmallInteger.extension.st → src/DeepCopier/SmallInteger.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : 'SmallInteger' }
 
-{ #category : '*System-Model' }
+{ #category : '*DeepCopier' }
 SmallInteger >> veryDeepCopyWith: deepCopier [
 	"Return self.  I can't be copied.  Do not record me."
 ]

src/System-Model/SmalltalkImage.extension.st → src/DeepCopier/SmalltalkImage.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : 'SmalltalkImage' }
 
-{ #category : '*System-Model' }
+{ #category : '*DeepCopier' }
 SmalltalkImage >> veryDeepCopyWith: deepCopier [
 	"Return self.  I can't be copied.  Do not record me."
 ]

src/System-Model/Symbol.extension.st → src/DeepCopier/Symbol.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : 'Symbol' }
 
-{ #category : '*System-Model' }
+{ #category : '*DeepCopier' }
 Symbol >> veryDeepCopyWith: deepCopier [
 	"Return self.  I am immutable in the Morphic world.  Do not record me."
 ]