From 6ce78c04b5c1b23804b42e34e808bc4d05ff73a6 Mon Sep 17 00:00:00 2001 From: Tom Beckmann Date: Mon, 2 Oct 2023 21:59:03 +0200 Subject: [PATCH] dc: make replacements compatible with diffing --- packages/DomainCode-Core/Morph.extension.st | 61 ++++++++++++ .../DCChawatheScriptGenerator.class.st | 18 ++-- .../DCCommandScriptGenerator.class.st | 2 +- .../DCGreedyBottomUpMatcher.class.st | 6 +- .../DCGreedySubtreeMatcher.class.st | 6 +- .../DCLeftOverLeafMatcher.class.st | 10 +- .../DCMappingComparator.class.st | 4 +- .../DomainCode-Diff/DCMappingStore.class.st | 6 +- packages/DomainCode-Diff/DCMatchTest.class.st | 6 +- packages/DomainCode-Diff/DCMatcher.class.st | 10 +- .../DCPriorityTreeQueue.class.st | 2 +- .../DCZhangShashaTree.class.st | 8 +- packages/DomainCode-Parser/DCBlock.class.st | 73 +++++++++++---- .../DomainCode-Parser/DCCheckbox.class.st | 25 +++++ .../DomainCode-Parser/DCMockSlot.class.st | 4 +- .../DomainCode-Parser/DCReplacement.class.st | 92 +++++++++++++++++++ 16 files changed, 272 insertions(+), 61 deletions(-) create mode 100644 packages/DomainCode-Core/Morph.extension.st create mode 100644 packages/DomainCode-Parser/DCCheckbox.class.st create mode 100644 packages/DomainCode-Parser/DCReplacement.class.st diff --git a/packages/DomainCode-Core/Morph.extension.st b/packages/DomainCode-Core/Morph.extension.st new file mode 100644 index 0000000..3aae4c4 --- /dev/null +++ b/packages/DomainCode-Core/Morph.extension.st @@ -0,0 +1,61 @@ +Extension { #name : #Morph } + +{ #category : #'*DomainCode-Core' } +Morph >> allChildrenBreadthFirstDo: aBlock [ + + | remaining | + remaining := OrderedCollection with: self. + [remaining notEmpty] whileTrue: [ | next | + next := remaining removeFirst. + aBlock value: next. + remaining addAll: next children] +] + +{ #category : #'*DomainCode-Core' } +Morph >> allChildrenDo: aBlock [ + + self children do: [:c | c allChildrenDo: aBlock]. + aBlock value: self +] + +{ #category : #'*DomainCode-Core' } +Morph >> allChildrenSelect: aBlock [ + + ^ Array streamContents: [:stream | self allChildrenDo: [:b | (aBlock value: b) ifTrue: [stream nextPut: b]]] +] + +{ #category : #'*DomainCode-Core' } +Morph >> children [ + + ^ submorphs +] + +{ #category : #'*DomainCode-Core' } +Morph >> firstDeepChildNode [ + + | current | + current := self. + [current children isEmpty] whileFalse: [current := current children first]. + ^ current +] + +{ #category : #'*DomainCode-Core' } +Morph >> hasChildren [ + + ^ self children notEmpty +] + +{ #category : #'*DomainCode-Core' } +Morph >> isNode: aNode [ + + ^ self = aNode +] + +{ #category : #'*DomainCode-Core' } +Morph >> treeSize [ + + | i | + i := 0. + self allChildrenDo: [:m | i := i + 1]. + ^ i +] diff --git a/packages/DomainCode-Diff/DCChawatheScriptGenerator.class.st b/packages/DomainCode-Diff/DCChawatheScriptGenerator.class.st index abb6456..f8f5ca7 100644 --- a/packages/DomainCode-Diff/DCChawatheScriptGenerator.class.st +++ b/packages/DomainCode-Diff/DCChawatheScriptGenerator.class.st @@ -8,11 +8,11 @@ Class { DCChawatheScriptGenerator >> alignChildrenSrc: w dest: x srcInOrder: srcInOrder destInOrder: destInOrder in: aMapping [ | s1 s2 lcs | - w submorphs do: [:c | srcInOrder remove: c ifAbsent: []]. - x submorphs do: [:c | destInOrder remove: c ifAbsent: []]. + w children do: [:c | srcInOrder remove: c ifAbsent: []]. + x children do: [:c | destInOrder remove: c ifAbsent: []]. - s1 := w submorphs select: [:c | (aMapping isSrcMapped: c) and: [x submorphs includes: (aMapping destForSrc: c)]]. - s2 := x submorphs select: [:c | (aMapping isDestMapped: c) and: [w submorphs includes: (aMapping srcForDest: c)]]. + s1 := w children select: [:c | (aMapping isSrcMapped: c) and: [x children includes: (aMapping destForSrc: c)]]. + s2 := x children select: [:c | (aMapping isDestMapped: c) and: [w children includes: (aMapping srcForDest: c)]]. lcs := self lcsWith: s1 and: s2 in: aMapping. lcs do: [:mapping | @@ -21,7 +21,7 @@ DCChawatheScriptGenerator >> alignChildrenSrc: w dest: x srcInOrder: srcInOrder s2 do: [:b | s1 do: [:a | - ((aMapping includes: {a. b}) and: [(lcs includes: {a. b}) not]) ifTrue: [ + ((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]]] @@ -37,7 +37,7 @@ DCChawatheScriptGenerator >> delete: aMorph [ DCChawatheScriptGenerator >> findPosition: aTree dest: destInOrder in: aMapping [ | siblings v u | - siblings := aTree owner submorphs. + siblings := aTree owner children. siblings do: [:c | (destInOrder includes: c) ifTrue: [c = aTree ifTrue: [^ 1]]]. v := nil. @@ -64,7 +64,7 @@ DCChawatheScriptGenerator >> generateFrom: src to: dest in: aMapping [ destInOrder := Set new. inserted := Set new. - dest allMorphsBreadthFirstDo: [:x | | y z w | + dest allChildrenBreadthFirstDo: [:x | | y z w | w := nil. y := x owner. z := aMapping srcForDest: y. @@ -81,13 +81,13 @@ DCChawatheScriptGenerator >> generateFrom: src to: dest in: aMapping [ v := w owner. w treeLabel = x treeLabel ifFalse: [self update: w with: x contents]. k := self findPosition: x dest: destInOrder in: aMapping. - z = v ifFalse: [self move: w to: z postDeleteDo: [k]]]]. + (z isNode: v) ifFalse: [self move: w to: z postDeleteDo: [k]]]]. srcInOrder add: w. destInOrder add: x. self alignChildrenSrc: w dest: x srcInOrder: srcInOrder destInOrder: destInOrder in: aMapping]. - (Array streamContents: [:s | src allMorphsDo: [:w | ((aMapping isSrcMapped: w) not and: [(inserted includes: w) not]) ifTrue: [s nextPut: w]]]) do: [:w | self delete: w] + (Array streamContents: [:s | src allChildrenDo: [:w | ((aMapping isSrcMapped: w) not and: [(inserted includes: w) not]) ifTrue: [s nextPut: w]]]) do: [:w | self delete: w] ] { #category : #actions } diff --git a/packages/DomainCode-Diff/DCCommandScriptGenerator.class.st b/packages/DomainCode-Diff/DCCommandScriptGenerator.class.st index 1d370f9..2df779c 100644 --- a/packages/DomainCode-Diff/DCCommandScriptGenerator.class.st +++ b/packages/DomainCode-Diff/DCCommandScriptGenerator.class.st @@ -68,7 +68,7 @@ DCCommandScriptGenerator >> move: aMorph to: anOwnerMorph postDeleteDo: aBlock [ self editor do: command. self maybeAttachFlash: aMorph. - self logChanges ifTrue: [Transcript showln: {#move. anOwnerMorph. aBlock. aMorph}] + self logChanges ifTrue: [Transcript showln: {#move. anOwnerMorph. command index. aMorph}] ] { #category : #actions } diff --git a/packages/DomainCode-Diff/DCGreedyBottomUpMatcher.class.st b/packages/DomainCode-Diff/DCGreedyBottomUpMatcher.class.st index 4ac4a9d..c9f7e37 100644 --- a/packages/DomainCode-Diff/DCGreedyBottomUpMatcher.class.st +++ b/packages/DomainCode-Diff/DCGreedyBottomUpMatcher.class.st @@ -33,7 +33,7 @@ DCGreedyBottomUpMatcher >> destCandidatesFor: src in: aMapping [ { #category : #'as yet unclassified' } DCGreedyBottomUpMatcher >> lastChanceMatchFrom: src to: dest in: aMapping [ - (src recursiveSubmorphCount < self sizeThreshold or: [dest recursiveSubmorphCount < self sizeThreshold]) ifTrue: [ | m zsMappings | + (src treeSize < self sizeThreshold or: [dest treeSize < self sizeThreshold]) ifTrue: [ | m zsMappings | m := DCZhangShashaMatcher new. zsMappings := DCMappingStore new. m matchFrom: src to: dest in: zsMappings. @@ -44,13 +44,13 @@ DCGreedyBottomUpMatcher >> lastChanceMatchFrom: src to: dest in: aMapping [ DCGreedyBottomUpMatcher >> matchFrom: src to: dest in: aMapping [ rootDest := dest. - src allMorphsDo: [:t | + src allChildrenDo: [:t | src = t ifTrue: [ aMapping addMappingFrom: t to: dest. self lastChanceMatchFrom: t to: dest in: aMapping] ifFalse: [ - ((aMapping isSrcMapped: t) not or: [t hasSubmorphs not]) ifTrue: [ + ((aMapping isSrcMapped: t) not or: [t hasChildren not]) ifTrue: [ (((self destCandidatesFor: t in: aMapping) select: [:candidate | (DCMappingComparator diceSimilarityFrom: t to: candidate in: aMapping) >= self similarityThreshold]) detectMax: [:candidate | DCMappingComparator diceSimilarityFrom: t to: candidate in: aMapping]) ifNotNil: [:best | self lastChanceMatchFrom: t to: best in: aMapping. aMapping addMappingFrom: t to: best]]]] diff --git a/packages/DomainCode-Diff/DCGreedySubtreeMatcher.class.st b/packages/DomainCode-Diff/DCGreedySubtreeMatcher.class.st index 071fd18..bee1dcd 100644 --- a/packages/DomainCode-Diff/DCGreedySubtreeMatcher.class.st +++ b/packages/DomainCode-Diff/DCGreedySubtreeMatcher.class.st @@ -17,9 +17,9 @@ DCGreedySubtreeMatcher >> handleAmbiguousMappings: aCollection for: aMapping [ mappingStore: aMapping. aCollection sort: [:m1 :m2 | | s1 s2 | - s1 := m1 first detectMax: [:t | t recursiveSubmorphCount]. - s2 := m2 first detectMax: [:t | t recursiveSubmorphCount]. - s1 recursiveSubmorphCount < s2 recursiveSubmorphCount]. + s1 := m1 first detectMax: [:t | t treeSize]. + s2 := m2 first detectMax: [:t | t treeSize]. + s1 treeSize < s2 treeSize]. aCollection do: [:entry | | candidates | candidates := Array streamContents: [:s | entry first do: [:src | entry second do: [:dest | s nextPut: {src. dest}]]]. diff --git a/packages/DomainCode-Diff/DCLeftOverLeafMatcher.class.st b/packages/DomainCode-Diff/DCLeftOverLeafMatcher.class.st index e98a502..d7f32d7 100644 --- a/packages/DomainCode-Diff/DCLeftOverLeafMatcher.class.st +++ b/packages/DomainCode-Diff/DCLeftOverLeafMatcher.class.st @@ -17,9 +17,9 @@ DCLeftOverLeafMatcher >> handleAmbiguousMappings: aCollection for: aMapping [ mappingStore: aMapping. aCollection sort: [:m1 :m2 | | s1 s2 | - s1 := m1 first detectMax: [:t | t recursiveSubmorphCount]. - s2 := m2 first detectMax: [:t | t recursiveSubmorphCount]. - s1 recursiveSubmorphCount < s2 recursiveSubmorphCount]. + s1 := m1 first detectMax: [:t | t treeSize]. + s2 := m2 first detectMax: [:t | t treeSize]. + s1 treeSize < s2 treeSize]. aCollection do: [:entry | | candidates | candidates := Array streamContents: [:s | entry first do: [:src | entry second do: [:dest | s nextPut: {src. dest}]]]. @@ -37,10 +37,10 @@ DCLeftOverLeafMatcher >> matchFrom: src to: dest in: aMapping [ ambiguousMappings := OrderedCollection new. srcTrees := DCPriorityTreeQueue new minimumHeight: 0; - addAll: (Array streamContents: [:s | src allMorphsDo: [:k | (aMapping isSrcMapped: k) ifFalse: [s nextPut: k]]]). + addAll: (Array streamContents: [:s | src allChildrenDo: [:k | (aMapping isSrcMapped: k) ifFalse: [s nextPut: k]]]). destTrees := DCPriorityTreeQueue new minimumHeight: 0; - addAll: (Array streamContents: [:s | dest allMorphsDo: [:k | (aMapping isDestMapped: k) ifFalse: [s nextPut: k]]]). + addAll: (Array streamContents: [:s | dest allChildrenDo: [:k | (aMapping isDestMapped: k) ifFalse: [s nextPut: k]]]). [ self synchronizePriority: srcTrees with: destTrees. diff --git a/packages/DomainCode-Diff/DCMappingComparator.class.st b/packages/DomainCode-Diff/DCMappingComparator.class.st index fe38282..1640852 100644 --- a/packages/DomainCode-Diff/DCMappingComparator.class.st +++ b/packages/DomainCode-Diff/DCMappingComparator.class.st @@ -24,8 +24,8 @@ DCMappingComparator class >> diceSimilarityFrom: src to: dest in: aMapping [ ^ self diceCoefficientCommon: (self numberOfMappedDescendantsFrom: src to: dest in: aMapping) - left: src recursiveSubmorphCount - 1 - right: dest recursiveSubmorphCount - 1 + left: src treeSize - 1 + right: dest treeSize - 1 ] { #category : #'as yet unclassified' } diff --git a/packages/DomainCode-Diff/DCMappingStore.class.st b/packages/DomainCode-Diff/DCMappingStore.class.st index 856518a..38f57e0 100644 --- a/packages/DomainCode-Diff/DCMappingStore.class.st +++ b/packages/DomainCode-Diff/DCMappingStore.class.st @@ -11,10 +11,6 @@ Class { { #category : #'as yet unclassified' } DCMappingStore >> addMappingFrom: src to: dest [ - SBToggledCode - comment: '' - active: 1 - do: {[src type = 'lexical_declaration' ifTrue: [self halt]]}. srcToDest at: src put: dest. destToSrc at: dest put: src ] @@ -23,7 +19,7 @@ DCMappingStore >> addMappingFrom: src to: dest [ DCMappingStore >> addRecursiveMappingFrom: src to: dest [ self addMappingFrom: src to: dest. - src submorphs with: dest submorphs do: [:a :b | self addRecursiveMappingFrom: a to: b] + src children with: dest children do: [:a :b | self addRecursiveMappingFrom: a to: b] ] { #category : #'as yet unclassified' } diff --git a/packages/DomainCode-Diff/DCMatchTest.class.st b/packages/DomainCode-Diff/DCMatchTest.class.st index 8ac6c8a..1fe67d6 100644 --- a/packages/DomainCode-Diff/DCMatchTest.class.st +++ b/packages/DomainCode-Diff/DCMatchTest.class.st @@ -8,10 +8,9 @@ Class { DCMatchTest >> testAppendBinary [ | src dest | - Transcript clear. src := DCBlock parseBlock: 'a' language: SBJavascript. dest := DCBlock parseBlock: 'a+' language: SBJavascript. - DCMatcher new matchFrom: src to: dest. + DCMatcher new applyEditsIn: dest to: src. self assert: 'a+' equals: src sourceString ] @@ -19,9 +18,8 @@ DCMatchTest >> testAppendBinary [ DCMatchTest >> testSplitBinary [ | src dest | - Transcript clear. src := DCBlock parseBlock: 'a2' language: SBJavascript. dest := DCBlock parseBlock: 'a+2' language: SBJavascript. - DCMatcher new matchFrom: src to: dest. + DCMatcher new applyEditsIn: dest to: src. self assert: 'a+2' equals: src sourceString ] diff --git a/packages/DomainCode-Diff/DCMatcher.class.st b/packages/DomainCode-Diff/DCMatcher.class.st index 7a36985..b1d0cee 100644 --- a/packages/DomainCode-Diff/DCMatcher.class.st +++ b/packages/DomainCode-Diff/DCMatcher.class.st @@ -47,10 +47,10 @@ DCMatcher >> fineGrainedMatch2From: src to: dest in: aMapping [ | topSrc topDest | topSrc := self - commonAncestorOf: (Array streamContents: [:s | src allMorphsDo: [:k | (aMapping isSrcMapped: k) ifFalse: [s nextPut: k]]]) + commonAncestorOf: (Array streamContents: [:s | src allChildrenDo: [:k | (aMapping isSrcMapped: k) ifFalse: [s nextPut: k]]]) root: src. topDest := self - commonAncestorOf: (Array streamContents: [:s | dest allMorphsDo: [:k | (aMapping isDestMapped: k) ifFalse: [s nextPut: k]]]) + commonAncestorOf: (Array streamContents: [:s | dest allChildrenDo: [:k | (aMapping isDestMapped: k) ifFalse: [s nextPut: k]]]) root: dest. (topSrc notNil and: [topDest notNil]) ifTrue: [ "see if we can answer quickly, otherwise we accept a worse diff result" @@ -66,8 +66,8 @@ DCMatcher >> fineGrainedMatch2From: src to: dest in: aMapping [ DCMatcher >> fineGrainedMatchFrom: src to: dest in: aMapping [ | topSrc topDest | - topSrc := (Array streamContents: [:s | src allMorphsDo: [:k | (aMapping isSrcMapped: k) ifFalse: [s nextPut: k]]]) detectMax: #treeHeight. - topDest := (Array streamContents: [:s | dest allMorphsDo: [:k | (aMapping isDestMapped: k) ifFalse: [s nextPut: k]]]) detectMax: #treeHeight. + topSrc := (Array streamContents: [:s | src allChildrenDo: [:k | (aMapping isSrcMapped: k) ifFalse: [s nextPut: k]]]) detectMax: #treeHeight. + topDest := (Array streamContents: [:s | dest allChildrenDo: [:k | (aMapping isDestMapped: k) ifFalse: [s nextPut: k]]]) detectMax: #treeHeight. self halt. topSrc ifNotNil: [ @@ -80,7 +80,7 @@ DCMatcher >> fineGrainedMatchFrom: src to: dest in: aMapping [ { #category : #'as yet unclassified' } DCMatcher >> largestUnmappedFor: aTree isSrc: aBoolean in: aMapping [ - ^ (Array streamContents: [:s | aTree allMorphsDo: [:k | (aBoolean ifTrue: [aMapping isSrcMapped: k] ifFalse: [aMapping isDestMapped: k]) ifFalse: [s nextPut: k]]]) detectMax: #treeHeight + ^ (Array streamContents: [:s | aTree allChildrenDo: [:k | (aBoolean ifTrue: [aMapping isSrcMapped: k] ifFalse: [aMapping isDestMapped: k]) ifFalse: [s nextPut: k]]]) detectMax: #treeHeight ] { #category : #'as yet unclassified' } diff --git a/packages/DomainCode-Diff/DCPriorityTreeQueue.class.st b/packages/DomainCode-Diff/DCPriorityTreeQueue.class.st index ff5d9bc..e37f7f3 100644 --- a/packages/DomainCode-Diff/DCPriorityTreeQueue.class.st +++ b/packages/DomainCode-Diff/DCPriorityTreeQueue.class.st @@ -23,7 +23,7 @@ DCPriorityTreeQueue >> addAll: aCollection [ { #category : #'as yet unclassified' } DCPriorityTreeQueue >> addTree: tree [ - tree submorphs do: [:child | self add: child] + tree children do: [:child | self add: child] ] { #category : #'as yet unclassified' } diff --git a/packages/DomainCode-Diff/DCZhangShashaTree.class.st b/packages/DomainCode-Diff/DCZhangShashaTree.class.st index 9e91952..f3838d1 100644 --- a/packages/DomainCode-Diff/DCZhangShashaTree.class.st +++ b/packages/DomainCode-Diff/DCZhangShashaTree.class.st @@ -15,18 +15,18 @@ Class { DCZhangShashaTree >> for: aTree [ | index tmpData visited k | - nodeCount := aTree recursiveSubmorphCount. + nodeCount := aTree treeSize. leafCount := 0. llds := Array new: nodeCount. labels := Array new: nodeCount. index := 1. tmpData := Dictionary new. - aTree allMorphsDo: [:n | + aTree allChildrenDo: [:n | tmpData at: n put: index. labels at: index put: n. - llds at: index put: (tmpData at: n firstDeepSubmorph) - 1. - n hasSubmorphs ifFalse: [leafCount := leafCount + 1]. + llds at: index put: (tmpData at: n firstDeepChildNode) - 1. + n hasChildren ifFalse: [leafCount := leafCount + 1]. index := index + 1]. keyRoots := Array new: leafCount + 1. diff --git a/packages/DomainCode-Parser/DCBlock.class.st b/packages/DomainCode-Parser/DCBlock.class.st index 5b85811..4dda76a 100644 --- a/packages/DomainCode-Parser/DCBlock.class.st +++ b/packages/DomainCode-Parser/DCBlock.class.st @@ -72,6 +72,14 @@ DCBlock class >> fromCursor: aCursor language: aLanguage [ range: aCursor range] ] +{ #category : #generic } +DCBlock class >> genericAddMarker [ + + + ^ { + [:x | x registerShortcut: #addMarker do: [{[:block | block attachDecorator: SBMarkedDecorator new]}]]} +] + { #category : #'as yet unclassified' } DCBlock class >> parse: aString language: aLanguage [ @@ -132,7 +140,8 @@ DCBlock class >> registerShortcuts: aProvider [ aProvider cmdShortcut: $[ do: #wrapInSquareBrackets. aProvider cmdShortcut: $' do: #wrapInSingleQuotes. aProvider cmdShortcut: $" do: #wrapInDoubleQuotes. - aProvider cmdShortcut: $` do: #wrapInBackticks + aProvider cmdShortcut: $` do: #wrapInBackticks. + aProvider shortcut: $M command do: #addMarker ] { #category : #smalltalk } @@ -181,6 +190,20 @@ DCBlock class >> smalltalkBrowseReferencesSend [ ifFalse: [message sandblockEditor open: calls first compiledMethod]]}]]} ] +{ #category : #smalltalk } +DCBlock class >> smalltalkCheckbox [ + + + ^ { + [:x | x language = SBTSSmalltalk]. + [:x | x isReplacement not]. + [:x | {#true. #false} includes: x type]. + [:x | + x installReplacement: (DCCheckbox new + fromSource: [:source :repl | repl checked: source contents = 'true'] + toSource: [:source :repl | source contents: (repl checked ifTrue: ['true'] ifFalse: ['false'])])]} +] + { #category : #smalltalk } DCBlock class >> smalltalkDeclaration [ @@ -267,7 +290,7 @@ DCBlock class >> smalltalkUndeclaredVariable [ container: temporaries; index: temporaries submorphCount)] ifNone: [ | index | - index := block submorphs findFirst: [:s | s treeLabel = '|']. + index := block children findFirst: [:s | s treeLabel = '|']. node sandblockEditor do: (SBInsertCommand new morph: (DCBlock new type: #temporaries; @@ -297,9 +320,12 @@ DCBlock class >> smalltalkUnusedVariable [ DCBlock class >> smalltalkUsesOfDeclaration [ ^ { - [:decl | {#args. decl. decl orAnyParent: #(block method)}]. - [:decl :scope | {#args. decl. scope allBlocksSelect: [:x | (#(identifier block_argument) includes: x type) and: [(x contents withoutLeading: #($:)) = (decl contents withoutLeading: #($:))]]}] - } + [:decl | {#args. decl. decl orAnyParent: #(#block #method)}]. + [:decl :scope | + { + #args. + decl. + scope allChildrenSelect: [:x | (#(#identifier #'block_argument') includes: x type) and: [(x contents withoutLeading: #($:)) = (decl contents withoutLeading: #($:))]]}]} ] { #category : #'as yet unclassified' } @@ -307,7 +333,7 @@ DCBlock >> absolutePositionOf: aMorph [ | n | n := 0. - self allMorphsDo: [:m | + self allChildrenDo: [:m | n := n + 1. m = aMorph ifTrue: [^ n]]. ^ self assert: false @@ -365,7 +391,7 @@ DCBlock >> allParentsUpTo: aBlock [ { #category : #'as yet unclassified' } DCBlock >> allTextMorphsDo: aBlock [ - self allMorphsDo: [:m | m isTextMorph ifTrue: [aBlock value: m]] + self allChildrenDo: [:m | m isTextMorph ifTrue: [aBlock value: m]] ] { #category : #'as yet unclassified' } @@ -383,7 +409,7 @@ DCBlock >> attachHighlight [ { #category : #'as yet unclassified' } DCBlock >> blockFor: aRange [ - self allMorphsDo: [:block | (block isTSMorph and: [block range = aRange]) ifTrue: [^ block]]. + self allChildrenDo: [:block | (block isTSMorph and: [block range = aRange]) ifTrue: [^ block]]. ^ nil ] @@ -403,7 +429,7 @@ DCBlock >> contentsToDisplay [ DCBlock >> copyRangesFrom: newTree to: oldTree [ oldTree range: newTree range. - newTree submorphs with: oldTree submorphs do: [:a :b | self copyRangesFrom: a to: b] + newTree children with: oldTree children do: [:a :b | self copyRangesFrom: a to: b] ] { #category : #'as yet unclassified' } @@ -494,7 +520,7 @@ DCBlock >> findLastMatchingAncesors: aCollection oldTree: aBlock [ | oldCurrent | oldCurrent := aBlock. aCollection allButLast reverseDo: [:newCurrent | - oldCurrent := oldCurrent submorphs at: newCurrent submorphIndex ifAbsent: [ + oldCurrent := oldCurrent children at: newCurrent submorphIndex ifAbsent: [ self assert: oldCurrent type = newCurrent owner type. ^ {oldCurrent. newCurrent owner}]. oldCurrent type = newCurrent type ifFalse: [ @@ -618,7 +644,7 @@ DCBlock >> inputClosestTextMorphTo: cursorPosition [ atStart := false. "match on same line" - self allMorphsDo: [:t | + self allChildrenDo: [:t | t isTextMorph ifTrue: [ t range start line = cursorPosition line ifTrue: [ | distance | distance := (t range start character - cursorPosition character) abs. @@ -635,7 +661,7 @@ DCBlock >> inputClosestTextMorphTo: cursorPosition [ "match on different line" best ifNil: [ - self allMorphsDo: [:t | + self allChildrenDo: [:t | t isTextMorph ifTrue: [ | distance | distance := (t range start line - cursorPosition line) abs min: (t range end line - cursorPosition line) abs. distance < bestDistance ifTrue: [ @@ -690,6 +716,12 @@ DCBlock >> insertStatementHasCandidate [ ^ true ] +{ #category : #'as yet unclassified' } +DCBlock >> installReplacement: aBlock [ + + self sandblockEditor do: (SBReplaceCommand new target: self replacer: (aBlock source: self)) +] + { #category : #'as yet unclassified' } DCBlock >> intoWorld: aWorld [ @@ -699,7 +731,8 @@ DCBlock >> intoWorld: aWorld [ self sandblockEditor when: #selectionChanged send: #updateSelectionQueries - to: self queryState] + to: self queryState. + self queryState updateChangeQueries] ] { #category : #'as yet unclassified' } @@ -730,6 +763,12 @@ DCBlock >> isPart [ ^ self highlight notNil and: [self highlight endsWith: '.part'] ] +{ #category : #'as yet unclassified' } +DCBlock >> isReplacement [ + + ^ false +] + { #category : #'as yet unclassified' } DCBlock >> isRootBlock [ @@ -949,7 +988,7 @@ DCBlock >> printOn: aStream [ DCBlock >> queryAll: aString [ ^ Array streamContents: [:stream | - self allMorphsDo: [:block | + self allChildrenDo: [:block | block isTSMorph ifTrue: [ (SBTSQuery new prepare: aString; @@ -1143,7 +1182,7 @@ DCBlock >> template [ { #category : #'as yet unclassified' } DCBlock >> textMorphForPosition: aPosition [ - self allMorphsDo: [:t | (t isTextMorph and: [t range contains: aPosition]) ifTrue: [^ t]]. + self allChildrenDo: [:t | (t isTextMorph and: [t range contains: aPosition]) ifTrue: [^ t]]. ^ nil ] @@ -1156,8 +1195,8 @@ DCBlock >> textMorphs [ { #category : #'as yet unclassified' } DCBlock >> treeHash [ - self hasSubmorphs ifFalse: [^ self treeHashChildren: 0]. - ^ self treeHashChildren: (self submorphs inject: 0 into: [:hash :morph | hash bitXor: morph treeHash]) + self hasChildren ifFalse: [^ self treeHashChildren: 0]. + ^ self treeHashChildren: (self children inject: 0 into: [:hash :morph | hash bitXor: morph treeHash]) ] { #category : #'as yet unclassified' } diff --git a/packages/DomainCode-Parser/DCCheckbox.class.st b/packages/DomainCode-Parser/DCCheckbox.class.st new file mode 100644 index 0000000..c0af22c --- /dev/null +++ b/packages/DomainCode-Parser/DCCheckbox.class.st @@ -0,0 +1,25 @@ +Class { + #name : #DCCheckbox, + #superclass : #DCReplacement, + #category : #'DomainCode-Parser' +} + +{ #category : #'as yet unclassified' } +DCCheckbox >> checked [ + + ^ self firstSubmorph value +] + +{ #category : #'as yet unclassified' } +DCCheckbox >> checked: aBoolean [ + + self firstSubmorph value: aBoolean +] + +{ #category : #'as yet unclassified' } +DCCheckbox >> initialize [ + + super initialize. + + self addMorphBack: SBCheckbox new +] diff --git a/packages/DomainCode-Parser/DCMockSlot.class.st b/packages/DomainCode-Parser/DCMockSlot.class.st index eb7de46..e08a38e 100644 --- a/packages/DomainCode-Parser/DCMockSlot.class.st +++ b/packages/DomainCode-Parser/DCMockSlot.class.st @@ -154,8 +154,8 @@ DCMockSlot >> type [ DCMockSlot >> updateAllHighlightsFor: aBlock [ morph language instance grammar hasHighlight ifFalse: [^ #'_sb_none']. - aBlock allMorphsDo: [:m | m isTSMorph ifTrue: [m highlight: #'_sb_none']]. - aBlock allMorphsBreadthFirstDo: [:m | m isTSMorph ifTrue: [m slot updateHighlightFor: m]]. + aBlock allChildrenDo: [:m | m isTSMorph ifTrue: [m highlight: #'_sb_none']]. + aBlock allChildrenBreadthFirstDo: [:m | m isTSMorph ifTrue: [m slot updateHighlightFor: m]]. ^ aBlock highlight ] diff --git a/packages/DomainCode-Parser/DCReplacement.class.st b/packages/DomainCode-Parser/DCReplacement.class.st new file mode 100644 index 0000000..154fe4f --- /dev/null +++ b/packages/DomainCode-Parser/DCReplacement.class.st @@ -0,0 +1,92 @@ +Class { + #name : #DCReplacement, + #superclass : #DCBlock, + #instVars : [ + 'source', + 'bindings' + ], + #category : #'DomainCode-Parser' +} + +{ #category : #'as yet unclassified' } +DCReplacement >> children [ + + ^ self source children +] + +{ #category : #'as yet unclassified' } +DCReplacement >> fromSource: aBlock toSource: anotherBlock [ + + bindings add: aBlock -> anotherBlock +] + +{ #category : #'as yet unclassified' } +DCReplacement >> initialize [ + + super initialize. + bindings := OrderedCollection new +] + +{ #category : #'as yet unclassified' } +DCReplacement >> isNode: aNode [ + + ^ self source = aNode +] + +{ #category : #'as yet unclassified' } +DCReplacement >> isReplacement [ + + ^ true +] + +{ #category : #'as yet unclassified' } +DCReplacement >> layoutCommands [ + + ^ SBAlgebraCommand container + morph: self; + data: (self submorphs collect: [:s | s layoutCommands] separatedBy: [SBAlgebraCommand softLine]) +] + +{ #category : #'as yet unclassified' } +DCReplacement >> source [ + + ^ source +] + +{ #category : #'as yet unclassified' } +DCReplacement >> source: aBlock [ + + source := aBlock. + bindings do: [:assoc | assoc key value: self source value: self] +] + +{ #category : #'as yet unclassified' } +DCReplacement >> treeHash [ + + ^ self source treeHash +] + +{ #category : #'as yet unclassified' } +DCReplacement >> treeLabel [ + + ^ self source treeLabel +] + +{ #category : #'as yet unclassified' } +DCReplacement >> type [ + + ^ self source type +] + +{ #category : #'as yet unclassified' } +DCReplacement >> updateSourceDuring: aBlock [ + + bindings do: [:assoc | assoc value value: self source value: self]. + aBlock value +] + +{ #category : #'as yet unclassified' } +DCReplacement >> writeSourceOn: aStream indent: aNumber forCompare: aBoolean [ + + self updateSourceDuring: [self source writeSourceOn: aStream indent: aNumber forCompare: aBoolean] +]