dc: improve layout of smalltalk code

packages/DomainCode-Core/CompiledMethod.extension.st

@@ -0,0 +1,9 @@
+Extension { #name : #CompiledMethod }
+
+{ #category : #'*DomainCode-Core' }
+CompiledMethod >> openDC: convert [
+	<convert>
+	<convertPriority: 13>
+
+	convert do: [DCSmalltalkMethod for: self]
+]

packages/DomainCode-Parser/DCBlock.class.st

@@ -11,6 +11,22 @@ Class {
 	#category : #'DomainCode-Parser'
 }
 
+{ #category : #'as yet unclassified' }
+DCBlock class >> addUncapturedTextTo: aNode in: aCursor language: aLanguage isLeaf: aBoolean [
+
+	| text |
+	text := aCursor textToNext.
+	(text occurrencesOf: Character lf) - 1 timesRepeat: [aNode addMorphBack: (DCUnknown new language: aLanguage)].
+
+	aBoolean ifTrue: [text := aLanguage instance grammar trimExtra: aCursor uncapturedText].
+
+	(aLanguage instance grammar trimExtra: text) ifNotEmpty: [:t |
+		aNode addMorphBack: (DCText new
+			contents: t;
+			field: aCursor fieldName;
+			range: aCursor range)]
+]
+
 { #category : #'as yet unclassified' }
 DCBlock class >> findChangeRangeFrom: original to: new [
 
@@ -43,16 +59,11 @@ DCBlock class >> fromCursor: aCursor language: aLanguage [
 			aCursor gotoFirstChild
 				ifTrue: [
 					[
-						aCursor numberOfNewLinesToNext - 1 timesRepeat: [node addMorphBack: (DCUnknown new language: aLanguage)].
+						self addUncapturedTextTo: node in: aCursor language: aLanguage isLeaf: false.
 						node addMorphBack: (self fromCursor: aCursor language: aLanguage)] doWhileFalse: [aCursor gotoNextSibling].
+					self addUncapturedTextTo: node in: aCursor language: aLanguage isLeaf: false.
 					aCursor gotoParent]
-				ifFalse: [
-					aCursor text ifNotEmpty: [:text |
-						node addMorphBack: (DCText new
-							contents: text;
-							field: aCursor fieldName;
-							range: aCursor range)]].
-
+				ifFalse: [self addUncapturedTextTo: node in: aCursor language: aLanguage isLeaf: true].
 			node]
 		ifFalse: [
 			DCText new
@@ -135,6 +146,32 @@ DCBlock >> absolutePositionOf: aMorph [
 	^ self assert: false
 ]
 
+{ #category : #'as yet unclassified' }
+DCBlock >> adaptInput: input in: source at: cursorIndex textMorph: textMorph event: anEvent [
+	"do not place closing pair characters if they are coming up right after"
+
+	(self pairMap keyAtValue: input ifAbsent: nil) ifNotNil: [:openChar |
+		(source at: cursorIndex + 1 ifPresent: [:char | input first = char] ifAbsent: [false]) ifTrue: [
+			self owner startInputAtSourceIndex: cursorIndex + 1.
+			^ '']].
+	
+	self pairMap at: input ifPresent: [:complete |
+		"do not autocomplete quotes in words"
+		(complete = '''' and: [source at: cursorIndex ifPresent: #isAlphaNumeric ifAbsent: [false]]) ifTrue: [^ input].
+		
+		"do not autocomplete after backslash"
+		textMorph characterBeforeCursor = $\ ifTrue: [^ input].
+		
+		^ input, complete].
+	
+	"for separators, don't re-parse immediately, as those get discarded during parse"
+	^ input first isSeparator
+		ifTrue: [
+			textMorph keyStroke: anEvent.
+			'']
+		ifFalse: [input]
+]
+
 { #category : #'as yet unclassified' }
 DCBlock >> alias [
 
@@ -245,6 +282,15 @@ DCBlock >> drawnColor [
 		ifFalse: [super drawnColor]
 ]
 
+{ #category : #'as yet unclassified' }
+DCBlock >> emphasis [
+
+	self highlight ifNotNil: [:h |
+		(h beginsWith: 'major_declaration') ifTrue: [^ TextEmphasis bold].
+		self type = #comment ifTrue: [^ TextEmphasis italic]].
+	^ self colorPolicy defaultEmphasis
+]
+
 { #category : #'as yet unclassified' }
 DCBlock >> encompasses: aRange [
 
@@ -439,12 +485,12 @@ DCBlock >> insertStatementAboveOrBelow: anAboveBoolean [
 			morph: (DCUnknown new language: self language))].
 	
 	(self orOwnerSuchThat: [:morph | morph isTSBlock and: [morph isStatement]]) ifNotNil: [:statement | | target |
-		target := ((statement morphBeforeOrAfter: anAboveBoolean) ifNotNil: #treeLabel) = self language statementTerminator
-			ifTrue: [statement morphBeforeOrAfter: anAboveBoolean]
+		target := (anAboveBoolean not and: [(statement submorphAfter ifNotNil: #treeLabel) = self language statementTerminator])
+			ifTrue: [statement submorphAfter]
 			ifFalse: [statement].
 		self sandblockEditor do: (SBRelInsertCommand new near: target before: anAboveBoolean in: statement owner morph: (DCUnknown new
 			language: self language;
-			contents: self language statementTerminator))]
+			contents: (SBToggledCode comment: '' active: 1 do: {['']. [self language statementTerminator]})))]
 ]
 
 { #category : #'as yet unclassified' }
@@ -480,31 +526,15 @@ DCBlock >> isTSMorph [
 { #category : #'as yet unclassified' }
 DCBlock >> keyStroke: anEvent [
 
-	self tryApplyChange: [:source :textMorph :cursorIndex :apply | | input insert |
+	self tryApplyChange: [:source :textMorph :cursorIndex :apply | | input |
 		input := anEvent keyCharacter asString.
-		insert := [:str |
-			self
-				insert: str
-				in: source
-				at: cursorIndex + 1
-				do: [:new :edit | apply value: new value: edit value: cursorIndex + 1]].
 		(input first isPrintable and: [anEvent commandKeyPressed not]) ifTrue: [
-			"do not place closing pair characters if they are coming up right after"
-			(self pairMap keyAtValue: input ifAbsent: nil) ifNotNil: [:openChar | (source at: cursorIndex + 1 ifPresent: [:char | input first = char] ifAbsent: [false]) ifTrue: [^ self owner startInputAtSourceIndex: cursorIndex + 1]].
-			
-			self pairMap at: input ifPresent: [:complete |
-				"do not autocomplete quotes in words"
-				(complete = '''' and: [source at: cursorIndex ifPresent: #isAlphaNumeric ifAbsent: [false]]) ifTrue: [^ insert value: input].
-				
-				"do not autocomplete after backslash"
-				textMorph characterBeforeCursor = $\ ifTrue: [^ insert value: input].
-				
-				^ insert value: input, complete].
-			
-			"for separators, don't re-parse immediately, as those get discarded during parse"
-			^ input first isSeparator
-				ifTrue: [textMorph keyStroke: anEvent]
-				ifFalse: [insert value: input]]]
+			(self adaptInput: input in: source at: cursorIndex textMorph: textMorph event: anEvent) ifNotEmpty: [:text |
+				self
+					insert: text
+					in: source
+					at: cursorIndex + 1
+					do: [:new :edit | apply value: new value: edit value: cursorIndex + 1]]]]
 ]
 
 { #category : #'as yet unclassified' }
@@ -545,9 +575,11 @@ DCBlock >> layoutCommands [
 { #category : #'as yet unclassified' }
 DCBlock >> layoutInset [
 
+	self isBlockBody ifTrue: [^ 2 @ 2].
+	
 	^ (self type = 'ERROR' and: [self childSandblocks notEmpty])
 		ifTrue: [0]
-		ifFalse: [super layoutInset]
+		ifFalse: [2 @ (self submorphCount > 3 ifTrue: [1] ifFalse: [0])]
 ]
 
 { #category : #'as yet unclassified' }
@@ -593,12 +625,31 @@ DCBlock >> prefersNoBorder [
 	^ self isPart
 ]
 
+{ #category : #'as yet unclassified' }
+DCBlock >> prettySourceString [
+
+	self allBlocksDo: [:b | b valid ifFalse: [^ self sourceString]].
+	^ self language runtime
+		ifNotNil: [:r | r prettyPrint: self sourceString]
+		ifNil: [self sourceString]
+]
+
 { #category : #'as yet unclassified' }
 DCBlock >> printOn: aStream [
 
 	aStream nextPutAll: self type
 ]
 
+{ #category : #'as yet unclassified' }
+DCBlock >> queryAll: aString [
+
+	^ Array streamContents: [:stream |
+		self allMorphsDo: [:block |
+			block isTSMorph ifTrue: [ | captures |
+				captures := nil.
+				(SBTSQuery new execute: aString against: block capturesDo: [:cap | captures := cap]) ifTrue: [stream nextPut: captures anyOne]]]]
+]
+
 { #category : #'as yet unclassified' }
 DCBlock >> range [
 
@@ -780,7 +831,7 @@ DCBlock >> treeHash [
 { #category : #'as yet unclassified' }
 DCBlock >> treeHashChildren: anotherNumber [
 
-	^ ((self type hash bitXor: 'ENTER' hash) bitXor: anotherNumber) bitXor: 'LEAVE' hash
+	^ (((self type hash bitXor: 'ENTER' hash) bitXor: anotherNumber) bitXor: self submorphIndex hash) bitXor: 'LEAVE' hash
 ]
 
 { #category : #'as yet unclassified' }

packages/DomainCode-Parser/DCMockSlot.class.st

@@ -78,15 +78,22 @@ DCMockSlot >> parentThat: aBlock [
 
 { #category : #'as yet unclassified' }
 DCMockSlot >> preferredColorIn: aColorPolicy for: aHighlightString [
+	" specific "
 
-	^ aHighlightString
+	aHighlightString
+		caseOf: {
+			['variable.part'] -> [^ aColorPolicy default].
+			['variable.builtin'] -> [^ aColorPolicy identifier]}
+		otherwise: [].
+
+	" general "
+	^ (aHighlightString copyUpTo: $.)
 		caseOf: {
 			['keyword'] -> [aColorPolicy keyword].
 			['function'] -> [aColorPolicy identifier].
 			['comment'] -> [aColorPolicy defaultLight].
+			['punctuation'] -> [aColorPolicy defaultLight].
 			['variable'] -> [aColorPolicy identifier].
-			['variable.part'] -> [aColorPolicy default].
-			['variable.builtin'] -> [aColorPolicy identifier].
 			['type'] -> [aColorPolicy keyword].
 			['number'] -> [aColorPolicy literal].
 			['string'] -> [aColorPolicy literal].
@@ -146,15 +153,13 @@ DCMockSlot >> type [
 DCMockSlot >> updateAllHighlightsFor: aBlock [
 
 	morph language instance grammar hasHighlight ifFalse: [^ #'_sb_none'].
-	aBlock allMorphsDo: [:m |
-		m isTSMorph ifTrue: [
-			m highlight: #'_sb_none'.
-			m slot updateHighlightFor: m]].
+	aBlock allMorphsDo: [:m | m isTSMorph ifTrue: [m highlight: #'_sb_none']].
+	aBlock allMorphsBreadthFirstDo: [:m | m isTSMorph ifTrue: [m slot updateHighlightFor: m]].
 	^ aBlock highlight
 ]
 
 { #category : #'as yet unclassified' }
 DCMockSlot >> updateHighlightFor: aBlock [
 
-	morph language instance grammar highlightQuery ifNotNil: [:query | (query executeCaptureAgainst: aBlock) do: [:pair | (pair value highlight isNil or: [pair value highlight = #'_sb_none' or: [pair value highlight size < pair key size]]) ifTrue: [pair value highlight: pair key]]]
+	morph language instance grammar highlightQuery ifNotNil: [:query | (query executeCaptureAgainst: aBlock) do: [:pair | (pair value highlight isNil or: [pair value highlight = #'_sb_none' or: [(pair value highlight occurrencesOf: '.') < (pair key highlight occurrencesOf: '.')]]) ifTrue: [pair value highlight: pair key]]]
 ]

packages/DomainCode-Parser/DCSmalltalkMethod.class.st

@@ -0,0 +1,108 @@
+Class {
+	#name : #DCSmalltalkMethod,
+	#superclass : #SBBlock,
+	#instVars : [
+		'methodClass'
+	],
+	#category : #'DomainCode-Parser'
+}
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod class >> for: aCompiledMethod [
+
+	^ self new for: aCompiledMethod
+]
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> browse [
+	<action>
+
+	Browser newOnClass: self methodClass selector: self selector
+]
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> for: aCompiledMethod [
+
+	methodClass := aCompiledMethod methodClass.
+	self addMorphBack: (DCBlock parseBlock: aCompiledMethod getSource asString language: SBTSSmalltalk)
+]
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> initialize [
+
+	super initialize.
+
+	self
+		hResizing: #rigid;
+		vResizing: #shrinkWrap;
+		layoutPolicy: SBAlgebraLayout new;
+		attachDecorator: SBMoveDecorator new;
+		attachDecorator: SBResizableDecorator new;
+		layoutInset: 4
+]
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> isArtefact [
+
+	^ true
+]
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> isMethod [
+
+	^ true
+]
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> layoutCommands [
+
+	^ SBAlgebraCommand container
+		data: (self submorphs collect: [:b | b layoutCommands] separatedBy: [SBAlgebraCommand hardLine]);
+		morph: self
+]
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> method [
+
+	^ self firstSubmorph
+]
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> methodClass [
+
+	^ methodClass
+]
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> object [
+
+	^ (self methodClass ifNil: [^ self])
+		compiledMethodAt: self selector
+		ifAbsent: [self]
+]
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> saveTryFixing: aFixBoolean quick: aQuickBoolean [
+
+	| text newSelector |
+	text := aQuickBoolean
+		ifTrue: [self method sourceString]
+		ifFalse: [self method prettySourceString].
+	newSelector := self methodClass compile: text asText classified: nil.
+	^ true
+]
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> selector [
+
+	| selector |
+	selector := (self method queryAll: '[(unary_selector) (binary_selector) (keyword_selector)] @') first.
+
+	^ (((selector childSandblocks viewFrom: 1 by: 2) collect: [:p | p contents]) joinSeparatedBy: '') asSymbol
+]
+
+{ #category : #'as yet unclassified' }
+DCSmalltalkMethod >> type [
+
+	^ nil
+]

packages/DomainCode-Parser/DCText.class.st

@@ -33,6 +33,12 @@ DCText >> effectiveContents [
 	^ self contents
 ]
 
+{ #category : #'as yet unclassified' }
+DCText >> emphasis [
+
+	^ #derive
+]
+
 { #category : #'as yet unclassified' }
 DCText >> ensureLayouted [
 

packages/DomainCode-Parser/DCUnknown.class.st

@@ -4,6 +4,12 @@ Class {
 	#category : #'DomainCode-Parser'
 }
 
+{ #category : #'as yet unclassified' }
+DCUnknown >> adaptInput: input in: source at: cursorIndex textMorph: textMorph event: anEvent [
+
+	^ (super adaptInput: input in: source at: cursorIndex textMorph: textMorph event: anEvent), self language statementTerminator
+]
+
 { #category : #'as yet unclassified' }
 DCUnknown >> contents: aString [