Introduction a combinator for continuations and a test case concernin…

…g the message #remove:oneStar: that uses it.
pharo-project · Jan 15, 2020 · a693458 · a693458
1 parent 02153f2
commit a693458
Show file tree

Hide file tree

Showing 2 changed files with 246 additions and 0 deletions.
diff --git a/src/Kernel-Tests/ContinuationTest.class.st b/src/Kernel-Tests/ContinuationTest.class.st
@@ -139,6 +139,116 @@ ContinuationTest >> leftmost: aBlock tree: aTree continuation: out [
 						ifTrue: [ out value: v ] ] ]
 ]
 
+{ #category : #printing }
+ContinuationTest >> printStringOfTree: aValueLink [
+	^ String
+		streamContents: [ :aStream | self printStringOfTree: aValueLink onStream: aStream ]
+]
+
+{ #category : #printing }
+ContinuationTest >> printStringOfTree: aValueLink onStream: aStream [
+	| cell |
+	aStream nextPut: $(.
+	cell := aValueLink.
+	[ | car |
+	car := cell value.
+	car class = ValueLink
+		ifTrue: [ self printStringOfTree: car onStream: aStream ]
+		ifFalse: [ car printOn: aStream ].
+	cell nextLink ifNotNil: [ aStream nextPut: Character space ].
+	cell := cell nextLink.
+	cell class = ValueLink ] whileTrue.
+	cell
+		ifNotNil: [ aStream
+				nextPut: $.;
+				nextPut: Character space.
+			cell printOn: aStream ].
+	aStream nextPut: $)
+]
+
+{ #category : #removing }
+ContinuationTest >> remove: anObj oneStar: aTree [
+	| newTree sentinel |
+	sentinel := #absent.
+	newTree := self
+		callcc: [ :oh | 
+			self
+				remove: anObj
+				oneStar: aTree
+				sentinel: sentinel
+				continuation: oh ].
+	^ newTree = sentinel
+		ifTrue: [ aTree ]
+		ifFalse: [ newTree ]
+]
+
+{ #category : #removing }
+ContinuationTest >> remove: anObj oneStar: aTree sentinel: aSymbol continuation: oh [
+	^ aTree
+		ifNil: [ oh value: aSymbol ]
+		ifNotNil: [ | v nl naturalRecursion |
+			v := aTree value.
+			nl := aTree nextLink.
+			naturalRecursion := [ ValueLink new
+				value: v;
+				nextLink:
+					(self
+						remove: anObj
+						oneStar: nl
+						sentinel: aSymbol
+						continuation: oh);
+				yourself ].
+			v class = ValueLink
+				ifTrue: [ | car |
+					car := self
+						callcc: [ :ooh | 
+							self
+								remove: anObj
+								oneStar: v
+								sentinel: aSymbol
+								continuation: ooh ].
+					car = aSymbol
+						ifTrue: naturalRecursion
+						ifFalse: [ ValueLink new
+								value: car;
+								nextLink: nl;
+								yourself ] ]
+				ifFalse: [ anObj = v
+						ifTrue: [ nl ]
+						ifFalse: naturalRecursion ] ]
+]
+
+{ #category : #removing }
+ContinuationTest >> remove: anObj oneStarWithTry: aTree [
+	^ Continuation
+		try: [ :oh | self remove: anObj oneStarWithTry: aTree continuation: oh ]
+		otherwise: [ aTree ]
+]
+
+{ #category : #removing }
+ContinuationTest >> remove: anObj oneStarWithTry: aTree continuation: oh [
+	^ aTree
+		ifNil: [ oh value: #absent ]
+		ifNotNil: [ | v nl naturalRecursion |
+			v := aTree value.
+			nl := aTree nextLink.
+			naturalRecursion := [ ValueLink new
+				value: v;
+				nextLink: (self remove: anObj oneStarWithTry: nl continuation: oh);
+				yourself ].
+			v class = ValueLink
+				ifTrue: [ Continuation
+						try: [ :ooh | 
+							ValueLink new
+								value: (self remove: anObj oneStarWithTry: v continuation: ooh);
+								nextLink: nl;
+								yourself ]
+						otherwise: naturalRecursion ]
+				ifFalse: [ anObj = v
+						ifTrue: [ nl ]
+						ifFalse: naturalRecursion ] ]
+]
+
 { #category : #'as yet unclassified' }
 ContinuationTest >> remove: anObj uptoLast: aLinkedList [
 	^ aLinkedList
@@ -337,6 +447,102 @@ ContinuationTest >> testReentrant [
 		ifFalse: [ assoc key value: assoc ]
 ]
 
+{ #category : #removing }
+ContinuationTest >> testRemoveOneStar [
+	| tree1 tree2 |
+	tree1 := ValueLink new
+		value:
+			(ValueLink new
+				value: #Swedish;
+				nextLink:
+					(ValueLink new
+						value: #rye;
+						yourself);
+				yourself);
+		nextLink:
+			(ValueLink new
+				value:
+					(ValueLink new
+						value: #French;
+						nextLink:
+							(ValueLink new
+								value:
+									(ValueLink new
+										value: #mustard;
+										nextLink:
+											(ValueLink new
+												value: #salad;
+												nextLink:
+													(ValueLink new
+														value: #turkey;
+														yourself);
+												yourself);
+										yourself);
+								yourself);
+						yourself);
+				nextLink:
+					(ValueLink new
+						value: #salad;
+						yourself);
+				yourself);
+		yourself.
+	tree2 := ValueLink new
+		value:
+			(ValueLink new
+				value: #pasta;
+				nextLink:
+					(ValueLink new
+						value: #meat;
+						yourself);
+				yourself);
+		nextLink:
+			(ValueLink new
+				value: #pasta;
+				nextLink:
+					(ValueLink new
+						value:
+							(ValueLink new
+								value: #noodles;
+								nextLink:
+									(ValueLink new
+										value: #meat;
+										nextLink:
+											(ValueLink new
+												value: #sauce;
+												yourself);
+										yourself);
+								yourself);
+						nextLink:
+							(ValueLink new
+								value: #meat;
+								nextLink:
+									(ValueLink new
+										value: #tomatoes;
+										yourself);
+								yourself);
+						yourself);
+				yourself);
+		yourself.
+	self
+		assert: (self printStringOfTree: tree1)
+		equals: '((#Swedish #rye) (#French (#mustard #salad #turkey)) #salad)'.
+	self
+		assert: (self printStringOfTree: tree2)
+		equals: '((#pasta #meat) #pasta (#noodles #meat #sauce) #meat #tomatoes)'.
+	self
+		assert: (self printStringOfTree: (self remove: #salad oneStar: tree1))
+		equals: '((#Swedish #rye) (#French (#mustard #turkey)) #salad)'.
+	self
+		assert: (self printStringOfTree: (self remove: #salad oneStarWithTry: tree1))
+		equals: '((#Swedish #rye) (#French (#mustard #turkey)) #salad)'.
+	self
+		assert: (self printStringOfTree: (self remove: #meat oneStar: tree2))
+		equals: '((#pasta) #pasta (#noodles #meat #sauce) #meat #tomatoes)'.
+	self
+		assert: (self printStringOfTree: (self remove: #meat oneStarWithTry: tree2))
+		equals: '((#pasta) #pasta (#noodles #meat #sauce) #meat #tomatoes)'
+]
+
 { #category : #'as yet unclassified' }
 ContinuationTest >> testRemoveUptoLast [
 	self

diff --git a/src/Kernel/Continuation.class.st b/src/Kernel/Continuation.class.st
@@ -38,6 +38,46 @@ Continuation class >> fromContext: aStack [
 	^self new initializeFromContext: aStack
 ]
 
+{ #category : #'instance creation' }
+Continuation class >> try: tryBlock or: orBlock or: orrBlock otherwise: elseBlock [
+	^ self
+		try: tryBlock
+		otherwise: [ :res | 
+			self
+				try: [ :cont | orBlock cull: cont cull: res ]
+				or: orrBlock
+				otherwise: [ :rr :r | elseBlock cull: rr cull: r cull: res ] ]
+]
+
+{ #category : #'instance creation' }
+Continuation class >> try: tryBlock or: orBlock otherwise: elseBlock [
+	"	^ self
+		currentDo: [ :success | 
+			| localResult localResult1 |
+			localResult := self
+				currentDo: [ :local | success value: (tryBlock value: local) ].
+			localResult1 := self
+				currentDo: [ :local | success value: (orBlock cull: local cull: localResult) ].
+			elseBlock cull: localResult1 cull: localResult ]"
+
+	^ self
+		try: tryBlock
+		otherwise: [ :res | 
+			self
+				try: [ :cont | orBlock cull: cont cull: res ]
+				otherwise: [ :lastRes | elseBlock cull: lastRes cull: res ] ]
+]
+
+{ #category : #'instance creation' }
+Continuation class >> try: tryBlock otherwise: elseBlock [
+	^ self
+		currentDo: [ :success | 
+			| localResult |
+			localResult := self
+				currentDo: [ :local | success value: (tryBlock value: local) ].
+			elseBlock cull: localResult ]
+]
+
 { #category : #private }
 Continuation >> initializeFromContext: aContext [
 	| valueStream context |