dc: fix off-by-one in stmt insert, add create-new-method

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]

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 [
+	<query: #shortcut>
+
+	^ {
+		[: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 [
-	<query: #change>
+	<query: #type>
 
 	^ {
 		[: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 [
 	<action>
 
-	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' }

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

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 [
 

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 [
 

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 [
 

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)'
 ]