From a20b62e607c098280f74536ed51812e254c43c37 Mon Sep 17 00:00:00 2001 From: Tom Beckmann Date: Wed, 4 Oct 2023 11:26:53 +0200 Subject: [PATCH] dc: fix off-by-one in stmt insert, add create-new-method --- packages/DomainCode-Diff/DCMatcher.class.st | 2 +- packages/DomainCode-Parser/DCBlock.class.st | 62 ++++++++++++---- .../DCJumpPlaceholder.class.st | 1 - .../DomainCode-Parser/DCQueryState.class.st | 73 +++++++++++++++---- .../DomainCode-Parser/DCReplacement.class.st | 15 ++++ .../DCSmalltalkMethod.class.st | 15 +++- .../SBTSSmalltalk.class.st | 4 + 7 files changed, 140 insertions(+), 32 deletions(-) diff --git a/packages/DomainCode-Diff/DCMatcher.class.st b/packages/DomainCode-Diff/DCMatcher.class.st index 4e2b11e..67d998b 100644 --- a/packages/DomainCode-Diff/DCMatcher.class.st +++ b/packages/DomainCode-Diff/DCMatcher.class.st @@ -71,7 +71,7 @@ DCMatcher >> fineGrainedMatchFrom: src to: dest in: aMapping [ self halt. topSrc ifNotNil: [ - self assert: (aMapping destForSrc: topSrc owner) = topDest parent. + self assert: (aMapping destForSrc: topSrc parent) = topDest parent. DCGreedyBottomUpMatcher new sizeThreshold: 900000000; lastChanceMatchFrom: topSrc to: topDest in: aMapping] diff --git a/packages/DomainCode-Parser/DCBlock.class.st b/packages/DomainCode-Parser/DCBlock.class.st index f162041..56c6813 100644 --- a/packages/DomainCode-Parser/DCBlock.class.st +++ b/packages/DomainCode-Parser/DCBlock.class.st @@ -205,6 +205,21 @@ DCBlock class >> smalltalkCheckbox [ toSource: [:source :repl | source contents: (repl checked ifTrue: ['true'] ifFalse: ['false'])])]} ] +{ #category : #smalltalk } +DCBlock class >> smalltalkCreateNewMethod [ + + + ^ { + [:x | x language = SBTSSmalltalk]. + [:x | + x registerShortcut: #createNewEmptyModule do: [ + { + [:e | | method | + method := DCSmalltalkMethod emptyIn: e containingArtefact methodClass. + e sandblockEditor openMorphInView: method. + method firstDeepChild startInputAtEnd]}]]} +] + { #category : #smalltalk } DCBlock class >> smalltalkDeclaration [ @@ -303,20 +318,20 @@ DCBlock class >> smalltalkInsertArg [ id := DCQuery script: {self smalltalkMethodArguments. [:args | (args at: index) contents]} with: block. - block type ~= #identifier - ifTrue: [block insert: id] - ifFalse: [block replaceWith: id]]}]]]} + (block type = #identifier or: [block sandblockEditor mode = #command]) + ifTrue: [block replaceWith: id] + ifFalse: [block insert: id]]}]]]} ] { #category : #smalltalk } DCBlock class >> smalltalkJumpPlaceholder [ - + ^ { [:x | x language = SBTSSmalltalk]. - [:x | x type = #identifier]. + [:x | #(#identifier #'unary_identifier') includes: x type]. [:x | x contents = '__sb']. - [:x | x installReplacement: DCJumpPlaceholder new]} + [:x | x ensureReplacement: DCJumpPlaceholder initDo: [:b | ]]} ] { #category : #smalltalk } @@ -519,8 +534,9 @@ DCBlock >> allParentsUpTo: aBlock [ { #category : #'as yet unclassified' } DCBlock >> allTextMorphsDo: aBlock [ + "iterate over morphs, not children, as we're looking for visible text morphs" - self allChildrenDo: [:m | m isTextMorph ifTrue: [aBlock value: m]] + self allMorphsDo: [:m | m isTextMorph ifTrue: [aBlock value: m]] ] { #category : #'as yet unclassified' } @@ -646,6 +662,12 @@ DCBlock >> encompasses: aRange [ ^ self range encompasses: aRange ] +{ #category : #'query actions' } +DCBlock >> ensureReplacement: aClass initDo: aBlock [ + + self queryState ensureReplacement: aClass for: self initDo: aBlock +] + { #category : #'as yet unclassified' } DCBlock >> field [ @@ -861,13 +883,16 @@ DCBlock >> insertStatementAboveOrBelow: anAboveBoolean [ in: self morph: (DCEmptyStatement new language: self language))]. - (self orOwnerSuchThat: [:morph | morph isTSBlock and: [morph isStatement]]) ifNotNil: [:statement | | target | + (self orOwnerSuchThat: [:morph | morph isTSBlock and: [morph isStatement]]) ifNotNil: [:statement | | target after | target := (anAboveBoolean not and: [(statement submorphAfter ifNotNil: #treeLabel) = self language statementTerminator]) ifTrue: [statement submorphAfter] - ifFalse: [statement]. + ifFalse: [ + "if we do not have a trailing dot, we need to insert the dot before the element" + after := anAboveBoolean not. + statement]. self sandblockEditor do: (SBRelInsertCommand new near: target before: anAboveBoolean in: statement owner morph: (DCEmptyStatement new language: self language; - after: anAboveBoolean not; + after: after; contents: (SBToggledCode comment: '' active: 1 do: {['']. [self language statementTerminator]})))] ] @@ -970,7 +995,7 @@ DCBlock >> keyStroke: anEvent [ insert: text in: source at: cursorIndex + 1 - do: [:new :edit | apply value: new value: edit value: cursorIndex + 1]]]]. + do: [:new :edit | apply value: new value: edit value: (cursorIndex + (text indexOf: anEvent keyCharacter))]]]]. self batchedChangeStep ] @@ -1012,13 +1037,13 @@ DCBlock >> layoutCommands [ { #category : #'as yet unclassified' } DCBlock >> layoutInset [ - self isBlockBody ifTrue: [^ 2 @ 2]. + self isBlockBody ifTrue: [^ 4 @ 3]. - true ifTrue: [^ super layoutInset]. + SBToggledCode comment: '' active: 0 do: {[true ifTrue: [^ super layoutInset]]}. ^ (self type = 'ERROR' and: [self childSandblocks notEmpty]) ifTrue: [0] - ifFalse: [2 @ (self submorphCount > 3 ifTrue: [1] ifFalse: [0])] + ifFalse: [2 @ (self submorphCount > 3 ifTrue: [2] ifFalse: [0])] ] { #category : #hierarchy } @@ -1236,10 +1261,15 @@ DCBlock >> registerShortcut: aSymbol do: aBlock [ DCBlock >> reloadArtefact [ - self sandblockEditor do: (SBReplaceCommand new target: self containingArtefact replacer: ((DCSmalltalkMethod for: self containingArtefact object) + | method | + method := (DCSmalltalkMethod for: self containingArtefact object) hResizing: self containingArtefact hResizing; width: self containingArtefact width; - yourself)) + yourself. + + self sandblockEditor do: (SBReplaceCommand new target: self containingArtefact replacer: method). + + method firstDeepChild startInputAtEnd ] { #category : #'text modify' } diff --git a/packages/DomainCode-Parser/DCJumpPlaceholder.class.st b/packages/DomainCode-Parser/DCJumpPlaceholder.class.st index b48a94e..beb3cd6 100644 --- a/packages/DomainCode-Parser/DCJumpPlaceholder.class.st +++ b/packages/DomainCode-Parser/DCJumpPlaceholder.class.st @@ -7,7 +7,6 @@ Class { { #category : #'as yet unclassified' } DCJumpPlaceholder >> adaptInput: input in: source at: cursorIndex textMorph: textMorph event: anEvent [ - self halt. (super adaptInput: input in: source at: cursorIndex textMorph: textMorph event: anEvent) ifNotEmpty: [:newInput | self replace: self range diff --git a/packages/DomainCode-Parser/DCQueryState.class.st b/packages/DomainCode-Parser/DCQueryState.class.st index e1f053f..93462b2 100644 --- a/packages/DomainCode-Parser/DCQueryState.class.st +++ b/packages/DomainCode-Parser/DCQueryState.class.st @@ -7,7 +7,9 @@ Class { 'rootBlock', 'currentShortcut', 'updateQueued', - 'suggestions' + 'suggestions', + 'transientReplacements', + 'currentTrigger' ], #category : #'DomainCode-Parser' } @@ -23,6 +25,24 @@ DCQueryState >> addSuggestions: aCollection for: aBlock [ aBlock updateSuggestions ] +{ #category : #'as yet unclassified' } +DCQueryState >> ensureReplacement: aClass for: aBlock initDo: aClosure [ + + | replacement | + replacement := aBlock class = aClass + ifFalse: [ | r hadFocus | + hadFocus := aBlock sandblockEditor textFocus ifNotNil: [:t | t hasAnyParent: aBlock] ifNil: [false]. + r := aClass new. + aBlock replacedParent: r. + aClosure value: r. + r source: aBlock. + aBlock replaceBy: r. + hadFocus ifTrue: [r startInputAtEnd]. + r] + ifTrue: [aBlock]. + (transientReplacements at: currentTrigger) add: replacement +] + { #category : #'as yet unclassified' } DCQueryState >> errors [ @@ -40,11 +60,11 @@ DCQueryState >> initialize [ super initialize. - currentDecorators := Dictionary new - at: #selection put: WeakKeyDictionary new; - at: #change put: WeakKeyDictionary new; - at: #type put: WeakKeyDictionary new; - yourself. + currentDecorators := Dictionary new. + transientReplacements := Dictionary new. + self triggers do: [:t | + currentDecorators at: t put: WeakKeyDictionary new. + transientReplacements at: t put: WeakSet new]. updateQueued := Dictionary new ] @@ -76,15 +96,11 @@ DCQueryState >> reportError: aDecorator for: aBlock [ { #category : #'as yet unclassified' } DCQueryState >> rerunQueriesFor: aSymbol do: aBlock [ - | oldDecorators | - newDecorators := WeakKeyDictionary new. + currentTrigger := aSymbol. - aBlock value. + self updateTransientReplacementsDuring: [self updateDecoratorsDuring: [aBlock value]]. - oldDecorators := currentDecorators at: aSymbol. - oldDecorators do: [:list | list do: [:d | d detach]]. - newDecorators keysAndValuesDo: [:block :list | list do: [:d | block attachDecorator: d]]. - currentDecorators at: aSymbol put: newDecorators + currentTrigger := nil ] { #category : #accessing } @@ -105,6 +121,12 @@ DCQueryState >> suggestionsFor: aBlock [ ^ suggestions key = aBlock ifTrue: [suggestions value] ifFalse: [{}] ] +{ #category : #'as yet unclassified' } +DCQueryState >> triggers [ + + ^ #(#shortcut #change #type #selection) +] + { #category : #shortcuts } DCQueryState >> tryShortcut: aSymbol do: aBlock [ @@ -120,6 +142,20 @@ DCQueryState >> updateChangeQueries [ self updateTypeQueries ] +{ #category : #'as yet unclassified' } +DCQueryState >> updateDecoratorsDuring: aBlock [ + + | oldDecorators | + newDecorators := WeakKeyDictionary new. + + aBlock value. + + oldDecorators := currentDecorators at: currentTrigger. + oldDecorators do: [:list | list do: [:d | d detach]]. + newDecorators keysAndValuesDo: [:block :list | list do: [:d | block attachDecorator: d]]. + currentDecorators at: currentTrigger put: newDecorators +] + { #category : #'as yet unclassified' } DCQueryState >> updateQueriesFor: aSymbol [ @@ -139,6 +175,17 @@ DCQueryState >> updateSelectionQueries [ self updateQueriesFor: #selection ] +{ #category : #'as yet unclassified' } +DCQueryState >> updateTransientReplacementsDuring: aBlock [ + + | old new | + old := transientReplacements at: currentTrigger. + new := WeakSet new. + transientReplacements at: currentTrigger put: new. + aBlock value. + old do: [:r | (new includes: r) ifFalse: [r uninstall]] +] + { #category : #'as yet unclassified' } DCQueryState >> updateTypeQueries [ diff --git a/packages/DomainCode-Parser/DCReplacement.class.st b/packages/DomainCode-Parser/DCReplacement.class.st index 387a7d2..c11930d 100644 --- a/packages/DomainCode-Parser/DCReplacement.class.st +++ b/packages/DomainCode-Parser/DCReplacement.class.st @@ -84,6 +84,21 @@ DCReplacement >> type [ ^ self source type ] +{ #category : #'as yet unclassified' } +DCReplacement >> uninstall [ + + | hadFocus | + self parent ifNil: [^ self]. + hadFocus := self sandblockEditor textFocus + ifNotNil: [:t | t hasAnyParent: self] + ifNil: [false]. + + self source replacedParent: nil. + self replaceBy: self source. + + hadFocus ifTrue: [self source startInputAtEnd] +] + { #category : #'as yet unclassified' } DCReplacement >> updateSourceDuring: aBlock [ diff --git a/packages/DomainCode-Parser/DCSmalltalkMethod.class.st b/packages/DomainCode-Parser/DCSmalltalkMethod.class.st index 1749973..8560fa9 100644 --- a/packages/DomainCode-Parser/DCSmalltalkMethod.class.st +++ b/packages/DomainCode-Parser/DCSmalltalkMethod.class.st @@ -7,10 +7,16 @@ Class { #category : #'DomainCode-Parser' } +{ #category : #'as yet unclassified' } +DCSmalltalkMethod class >> emptyIn: aClass [ + + ^ self new emptyIn: aClass +] + { #category : #'as yet unclassified' } DCSmalltalkMethod class >> for: aCompiledMethod [ - ^ self new for: aCompiledMethod + ^ aCompiledMethod isSandblock ifFalse: [self new for: aCompiledMethod] ifTrue: [self new emptyIn: aCompiledMethod methodClass] ] { #category : #'as yet unclassified' } @@ -20,6 +26,13 @@ DCSmalltalkMethod >> browse [ Browser newOnClass: self methodClass selector: self selector ] +{ #category : #'as yet unclassified' } +DCSmalltalkMethod >> emptyIn: aClass [ + + methodClass := aClass. + self addMorphBack: (DCBlock parseBlock: '__sb' language: SBTSSmalltalk) +] + { #category : #'as yet unclassified' } DCSmalltalkMethod >> for: aCompiledMethod [ diff --git a/packages/Sandblocks-TSSmalltalk/SBTSSmalltalk.class.st b/packages/Sandblocks-TSSmalltalk/SBTSSmalltalk.class.st index be7df24..d4c6d45 100644 --- a/packages/Sandblocks-TSSmalltalk/SBTSSmalltalk.class.st +++ b/packages/Sandblocks-TSSmalltalk/SBTSSmalltalk.class.st @@ -1176,6 +1176,8 @@ SBTSSmalltalk class >> highlightQuery [ (string) @string (symbol) @string (character) @string +(comment) @comment +(block "|" @punctuation) (identifier) @variable (block_argument) @variable @@ -1195,6 +1197,8 @@ SBTSSmalltalk class >> highlightQuery [ (binary_selector (binary_operator) @major_declaration.part) @structure.part (unary_selector (unary_identifier) @major_declaration.part) @structure.part +[(pragma_keyword_selector) (pragma_unary_selector) (pragma_binary_selector)] @structure.part + (temporaries) @punctuation.part (temporaries (identifier) @punctuation)' ]