dc: add replacements for tests

packages/DomainCode-Core/Morph.extension.st

@@ -58,6 +58,18 @@ Morph >> isNode: aNode [
 	^ self = aNode
 ]
 
+{ #category : #'*DomainCode-Core' }
+Morph >> isReplacement [
+
+	^ false
+]
+
+{ #category : #'*DomainCode-Core' }
+Morph >> purpose [
+
+	^ nil
+]
+
 { #category : #'*DomainCode-Core' }
 Morph >> treeSize [
 
@@ -66,3 +78,11 @@ Morph >> treeSize [
 	self allChildrenDo: [:m | i := i + 1].
 	^ i
 ]
+
+{ #category : #'*DomainCode-Core' }
+Morph >> wrapped: aSymbol [
+
+	^ DCReplacement new
+		addMorph: self;
+		purpose: aSymbol
+]

packages/DomainCode-Parser/DCBlock.class.st

@@ -586,13 +586,33 @@ DCBlock class >> smalltalkRunTest [
 		[:x | x language = SBTSSmalltalk].
 		[:x | x containingArtefact].
 		[:x | (x selector beginsWith: 'test') and: [x methodClass inheritsFrom: TestCase]].
-		[:x | | result case |
-			Project current addDeferredUIMessage: [
-				result := TestResult new.
-				case := x methodClass selector: x selector.
-				result runCase: case.
-				result defects ifNotEmpty: [:d | d anyOne debug].
-				(result respondsTo: #dispatchResultsIntoHistory) ifTrue: [result dispatchResultsIntoHistory]]]}
+		[:x |
+			Project current addDeferredUIMessage: [ | addIcon displayedError |
+				x method all: {[:p | p purpose = #testResult]} do: #passiveUninstall.
+				addIcon := [:icon | x method addMorphFront: ((SBIcon perform: icon) wrapped: #testResult)].
+				displayedError := false.
+				
+				[(x methodClass selector: x selector) runCase]
+					on: TestResult failure
+					do: [:signal |
+						x messageSendForError: signal argsDo: [:message :args |
+							message run: {
+								self smalltalkMessageSendSelector.
+								[:selector :m | selector = #assert:equals:].
+								[:selector :m |
+									displayedError := true.
+									args do: [:arg |
+										DCPreviewValue new
+											value: arg value;
+											purpose: #testResult;
+											installFor: arg key]]}].
+						addIcon value: #iconTimesCircle.
+						displayedError ifFalse: [signal signal]]
+					on: TestResult exError
+					do: [:signal |
+						addIcon value: #iconTimesCircle.
+						signal signal].
+				displayedError ifFalse: [addIcon value: #iconCheckCircle]]]}
 ]
 
 { #category : #'smalltalk - helpers' }
@@ -638,7 +658,7 @@ DCBlock class >> smalltalkSymbolAutocompletion [
 		[:x | x isSelected].
 		[:x | x language = SBTSSmalltalk].
 		[:x | x type = #symbol].
-		[:x | x addSuggestions: ((self sortedSuggestions: Symbol allSymbols for: x contents allButFirst addAll: false max: 10) collect: [:sel | DCSuggestionItem new selector: sel label: 'symbol' source: sel])]}
+		[:x | x addSuggestions: ((self sortedSuggestions: Symbol allSymbols for: x contents allButFirst addAll: false max: 10) collect: [:sel | DCSuggestionItem new selector: sel label: 'symbol' source: '#', sel])]}
 ]
 
 { #category : #smalltalk }
@@ -706,7 +726,6 @@ DCBlock class >> smalltalkUnknownSelector [
 					SBCodeAction labeled: 'Create method on ...' for: message do: [:node | | method class |
 						class := UIManager default chooseClassOrTrait.
 						class ifNotNil: [
-							self halt.
 							method := DCSmalltalkMethod
 								newWith: (self smalltalkSelectorWithPlaceholders: selector)
 								in: class.
@@ -831,6 +850,12 @@ DCBlock >> alias [
 	^ nil
 ]
 
+{ #category : #queries }
+DCBlock >> all: aCollection do: aBlock [
+
+	(self allBlocksSelect: [:b | (DCQuery script: aCollection with: b) notNil]) do: aBlock
+]
+
 { #category : #'as yet unclassified' }
 DCBlock >> allChildrenDetect: aBlock ifFound: aSuccessBlock ifNone: aFailBlock [
 
@@ -907,7 +932,7 @@ DCBlock >> blockFor: aRange [
 { #category : #'as yet unclassified' }
 DCBlock >> children [
 
-	^ super children collect: [:c | c isReplacement ifTrue: [c resolveSource] ifFalse: [c]]
+	^ Array streamContents: [:s | super children do: [:c | c isReplacement ifTrue: [c resolveSource ifNotNil: [:child | s nextPut: child]] ifFalse: [s nextPut: c]]]
 ]
 
 { #category : #'as yet unclassified' }
@@ -1307,6 +1332,18 @@ DCBlock >> installActiveReplacement: aBlock [
 			value: aBlock})
 ]
 
+{ #category : #'as yet unclassified' }
+DCBlock >> installActiveReplacement: aBlock do: aClosure [
+
+	self sandblockEditor do: (SBCombinedCommand newWith: {
+		SBReplaceCommand new target: self replacer: (aBlock source: self).
+		SBMutatePropertyCommand new
+			target: self;
+			selector: #replacedParent;
+			value: aBlock}).
+	aClosure value: aBlock
+]
+
 { #category : #'as yet unclassified' }
 DCBlock >> installPassiveReplacement: aBlock [
 
@@ -1315,6 +1352,15 @@ DCBlock >> installPassiveReplacement: aBlock [
 	self replacedParent: aBlock
 ]
 
+{ #category : #'as yet unclassified' }
+DCBlock >> installPassiveReplacement: aBlock do: aClosure [
+
+	aBlock source: self.
+	self replaceBy: aBlock.
+	self replacedParent: aBlock.
+	aClosure value: aBlock
+]
+
 { #category : #'as yet unclassified' }
 DCBlock >> intoWorld: aWorld [
 
@@ -1775,6 +1821,12 @@ DCBlock >> rootBlock [
 	^ self orAnyParent: self language rootRuleName
 ]
 
+{ #category : #queries }
+DCBlock >> run: aCollection [
+
+	^ DCQuery script: aCollection with: self
+]
+
 { #category : #'as yet unclassified' }
 DCBlock >> saveTryFixing: aFixBoolean quick: aQuickBoolean [
 

packages/DomainCode-Parser/DCEditTest.class.st

@@ -105,7 +105,7 @@ DCEditTest >> testSmalltalkSwapStatementsWithEmpty [
 
 	| program editor |
 	program := DCBlock parse: 'a
-b.
+b .
 
 c.' language: SBTSSmalltalk.
 	editor := self editorAndWorldFor: program.

packages/DomainCode-Parser/DCPreviewValue.class.st

@@ -0,0 +1,53 @@
+Class {
+	#name : #DCPreviewValue,
+	#superclass : #DCReplacement,
+	#instVars : [
+		'value'
+	],
+	#category : #'DomainCode-Parser'
+}
+
+{ #category : #'as yet unclassified' }
+DCPreviewValue >> drawnColor [
+
+	^ Color veryDarkGray
+]
+
+{ #category : #'as yet unclassified' }
+DCPreviewValue >> installFor: aBlock [
+
+	aBlock installPassiveReplacement: self do: [:r |
+		r
+			addMorphBack: (r addEmbed: aBlock);
+			addMorphBack: (SBMultilineOwnTextMorph new
+				contents: r value printString;
+				bold)]
+]
+
+{ #category : #'as yet unclassified' }
+DCPreviewValue >> layoutCommands [
+
+	^ SBAlgebraCommand container
+		morph: self;
+		data: (self submorphs
+			collect: [:s | s layoutCommands]
+			separatedBy: [SBAlgebraCommand hardLine withGap: true])
+]
+
+{ #category : #'as yet unclassified' }
+DCPreviewValue >> layoutInset [
+
+	^ 5
+]
+
+{ #category : #'as yet unclassified' }
+DCPreviewValue >> value [
+
+	^ value
+]
+
+{ #category : #'as yet unclassified' }
+DCPreviewValue >> value: anObject [
+
+	value := anObject
+]

packages/DomainCode-Parser/DCReplacement.class.st

@@ -47,16 +47,31 @@ DCReplacement >> activeUninstall [
 	self source startInputAtEnd
 ]
 
+{ #category : #'as yet unclassified' }
+DCReplacement >> addEmbed: aBlock [
+
+	currentEmbeds ifNil: [currentEmbeds := OrderedCollection new].
+
+	^ currentEmbeds add: (aBlock = self source
+		ifFalse: [ | marker |
+			marker := DCEmbedMarker new source: aBlock.
+			aBlock replaceBy: marker.
+			aBlock]
+		ifTrue: [
+			self assert: aBlock replacedParent = self.
+			aBlock])
+]
+
 { #category : #'as yet unclassified' }
 DCReplacement >> children [
 
-	^ self source children
+	^ self source ifNotNil: #children ifNil: [#()]
 ]
 
 { #category : #'as yet unclassified' }
 DCReplacement >> contents [
 
-	^ self source contents
+	^ self source ifNotNil: #contents ifNil: ['']
 ]
 
 { #category : #'as yet unclassified' }
@@ -110,14 +125,14 @@ DCReplacement >> layoutCommands [
 DCReplacement >> passiveUninstall [
 
 	| hadFocus |
-	self source replacedParent: nil.
-	currentEmbeds ifNotNil: [:e | e do: [:embed | embed replacedParent uninstall]].
+	currentEmbeds ifNotNil: [:e | e do: [:embed | embed = self source ifFalse: [embed replacedParent uninstall]]].
+	self source ifNotNil: [self source replacedParent: nil].
 
 	self sandblockEditor ifNil: [^ self].
 	hadFocus := self sandblockEditor textFocus
 		ifNotNil: [:t | t hasAnyParent: self]
 		ifNil: [false].
-	self replaceBy: self source.
+	self source ifNotNil: [self replaceBy: self source] ifNil: [self delete].
 
 	hadFocus ifTrue: [self source startInputAtEnd]
 ]
@@ -131,16 +146,28 @@ DCReplacement >> printOn: aStream [
 	aStream nextPut: $)
 ]
 
+{ #category : #'as yet unclassified' }
+DCReplacement >> purpose [
+
+	^ self valueOfProperty: #purpose
+]
+
+{ #category : #'as yet unclassified' }
+DCReplacement >> purpose: aSymbol [
+
+	self setProperty: #purpose toValue: aSymbol
+]
+
 { #category : #'as yet unclassified' }
 DCReplacement >> range [
 
-	^ self source range
+	^ self source ifNotNil: #range ifNil: [SBTSRange null]
 ]
 
 { #category : #'as yet unclassified' }
 DCReplacement >> resolveSource [
 
-	^ self source resolveSource
+	^ self source ifNotNil: [:c | c resolveSource]
 ]
 
 { #category : #'as yet unclassified' }
@@ -172,7 +199,7 @@ DCReplacement >> treeHash [
 { #category : #'as yet unclassified' }
 DCReplacement >> treeLabel [
 
-	^ self source treeLabel
+	^ self source ifNotNil: #treeLabel ifNil: ['']
 ]
 
 { #category : #'as yet unclassified' }
@@ -188,15 +215,8 @@ DCReplacement >> updateEmbeds [
 	newEmbeds := collectEmbeds value: self source.
 	currentEmbeds
 		ifNil: [
-			currentEmbeds := newEmbeds collect: [:embed |
-				embed = self source
-					ifFalse: [ | marker |
-						marker := DCEmbedMarker new source: embed.
-						embed replaceBy: marker.
-						embed]
-					ifTrue: [
-						self assert: embed replacedParent = self.
-						embed]]]
+			newEmbeds do: [:embed | self addEmbed: embed].
+			currentEmbeds ifNil: [currentEmbeds := {}]]
 		ifNotNil: [
 			newEmbeds do: [:e |
 				self

packages/DomainCode-Parser/DCSmalltalkMethod.class.st

@@ -25,6 +25,15 @@ DCSmalltalkMethod class >> newWith: aString in: aClass [
 	^ self new in: aClass with: aString
 ]
 
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> blockForPC: aNumber isActiveFrame: aBoolean [
+
+	| pc |
+	pc := aBoolean ifTrue: [aNumber] ifFalse: [self compiledMethod pcPreviousTo: aNumber].
+	(self method getSourceStringAndMark parseAsMethodFor: self methodClass) rawSourceRanges keysAndValuesDo: [:node :range | node pc = pc ifTrue: [^ self method smallestBlockEncompassig: (SBTSRange start: range start - 1 size: range size)]].
+	^ nil
+]
+
 { #category : #'as yet unclassified' }
 DCSmalltalkMethod >> browse [
 	<action>
@@ -38,6 +47,12 @@ DCSmalltalkMethod >> category [
 	^ self methodClass organization categoryOfElement: self selector
 ]
 
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> compiledMethod [
+
+	^ self methodClass >> self selector
+]
+
 { #category : #'as yet unclassified' }
 DCSmalltalkMethod >> emptyIn: aClass [
 
@@ -122,6 +137,17 @@ DCSmalltalkMethod >> layoutCommands [
 		morph: self
 ]
 
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> messageSendForError: anError argsDo: aBlock [
+
+	| context message |
+	context := anError signalerContext findContextSuchThat: [:c | c method = self compiledMethod].
+	message := self blockForPC: context pc isActiveFrame: context = anError signalerContext.
+	aBlock
+		value: message
+		value: ((anError signalerContext findContextSuchThat: [:c | c sender = context]) arguments collectWithIndex: [:arg :index | (message children at: 2 + (index - 1 * 2) + 1) -> arg])
+]
+
 { #category : #'as yet unclassified' }
 DCSmalltalkMethod >> method [