dc: introduce queries for decorators and shortcuts

hpi-swa-lab · Oct 2, 2023 · 685acca · 685acca
1 parent 91243f7
commit 685acca
Show file tree

Hide file tree

Showing 14 changed files with 460 additions and 36 deletions.
diff --git a/packages/DomainCode-Core/CompiledMethod.extension.st b/packages/DomainCode-Core/CompiledMethod.extension.st
@@ -1,9 +1,9 @@
 Extension { #name : #CompiledMethod }
 
 { #category : #'*DomainCode-Core' }
-CompiledMethod >> openDC: convert [
-	<convert>
-	<convertPriority: 13>
+CompiledMethod >> openDC:convert [
+<convert>
+<convertPriority:1>
 
-	convert do: [DCSmalltalkMethod for: self]
+convert do:[DCSmalltalkMethod for:self]
 ]
diff --git a/packages/DomainCode-Core/DCQuery.class.st b/packages/DomainCode-Core/DCQuery.class.st
@@ -32,6 +32,13 @@ DCQuery class >> does: aDomainObject haveProperty: anObject [
 		ifAbsent: [false]
 ]
 
+{ #category : #'as yet unclassified' }
+DCQuery class >> firstScript: aCollectionOfCollections with: anObject [
+
+	aCollectionOfCollections do: [:script | (self script: script with: anObject) ifNotNil: [:res | ^ res]].
+	^ nil
+]
+
 { #category : #'as yet unclassified' }
 DCQuery class >> match: aClosure with: anObject do: anotherClosure [
 
@@ -52,3 +59,34 @@ DCQuery class >> removeProperty: anObject from: aDomainObject [
 		at: aDomainObject
 		ifPresent: [:properties | properties remove: aDomainObject]
 ]
+
+{ #category : #'as yet unclassified' }
+DCQuery class >> script: aCollection first: anotherCollection [
+
+	anotherCollection do: [:obj | (self script: aCollection with: obj) ifNotNil: [:res | ^ res]].
+	^ nil
+]
+
+{ #category : #'as yet unclassified' }
+DCQuery class >> script: aCollection with: anObject [
+
+	| current |
+	current := anObject.
+	aCollection do: [:block | | res |
+		block isCollection
+			ifTrue: [
+				(self script: block with: current)
+					ifNil: [^ nil]
+					ifNotNil: [:o | current := o]]
+			ifFalse: [
+				res := (current isCollection and: [current notEmpty and: [current first = #args]])
+					ifTrue: [block valueWithArguments: current allButFirst]
+					ifFalse: [block value: current].
+				res == nil ifTrue: [^ nil].
+				res == false ifTrue: [^ nil].
+				res isCollection ifTrue: [
+					res ifEmpty: [^ nil].
+					res first = #args and: [(res anySatisfy: [:subRes | subRes == nil or: [subRes == false or: [subRes isCollection and: [subRes isEmpty]]]]) ifTrue: [^ nil]]].
+				res ~~ true ifTrue: [current := res]]].
+	^ current
+]
diff --git a/packages/DomainCode-Diff/DCChawatheScriptGenerator.class.st b/packages/DomainCode-Diff/DCChawatheScriptGenerator.class.st
@@ -21,11 +21,8 @@ DCChawatheScriptGenerator >> alignChildrenSrc: w dest: x srcInOrder: srcInOrder
 
 	s2 do: [:b |
 		s1 do: [:a |
-			((aMapping includes: {a. b}) and: [(lcs includes: {a. b}) not]) ifTrue: [ | k |
-				"FIXME delete first or find position first?"
-				"a delete."
-				k := self findPosition: b dest: destInOrder in: aMapping.
-				self move: a to: w at: k.
+			((aMapping includes: {a. b}) and: [(lcs includes: {a. b}) not]) ifTrue: [ 
+				self move: a to: w postDeleteDo: [self findPosition: b dest: destInOrder in: aMapping].
 				srcInOrder add: a.
 				destInOrder add: b]]]
 ]
@@ -80,10 +77,11 @@ DCChawatheScriptGenerator >> generateFrom: src to: dest in: aMapping [
 			ifTrue: [
 				w := aMapping srcForDest: x.
 				w range: x range.
-				x = dest ifFalse: [ | v |
+				x = dest ifFalse: [ | v k |
 					v := w owner.
 					w treeLabel = x treeLabel ifFalse: [self update: w with: x contents].
-					z = v ifFalse: [self move: w to: z at: (self findPosition: x dest: destInOrder in: aMapping)]]].
+					k := self findPosition: x dest: destInOrder in: aMapping.
+					z = v ifFalse: [self move: w to: z postDeleteDo: [k]]]].
 
 		srcInOrder add: w.
 		destInOrder add: x.
@@ -134,9 +132,12 @@ DCChawatheScriptGenerator >> maybeAttachFlash: aMorph [
 ]
 
 { #category : #actions }
-DCChawatheScriptGenerator >> move: aMorph to: anOwnerMorph at: aNumber [
+DCChawatheScriptGenerator >> move: aMorph to: anOwnerMorph postDeleteDo: aBlock [
 
-	anOwnerMorph addMorph: aMorph asElementNumber: aNumber
+	| index |
+	aMorph delete.
+	index := aBlock value.
+	anOwnerMorph addMorph: aMorph asElementNumber: index
 ]
 
 { #category : #actions }

diff --git a/packages/DomainCode-Diff/DCCommandScriptGenerator.class.st b/packages/DomainCode-Diff/DCCommandScriptGenerator.class.st
@@ -51,19 +51,24 @@ DCCommandScriptGenerator >> insert: aMorph at: aNumber in: anOwnerMorph [
 { #category : #testing }
 DCCommandScriptGenerator >> logChanges [
 
-	^ false
+^true
 ]
 
 { #category : #actions }
-DCCommandScriptGenerator >> move: aMorph to: anOwnerMorph at: aNumber [
+DCCommandScriptGenerator >> move: aMorph to: anOwnerMorph postDeleteDo: aBlock [
 
-	self editor do: (SBMoveCommand new
+	| command |
+	command := SBMoveCommand new
 		shouldMergeWithNext: true;
 		container: anOwnerMorph;
 		morph: aMorph;
-		index: aNumber).
+		notePosition.
+	aMorph delete.
+	command index: aBlock value.
+	self editor do: command.
+
 	self maybeAttachFlash: aMorph.
-	self logChanges ifTrue: [Transcript showln: {#move. anOwnerMorph. aNumber. aMorph}]
+	self logChanges ifTrue: [Transcript showln: {#move. anOwnerMorph. aBlock. aMorph}]
 ]
 
 { #category : #actions }

diff --git a/packages/DomainCode-Diff/DCMappingStore.class.st b/packages/DomainCode-Diff/DCMappingStore.class.st
@@ -91,3 +91,21 @@ DCMappingStore >> srcToDest [
 
 	^ srcToDest
 ]
+
+{ #category : #'as yet unclassified' }
+DCMappingStore >> visualizeFrom: src to: dest [
+
+	| destExtent srcExtent editor |
+	srcExtent := src fullBounds; extent.
+	destExtent := dest fullBounds; extent.
+
+	"container := SBBlock new.
+	 listDirection: #leftToRight; hResizing: #shrinkWrap; vResizing: #shrinkWrap; changeTableLayout; layoutInset: 10; cellGap: 50; addMorphBack: src; addMorphBack: dest."
+
+	editor := SBEditor openFor: src.
+	editor openMorphInView: dest.
+	self keysAndValuesDo: [:from :to |
+		from layoutInset: 10.
+		to layoutInset: 10.
+		((editor connectFrom: from to: to) color: (Color random alpha: 0.2))].
+]
diff --git a/packages/DomainCode-Diff/DCMatcher.class.st b/packages/DomainCode-Diff/DCMatcher.class.st
@@ -30,9 +30,16 @@ DCMatcher >> commonAncestorOf: aCollection root: aTree [
 { #category : #'as yet unclassified' }
 DCMatcher >> doCommandForEditsIn: aDest to: aSrc in: anEditor [
 
-	DCCommandScriptGenerator new
-		editor: anEditor;
-		generateFrom: aSrc to: aDest in: (self matchFrom: aSrc to: aDest)
+	SBToggledCode comment: '' active: 2 do: {
+		[
+			DCChawatheScriptGenerator new
+				generateFrom: aSrc
+				to: aDest
+				in: (self matchFrom: aSrc to: aDest)].
+		[
+			DCCommandScriptGenerator new
+				editor: anEditor;
+				generateFrom: aSrc to: aDest in: (self matchFrom: aSrc to: aDest)]}
 ]
 
 { #category : #'as yet unclassified' }

diff --git a/packages/DomainCode-Diff/String.extension.st b/packages/DomainCode-Diff/String.extension.st
@@ -30,3 +30,11 @@ String >> levenshteinRatioTo: anotherString [
 	lengthSum := self size + anotherString size.
 	^ (lengthSum - (self levenshteinDistanceTo: anotherString) / lengthSum) asFloat
 ]
+
+{ #category : #'*DomainCode-Diff' }
+String >> withoutLeading: aCollection [
+
+	| firstValid |
+	firstValid := self findFirst: [:m | (aCollection includes: m) not].
+	^ firstValid > 0 ifTrue: [self copyFrom: firstValid to: self size] ifFalse: ['']
+]