From 1c93efadbe5cd2588664be16faa72d005ea43be6 Mon Sep 17 00:00:00 2001 From: Pablo Tesone Date: Sat, 12 Oct 2024 19:26:31 +0200 Subject: [PATCH 01/20] Using unknownBytecode to improve the step through implementation --- src/Debugger-Model/Context.extension.st | 13 +++ .../EnhancedDebugSession.class.st | 80 +++++++++++++++++++ src/Debugging-Core/Context.extension.st | 5 +- src/Debugging-Core/UnknownBytecode.class.st | 27 +++++++ .../InstructionStream.class.st | 4 +- 5 files changed, 127 insertions(+), 2 deletions(-) create mode 100644 src/Debugger-Model/Context.extension.st create mode 100644 src/Debugger-Model/EnhancedDebugSession.class.st create mode 100644 src/Debugging-Core/UnknownBytecode.class.st diff --git a/src/Debugger-Model/Context.extension.st b/src/Debugger-Model/Context.extension.st new file mode 100644 index 00000000000..affcdc8401e --- /dev/null +++ b/src/Debugger-Model/Context.extension.st @@ -0,0 +1,13 @@ +Extension { #name : 'Context' } + +{ #category : '*Debugger-Model' } +Context >> privSetClosure: aBlockClosure [ + + closureOrNil := aBlockClosure +] + +{ #category : '*Debugger-Model' } +Context >> privSetMethod: aCompiledCode [ + + method := aCompiledCode +] diff --git a/src/Debugger-Model/EnhancedDebugSession.class.st b/src/Debugger-Model/EnhancedDebugSession.class.st new file mode 100644 index 00000000000..86a34520387 --- /dev/null +++ b/src/Debugger-Model/EnhancedDebugSession.class.st @@ -0,0 +1,80 @@ +Class { + #name : 'EnhancedDebugSession', + #superclass : 'DebugSession', + #instVars : [ + 'originalBlocks', + 'newBlocks' + ], + #category : 'Debugger-Model-Core', + #package : 'Debugger-Model', + #tag : 'Core' +} + +{ #category : 'menu - operations' } +EnhancedDebugSession >> findNextContext: aContext [ + + | blockContext idx | + originalBlocks ifEmpty: [ ^ aContext ]. + + (aContext receiver isKindOf: UnknownBytecode) ifFalse: [ ^ aContext ]. + aContext receiver bytecode = self bytecodeForHalt ifFalse: [ ^ aContext ]. + + "Climb up the context, if I found nil, just return the original context" + (blockContext := aContext sender) ifNil: [ ^aContext ]. + (blockContext := blockContext sender) ifNil: [ ^aContext ]. + (blockContext := blockContext sender) ifNil: [ ^aContext ]. + (blockContext := blockContext sender) ifNil: [ ^aContext ]. + + idx := newBlocks indexOf: blockContext closure ifAbsent: [ ^ aContext ]. + + blockContext privSetClosure: (originalBlocks at: idx). + blockContext privSetMethod: (originalBlocks at: idx) compiledBlock. + blockContext stepToSendOrReturn. + + ^ blockContext + +] + +{ #category : 'debugging actions' } +EnhancedDebugSession >> stepOver: aContext [ + "Send the selected message in selectedContext, and regain control + after the invoked method returns." + + | newContext | + aContext stepIntoQuickMethod: false. + (self isContextPostMortem: aContext) ifTrue: [^ self]. + + newContext := interruptedProcess completeStep: aContext. + self updateContextTo: + (newContext == aContext + ifTrue: [ (self stepToFirstInterestingBytecodeIn: interruptedProcess) ] + ifFalse: [ newContext ]). + + self triggerEvent: #stepOver +] + +{ #category : 'debugging actions' } +EnhancedDebugSession >> stepThrough: aContext [ + "Send messages until you return to selectedContext. + Used to step into a block in the method." + + | newContext | + + aContext stepIntoQuickMethod: false. + (self isContextPostMortem: aContext) ifTrue: [^ self]. + + self prepareContextForStepThrough: aContext. + + newContext := interruptedProcess completeStep: aContext. + + newContext := self findNextContext: newContext. + + self revertBlocks. + + self updateContextTo: + (newContext == aContext + ifTrue: [ (self stepToFirstInterestingBytecodeIn: interruptedProcess) ] + ifFalse: [ newContext ]). + + self triggerEvent: #stepThrough +] diff --git a/src/Debugging-Core/Context.extension.st b/src/Debugging-Core/Context.extension.st index e6d3be674a8..e529de024ac 100644 --- a/src/Debugging-Core/Context.extension.st +++ b/src/Debugging-Core/Context.extension.st @@ -77,7 +77,10 @@ Context >> respondsToUnknownBytecode [ | unknownBytecode | unknownBytecode := self compiledCode at: self pc. - self error: 'VM cannot run unknown bytecode ', unknownBytecode printString + ^ UnknownBytecode new + bytecode: unknownBytecode; + pc: self pc; + signal: 'VM cannot run unknown bytecode ', unknownBytecode printString ] { #category : '*Debugging-Core' } diff --git a/src/Debugging-Core/UnknownBytecode.class.st b/src/Debugging-Core/UnknownBytecode.class.st new file mode 100644 index 00000000000..2e6dc472e7f --- /dev/null +++ b/src/Debugging-Core/UnknownBytecode.class.st @@ -0,0 +1,27 @@ +Class { + #name : 'UnknownBytecode', + #superclass : 'Error', + #instVars : [ + 'pc', + 'bytecode' + ], + #category : 'Debugging-Core', + #package : 'Debugging-Core' +} + +{ #category : 'accessing' } +UnknownBytecode >> bytecode [ + ^ bytecode +] + +{ #category : 'accessing' } +UnknownBytecode >> bytecode: aValue [ + + bytecode := aValue +] + +{ #category : 'accessing' } +UnknownBytecode >> pc: aValue [ + + pc := aValue +] diff --git a/src/Kernel-CodeModel/InstructionStream.class.st b/src/Kernel-CodeModel/InstructionStream.class.st index 5918a6d80bd..014f95b32a7 100644 --- a/src/Kernel-CodeModel/InstructionStream.class.st +++ b/src/Kernel-CodeModel/InstructionStream.class.st @@ -262,7 +262,9 @@ InstructionStream >> interpretNextSistaV1InstructionFor: client [ offset < 8 ifTrue: [^client popIntoTemporaryVariable: offset]. offset = 8 ifTrue: [ ^ client doPop ]. - offset = 9 ifTrue: [ ^ client trap ]. + offset = 9 ifTrue: [ byte traceCr. +^ client trap ]. + ^self interpretUnusedBytecode: client at: savedPC]. "2 byte and 3 byte codes" byte < 248 ifTrue: From 03b5a968efcb0ba3b5ce587398e8435208f7a4d9 Mon Sep 17 00:00:00 2001 From: Pablo Tesone Date: Sat, 12 Oct 2024 19:26:56 +0200 Subject: [PATCH 02/20] Fixing critics --- .../EnhancedDebugSession.class.st | 48 +++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/src/Debugger-Model/EnhancedDebugSession.class.st b/src/Debugger-Model/EnhancedDebugSession.class.st index 86a34520387..53dcf6828e5 100644 --- a/src/Debugger-Model/EnhancedDebugSession.class.st +++ b/src/Debugger-Model/EnhancedDebugSession.class.st @@ -10,6 +10,12 @@ Class { #tag : 'Core' } +{ #category : 'accessing' } +EnhancedDebugSession >> bytecodeForHalt [ + + ^ 218 "This is an unknown bytecode that should be left always unknown to be used for halt in the image side" +] + { #category : 'menu - operations' } EnhancedDebugSession >> findNextContext: aContext [ @@ -35,6 +41,28 @@ EnhancedDebugSession >> findNextContext: aContext [ ] +{ #category : 'initialization' } +EnhancedDebugSession >> initialize [ + + super initialize. + originalBlocks := OrderedCollection new. + newBlocks := OrderedCollection new. +] + +{ #category : 'preparation' } +EnhancedDebugSession >> prepareContextForStepThrough: aContext [ + + 1 to: aContext size do: [ :idx | + self updateFullBlocksOf: aContext withIndex: idx ] +] + +{ #category : 'clean-up' } +EnhancedDebugSession >> revertBlocks [ + + newBlocks asArray elementsForwardIdentityTo: originalBlocks asArray. + +] + { #category : 'debugging actions' } EnhancedDebugSession >> stepOver: aContext [ "Send the selected message in selectedContext, and regain control @@ -78,3 +106,23 @@ EnhancedDebugSession >> stepThrough: aContext [ self triggerEvent: #stepThrough ] + +{ #category : 'preparation' } +EnhancedDebugSession >> updateFullBlocksOf: aContext withIndex: anIndex [ + + | originalBlock newBlock newCompiledBlock | + + originalBlock := aContext at: anIndex. + originalBlock isBlock ifFalse: [ ^ self ]. + + newBlock := originalBlock clone. + newCompiledBlock := newBlock compiledBlock clone. + newBlock compiledBlock: newCompiledBlock. + + newCompiledBlock byteAt: newCompiledBlock initialPC put: self bytecodeForHalt. + + originalBlocks add: originalBlock. + newBlocks add: newBlock. + + aContext at: anIndex put: newBlock. +] From 6b05d8d19dae1f0be2ddc526f37fe259fd3e9787 Mon Sep 17 00:00:00 2001 From: Ignacio Losiggio Date: Fri, 18 Oct 2024 17:31:42 +0200 Subject: [PATCH 03/20] SDL2: Ignore repeated events A change in SDL2 (https://github.com/libsdl-org/SDL/commit/61cd57d378e6bf5a62a8bf49e02164df63924c56) caused modifier changes to be sent as a repeat keydown with different key modifiers. This causes some keybindings to become un-typeable (For example: Cmd+Shift+W, E) because the keyup events cause these new keydown repeats with the new modifiers (for the previous example these are something like Cmd+Shift/Cmd+W/Shift+W). --- src/OSWindow-SDL2/OSSDL2BackendWindow.class.st | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/OSWindow-SDL2/OSSDL2BackendWindow.class.st b/src/OSWindow-SDL2/OSSDL2BackendWindow.class.st index 4e93edacb2c..a6c04ed095c 100644 --- a/src/OSWindow-SDL2/OSSDL2BackendWindow.class.st +++ b/src/OSWindow-SDL2/OSSDL2BackendWindow.class.st @@ -683,6 +683,7 @@ OSSDL2BackendWindow >> visitKeyDownEvent: event [ self convertButtonState: SDL2 mouseState modState: keysym mod modifiers: osEvent modifiers. self convertNumpadKeysOf: osEvent. + osEvent repeat = 1 ifTrue: [ ^ self ]. ^ osEvent deliver ] @@ -699,6 +700,7 @@ OSSDL2BackendWindow >> visitKeyUpEvent: event [ self convertButtonState: SDL2 mouseState modState: keysym mod modifiers: osEvent modifiers. self convertNumpadKeysOf: osEvent. + osEvent repeat = 1 ifTrue: [ ^ self ]. ^ osEvent deliver ] From b39e71b4f920efe706d810fbe478432a11ce3299 Mon Sep 17 00:00:00 2001 From: Ignacio Losiggio Date: Fri, 18 Oct 2024 20:24:32 +0200 Subject: [PATCH 04/20] Instead of removing all repeat events just try to match with and without repeat events. This feels like a hack... --- src/Keymapping-Core/KMDispatchChain.class.st | 10 +++++++++- src/Morphic-Core/KeyboardEvent.class.st | 15 ++++++++++++++- .../OSWindowMorphicEventHandler.class.st | 6 ++++-- src/OSWindow-SDL2/OSSDL2BackendWindow.class.st | 2 -- 4 files changed, 27 insertions(+), 6 deletions(-) diff --git a/src/Keymapping-Core/KMDispatchChain.class.st b/src/Keymapping-Core/KMDispatchChain.class.st index 0fd373a7bf0..982e9d4393d 100644 --- a/src/Keymapping-Core/KMDispatchChain.class.st +++ b/src/Keymapping-Core/KMDispatchChain.class.st @@ -26,8 +26,16 @@ KMDispatchChain class >> from: anInitialTarget andDispatcher: aDispatcher [ { #category : 'dispatching' } KMDispatchChain >> dispatch: aKeyboardEvent [ self do: [ :targetToDispatch | - targetToDispatch dispatch: KMBuffer uniqueInstance buffer copy. + | sequence | + sequence := KMBuffer uniqueInstance buffer copy. + targetToDispatch dispatch: sequence. aKeyboardEvent wasHandled ifTrue: [ ^self ]. + "Let's try to match this sequence of events again. + This time ignoring any repeated events." + sequence removeAllSuchThat: [ :ev | ev isRepeat ]. + sequence isNotEmpty ifTrue: [ + targetToDispatch dispatch: sequence. + aKeyboardEvent wasHandled ifTrue: [ ^self ] ] ]. "This should be a noMatch event" aKeyboardEvent wasHandled ifFalse: [ KMBuffer uniqueInstance clearBuffer ] diff --git a/src/Morphic-Core/KeyboardEvent.class.st b/src/Morphic-Core/KeyboardEvent.class.st index d846cdfb550..457dbd433ef 100644 --- a/src/Morphic-Core/KeyboardEvent.class.st +++ b/src/Morphic-Core/KeyboardEvent.class.st @@ -9,7 +9,8 @@ Class { 'charCode', 'scanCode', 'key', - 'supressNextKeyPress' + 'supressNextKeyPress', + 'isRepeat' ], #category : 'Morphic-Core-Events', #package : 'Morphic-Core', @@ -81,6 +82,18 @@ KeyboardEvent >> isMouseMove [ ^false ] +{ #category : 'accessing' } +KeyboardEvent >> isRepeat [ + + ^ isRepeat +] + +{ #category : 'accessing' } +KeyboardEvent >> isRepeat: anObject [ + + isRepeat := anObject +] + { #category : 'keyboard' } KeyboardEvent >> key [ ^ key ifNil: [key := Smalltalk os keyForValue: keyValue] diff --git a/src/OSWindow-Core/OSWindowMorphicEventHandler.class.st b/src/OSWindow-Core/OSWindowMorphicEventHandler.class.st index a773696ada3..fab4cf428e9 100644 --- a/src/OSWindow-Core/OSWindowMorphicEventHandler.class.st +++ b/src/OSWindow-Core/OSWindowMorphicEventHandler.class.st @@ -220,7 +220,8 @@ OSWindowMorphicEventHandler >> visitKeyDownEvent: anEvent [ stamp: Time millisecondClockValue. keyEvent scanCode: anEvent scanCode; - key: (OSKeySymbols mapKeySymbolValueToKeyboardKey: anEvent symbol). + key: (OSKeySymbols mapKeySymbolValueToKeyboardKey: anEvent symbol); + isRepeat: anEvent repeat = 1. self dispatchMorphicEvent: keyEvent ] @@ -237,7 +238,8 @@ OSWindowMorphicEventHandler >> visitKeyUpEvent: anEvent [ stamp: Time millisecondClockValue. keyEvent scanCode: anEvent scanCode; - key: (OSKeySymbols mapKeySymbolValueToKeyboardKey: anEvent symbol). + key: (OSKeySymbols mapKeySymbolValueToKeyboardKey: anEvent symbol); + isRepeat: anEvent repeat = 1. ^ keyEvent ] diff --git a/src/OSWindow-SDL2/OSSDL2BackendWindow.class.st b/src/OSWindow-SDL2/OSSDL2BackendWindow.class.st index a6c04ed095c..4e93edacb2c 100644 --- a/src/OSWindow-SDL2/OSSDL2BackendWindow.class.st +++ b/src/OSWindow-SDL2/OSSDL2BackendWindow.class.st @@ -683,7 +683,6 @@ OSSDL2BackendWindow >> visitKeyDownEvent: event [ self convertButtonState: SDL2 mouseState modState: keysym mod modifiers: osEvent modifiers. self convertNumpadKeysOf: osEvent. - osEvent repeat = 1 ifTrue: [ ^ self ]. ^ osEvent deliver ] @@ -700,7 +699,6 @@ OSSDL2BackendWindow >> visitKeyUpEvent: event [ self convertButtonState: SDL2 mouseState modState: keysym mod modifiers: osEvent modifiers. self convertNumpadKeysOf: osEvent. - osEvent repeat = 1 ifTrue: [ ^ self ]. ^ osEvent deliver ] From 73d4ec066d4db585d246331a66ab4b8f2391116f Mon Sep 17 00:00:00 2001 From: Ignacio Esteban Losiggio Date: Sat, 19 Oct 2024 12:05:57 +0200 Subject: [PATCH 05/20] Rename the argument to KeyboardEvent>>#isRepeat: --- src/Morphic-Core/KeyboardEvent.class.st | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Morphic-Core/KeyboardEvent.class.st b/src/Morphic-Core/KeyboardEvent.class.st index 457dbd433ef..af16d80abed 100644 --- a/src/Morphic-Core/KeyboardEvent.class.st +++ b/src/Morphic-Core/KeyboardEvent.class.st @@ -89,9 +89,9 @@ KeyboardEvent >> isRepeat [ ] { #category : 'accessing' } -KeyboardEvent >> isRepeat: anObject [ +KeyboardEvent >> isRepeat: aBoolean [ - isRepeat := anObject + isRepeat := aBoolean ] { #category : 'keyboard' } From 10a23363be1307ab4d2bd9763ed8eaaf8e450efe Mon Sep 17 00:00:00 2001 From: Ignacio Losiggio Date: Mon, 21 Oct 2024 13:27:16 +0200 Subject: [PATCH 06/20] isRepeat is `false` by default for KeyboardEvent-s --- src/Morphic-Core/KeyboardEvent.class.st | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Morphic-Core/KeyboardEvent.class.st b/src/Morphic-Core/KeyboardEvent.class.st index 457dbd433ef..a4cd7cd37b2 100644 --- a/src/Morphic-Core/KeyboardEvent.class.st +++ b/src/Morphic-Core/KeyboardEvent.class.st @@ -54,7 +54,8 @@ KeyboardEvent >> hash [ KeyboardEvent >> initialize [ super initialize. - supressNextKeyPress := false + supressNextKeyPress := false. + isRepeat := false ] { #category : 'testing' } From b27b2a4ca8f26786e9e75b060a317e6ffaacb415 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 21 Oct 2024 13:31:10 +0200 Subject: [PATCH 07/20] Improvements in undo/redo - fix undo/redo cases that broke text, specially when in collaboration with the syntax highlighter - make undo/redo work on a word-by-word basis - make undo/redo restore selection and cursur when doing a replacement by paste/completion Co-authored-by: Fede Lochbaum --- .../CompletionEngine.class.st | 6 +- .../CompletionEngineTest.class.st | 50 +++++++ src/Rubric-Tests/RubAbstractTest.class.st | 20 +++ .../RubTextEditorLocalHistoryTest.class.st | 87 +++++++++++++ src/Rubric-Tests/RubTextEditorTest.class.st | 6 +- src/Rubric/RubAbstractTextArea.class.st | 16 ++- src/Rubric/RubTextEditor.class.st | 122 +++++++++++++----- src/System-History/UndoRedoRecord.class.st | 9 ++ 8 files changed, 272 insertions(+), 44 deletions(-) create mode 100644 src/Rubric-Tests/RubAbstractTest.class.st create mode 100644 src/Rubric-Tests/RubTextEditorLocalHistoryTest.class.st diff --git a/src/NECompletion-Morphic/CompletionEngine.class.st b/src/NECompletion-Morphic/CompletionEngine.class.st index b6cab22e1b4..0b0d37f0022 100644 --- a/src/NECompletion-Morphic/CompletionEngine.class.st +++ b/src/NECompletion-Morphic/CompletionEngine.class.st @@ -338,7 +338,7 @@ CompletionEngine >> replaceTokenInEditorWith: aString [ The completion context uses this API to insert text into the text editor" - | newString wordEnd old doubleSpace wordStart | + | newString wordEnd doubleSpace wordStart oldSelectionInterval | newString := aString. wordStart := self completionTokenStart. @@ -355,12 +355,12 @@ CompletionEngine >> replaceTokenInEditorWith: aString [ "If the returned index is the size of the text that means that the caret is at the end of the text and there is no more word after, so add 1 to the index to be out of range to select the entierely word because of the selectInvisiblyFrom:to: remove 1 just after to be at the end of then final word" wordEnd > self editor text size ifTrue:[ wordEnd := wordEnd + 1 ]. + oldSelectionInterval := self editor selectionInterval. self editor selectInvisiblyFrom: wordStart to: wordEnd - 1. - old := self editor selection. - self editor replaceSelectionWith: newString. + self editor replaceSelectionWith: newString fromSelection: oldSelectionInterval. doubleSpace := newString indexOfSubCollection: ' ' startingAt: 1 ifAbsent: [ newString size ]. self editor selectAt: wordStart + doubleSpace. diff --git a/src/NECompletion-Tests/CompletionEngineTest.class.st b/src/NECompletion-Tests/CompletionEngineTest.class.st index d6d503e78a6..6b403fa269a 100644 --- a/src/NECompletion-Tests/CompletionEngineTest.class.st +++ b/src/NECompletion-Tests/CompletionEngineTest.class.st @@ -31,6 +31,12 @@ CompletionEngineTest >> editorTextWithCaret [ ^ (source copyFrom: 1 to: editor caret-1), '|', (source copyFrom: editor caret to: source size) ] +{ #category : 'helpers' } +CompletionEngineTest >> expectText: aString [ + + self assert: editor text asString equals: aString +] + { #category : 'accessing' } CompletionEngineTest >> interactionModel [ @@ -995,3 +1001,47 @@ CompletionEngineTest >> testSmartQuoteSurroundsSelection [ controller smartCharacterWithEvent: (self keyboardPressFor: $'). self assert: editor text equals: ' ''text'' ' ] + +{ #category : 'tests - undo' } +CompletionEngineTest >> testUndoAutocompleteLeavesCursorInOriginalPosition [ + + "If the caret is at the end of a word, replace the entire word" + editor addString: 'self'. + editor closeTypeIn. + editor unselect. + + "Put the cursor after the `sel` token, and then we will simulate code completion" + self selectAt: 'self' size - 1. + + editor textArea openInWorld. + controller openMenu. + + controller context replaceTokenInEditorWith: 'selection'. + + editor undo. + self expectText: 'self'. + self assert: editor selectionInterval equals: (3 to: 2) +] + +{ #category : 'tests - undo' } +CompletionEngineTest >> testUndoCompletionEntryKeepsFollowingLine [ + + "If the caret is at the end of a word, replace the entire word" + + | text | + text := 'self mEthOdThatDoes +nextLine'. + + self + setEditorText: text; + selectAt: text lines first size. + + editor textArea openInWorld. + controller openMenu. + + controller context replaceTokenInEditorWith: 'mEthOdThatDoesNotExist'. + + editor undo. + + self assert: editor text asString equals: text +] diff --git a/src/Rubric-Tests/RubAbstractTest.class.st b/src/Rubric-Tests/RubAbstractTest.class.st new file mode 100644 index 00000000000..90f68e20b25 --- /dev/null +++ b/src/Rubric-Tests/RubAbstractTest.class.st @@ -0,0 +1,20 @@ +Class { + #name : 'RubAbstractTest', + #superclass : 'TestCase', + #instVars : [ + 'string', + 'editor' + ], + #category : 'Rubric-Tests-Editing-Core', + #package : 'Rubric-Tests', + #tag : 'Editing-Core' +} + +{ #category : 'running' } +RubAbstractTest >> setUp [ + + super setUp. + editor := RubTextEditor forTextArea: RubEditingArea new. + "Add text with a paragraph" + string := 'Lorem ipsum ' +] diff --git a/src/Rubric-Tests/RubTextEditorLocalHistoryTest.class.st b/src/Rubric-Tests/RubTextEditorLocalHistoryTest.class.st new file mode 100644 index 00000000000..d85330f2f49 --- /dev/null +++ b/src/Rubric-Tests/RubTextEditorLocalHistoryTest.class.st @@ -0,0 +1,87 @@ +Class { + #name : 'RubTextEditorLocalHistoryTest', + #superclass : 'RubAbstractTest', + #category : 'Rubric-Tests-Editing-Core', + #package : 'Rubric-Tests', + #tag : 'Editing-Core' +} + +{ #category : 'tests - undo' } +RubTextEditorLocalHistoryTest >> expectText: aString [ + + self assert: editor text asString equals: aString +] + +{ #category : 'tests - undo' } +RubTextEditorLocalHistoryTest >> selectAt: anIndex [ + editor selectFrom: anIndex to: anIndex - 1 +] + +{ #category : 'tests - undo' } +RubTextEditorLocalHistoryTest >> testRedoCompletionEntryKeepsFollowingLine [ + + "If the caret is at the end of a word, replace the entire word" + editor addString: 'self'. + editor closeTypeIn. + editor unselect. + "Simulate an enter" + editor crWithIndent: KeyboardEvent new. + editor addString: ' b'. + editor closeTypeIn. + editor unselect. + + "Put the cursor after the `self` token, and then we will simulate code completion" + self selectAt: 'self' size + 1. + editor addString: ' te'. + editor closeTypeIn. + + self expectText: 'self te + b'. + + editor undo. + self expectText: 'self + b'. + + editor redo. + self expectText: 'self te + b'. +] + +{ #category : 'tests - undo' } +RubTextEditorLocalHistoryTest >> testRedoLeavesCursorInOriginalPosition [ + + "If the caret is at the end of a word, replace the entire word" + editor addString: 'self'. + editor unselect. + editor undo. + editor redo. + + self expectText: 'self'. + self assert: editor selectionInterval equals: (5 to: 4) +] + +{ #category : 'tests - undo' } +RubTextEditorLocalHistoryTest >> testUndoAfterTypeThenTabUndoesOnlyTheTab [ + + editor addString: 'self'. + editor unselect. + editor tab: KeyboardEvent new. + + editor undo. + + self expectText: 'self' +] + +{ #category : 'tests - undo' } +RubTextEditorLocalHistoryTest >> testUndoWordUndoesOneWordAtATime [ + + editor addString: 'self'. + editor unselect. + editor space: KeyboardEvent new. + + editor addString: 'toto'. + + editor undo. + + self expectText: 'self' +] diff --git a/src/Rubric-Tests/RubTextEditorTest.class.st b/src/Rubric-Tests/RubTextEditorTest.class.st index 8463819cfbb..b840b727469 100644 --- a/src/Rubric-Tests/RubTextEditorTest.class.st +++ b/src/Rubric-Tests/RubTextEditorTest.class.st @@ -3,11 +3,7 @@ A RubTextEditorTest is a test class for testing the behavior of RubTextEditor " Class { #name : 'RubTextEditorTest', - #superclass : 'TestCase', - #instVars : [ - 'editor', - 'string' - ], + #superclass : 'RubAbstractTest', #category : 'Rubric-Tests-Editing-Core', #package : 'Rubric-Tests', #tag : 'Editing-Core' diff --git a/src/Rubric/RubAbstractTextArea.class.st b/src/Rubric/RubAbstractTextArea.class.st index 618f55c088e..4e52189ee18 100644 --- a/src/Rubric/RubAbstractTextArea.class.st +++ b/src/Rubric/RubAbstractTextArea.class.st @@ -1744,7 +1744,13 @@ RubAbstractTextArea >> recomputeSelection [ { #category : 'multi level undo' } RubAbstractTextArea >> redoTypeIn: aText interval: anInterval [ - self handleEdit: [self editor redoTypeIn: aText interval: anInterval] + + ^ self redoTypeIn: aText interval: anInterval selection: anInterval +] + +{ #category : 'multi level undo' } +RubAbstractTextArea >> redoTypeIn: aText interval: anInterval selection: selection [ + self handleEdit: [self editor redoTypeIn: aText interval: anInterval selection: selection] ] { #category : 'caching' } @@ -2105,7 +2111,13 @@ RubAbstractTextArea >> undoRedoExchange: aninterval with: anotherInterval [ { #category : 'multi level undo' } RubAbstractTextArea >> undoTypeIn: aText interval: anInterval [ - self handleEdit: [self editor undoTypeIn: aText interval: anInterval] + + ^ self undoTypeIn: aText interval: anInterval selection: anInterval +] + +{ #category : 'multi level undo' } +RubAbstractTextArea >> undoTypeIn: aText interval: anInterval selection: aSelection [ + self handleEdit: [self editor undoTypeIn: aText interval: anInterval selection: aSelection] ] { #category : 'private' } diff --git a/src/Rubric/RubTextEditor.class.st b/src/Rubric/RubTextEditor.class.st index 4ed6e7b7652..f4328ea5abe 100644 --- a/src/Rubric/RubTextEditor.class.st +++ b/src/Rubric/RubTextEditor.class.st @@ -152,18 +152,29 @@ RubTextEditor >> addString: aString [ { #category : 'undo - redo private' } RubTextEditor >> addTypeInUndoRecord [ - | begin stop undoText redoText | - begin := self startOfTyping min: self stopIndex. - stop := self stopIndex max: self startOfTyping. + | begin stop undoText redoText selectionBeforeChange | + begin := self startOfTyping. + stop := self stopIndex. + + selectionBeforeChange := self selectionInterval. self editingState previousInterval: (begin to: stop - 1). undoText := self nullText. redoText := stop > begin ifTrue: [self text copyFrom: begin to: stop - 1] ifFalse: [self nullText]. - ((undoText isEmpty and: [redoText isEmpty]) and: [self editingState previousInterval size < 1]) - ifFalse: [self - redoArray: { textArea. #redoTypeIn:interval:. {redoText. begin to: begin + self selection size - 1} } - undoArray: {textArea. #undoTypeIn:interval:. {undoText. begin to: stop - 1} }] + + ((undoText isEmpty and: [redoText isEmpty]) + and: [self editingState previousInterval size < 1]) ifTrue: [ ^ self ] . + + self + redoArray: { textArea. #redoTypeIn:interval:selection:. { + redoText. + begin to: begin - 1. + selectionBeforeChange } } + undoArray: { textArea. #undoTypeIn:interval:selection:. { + undoText. + begin to: stop - 1. + (begin to: begin -1) } } ] { #category : 'new selection' } @@ -781,6 +792,7 @@ RubTextEditor >> defaultCommandKeymapping [ (KeyboardKey enter -> #crWithIndent:). (KeyboardKey escape -> #escape:). (KeyboardKey left -> #cursorLeft:). + (KeyboardKey space -> #space:). (KeyboardKey right -> #cursorRight:). (KeyboardKey up -> #cursorUp:). (KeyboardKey down -> #cursorDown:). @@ -851,21 +863,6 @@ RubTextEditor >> doubleClick: evt [ self storeSelectionInText ] -{ #category : 'editing keys' } -RubTextEditor >> duplicate: aKeyboardEvent [ - "Paste the current selection over the prior selection, if it is non-overlapping and - legal. Undoer & Redoer: undoAndReselect." - - self closeTypeIn. - (self hasSelection and: [self isDisjointFrom: self editingState previousInterval]) - ifTrue: "Something to duplicate" - [self replace: self editingState previousInterval with: self selection and: - [self selectAt: self pointIndex]] - ifFalse: - [textArea flash]. - ^true -] - { #category : 'accessing - selection' } RubTextEditor >> editPrimarySelectionSeparately [ textArea editPrimarySelectionSeparately @@ -1903,10 +1900,13 @@ RubTextEditor >> redoArray: doArray undoArray: undoArray [ ] { #category : 'undoers - redoers' } -RubTextEditor >> redoTypeIn: aText interval: anInterval [ +RubTextEditor >> redoTypeIn: aText interval: anInterval selection: selection [ + self selectInterval: anInterval. - self replace: self selectionInterval with: aText and: - [self selectInterval: (anInterval first to: anInterval first + aText size - 1)] + self + replace: self selectionInterval + with: aText + and: [ self selectInterval: selection ] ] { #category : 'accessing' } @@ -1914,17 +1914,45 @@ RubTextEditor >> replace: xoldInterval with: newText and: selectingBlock [ "Replace the text in oldInterval with newText and execute selectingBlock to establish the new selection. Create an UndoRecord to allow perfect undoing." - | prevSel currInterval | + + self replace: xoldInterval with: newText and: selectingBlock selection: self selectionInterval +] + +{ #category : 'accessing' } +RubTextEditor >> replace: xoldInterval with: newText and: selectingBlock selection: fromSelection [ + "Replace the text in oldInterval with newText and + execute selectingBlock to establish the new selection. + Create an UndoRecord to allow perfect undoing." + + | prevSel currInterval cursorAfterInsertion | self selectInterval: xoldInterval. prevSel := self selection. currInterval := self selectionInterval. self editingState previousInterval: currInterval. + self zapSelectionWith: newText. + cursorAfterInsertion := currInterval first + newText size - 1. + selectingBlock value. - ((prevSel isEmpty and: [newText isEmpty]) and: [currInterval size < 1]) - ifFalse: [self - redoArray: {textArea. #redoTypeIn:interval:. {newText. currInterval}} - undoArray: {textArea. #undoTypeIn:interval:. {prevSel. currInterval first to: currInterval first + newText size - 1}}] + + ((prevSel isEmpty and: [ newText isEmpty ]) and: [ + currInterval size < 1 ]) ifTrue: [ ^ self ]. + + self + redoArray: { + textArea. + #redoTypeIn:interval:selection:. + { + newText. + currInterval. + (cursorAfterInsertion + 1 to: cursorAfterInsertion) } } + undoArray: { + textArea. + #undoTypeIn:interval:selection:. + { + prevSel. + (currInterval first to: currInterval first + newText size - 1). + fromSelection } } ] { #category : 'find-select' } @@ -1957,7 +1985,15 @@ RubTextEditor >> replaceAll: aRegex with: aText startingAt: startIdx [ { #category : 'accessing' } RubTextEditor >> replaceSelectionWith: aText [ - self replace: self selectionInterval with: aText and: [] + + self + replaceSelectionWith: aText + fromSelection: self selectionInterval +] + +{ #category : 'accessing' } +RubTextEditor >> replaceSelectionWith: aText fromSelection: fromSelection [ + self replace: self selectionInterval with: aText and: [] selection: fromSelection ] { #category : 'accessing' } @@ -2393,6 +2429,20 @@ RubTextEditor >> shouldEscapeCharacter: aCharacter [ ^ #($" $') includes: aCharacter ] +{ #category : 'typing/selecting keys' } +RubTextEditor >> space: aKeyboardEvent [ + "Append a space to the stream of characters and commit the undo/redo transaction. + This allows to manage undo/redo at a per-word granularity" + + "We are consuming the space keydown event, do not send a keypress for it" + aKeyboardEvent supressNextKeyPress: true. + + self closeTypeIn. + self addString: String space. + self unselect. + ^false +] + { #category : 'keymapping' } RubTextEditor >> specialShiftCmdKeys [ @@ -2503,6 +2553,7 @@ RubTextEditor >> swapChars: aKeyboardEvent [ RubTextEditor >> tab: aKeyboardEvent [ "Append a line feed character to the stream of characters." + self closeTypeIn. self addString: String tab. self unselect. ^false @@ -2617,10 +2668,13 @@ RubTextEditor >> undoRedoTransaction: aBlock [ ] { #category : 'undoers - redoers' } -RubTextEditor >> undoTypeIn: aText interval: anInterval [ +RubTextEditor >> undoTypeIn: aText interval: anInterval selection: aSelection [ + self selectInterval: anInterval. - self replace: anInterval with: aText and: - [self selectInterval: (anInterval first to: anInterval first - 1)] + self + replace: anInterval + with: aText + and: [ self selectInterval: aSelection ] ] { #category : 'private' } diff --git a/src/System-History/UndoRedoRecord.class.st b/src/System-History/UndoRedoRecord.class.st index 83b11d289aa..2a7e8a6403e 100644 --- a/src/System-History/UndoRedoRecord.class.st +++ b/src/System-History/UndoRedoRecord.class.st @@ -78,6 +78,15 @@ UndoRedoRecord >> doMessage: aMessageSend [ ^ self redoMessage: aMessageSend ] +{ #category : 'printing' } +UndoRedoRecord >> printOn: aStream [ + + super printOn: aStream. + aStream nextPutAll: '('. + aStream print: redoMessage arguments. + aStream nextPutAll: ')' +] + { #category : 'redo-undo' } UndoRedoRecord >> redo [ ^self redoMessage value From 32472c61270617eaabba058b31cf1dc20cbfebcd Mon Sep 17 00:00:00 2001 From: Ignacio Losiggio Date: Mon, 21 Oct 2024 14:27:07 +0200 Subject: [PATCH 08/20] Add a test for the new behavior of the dispatcher --- .../KMDispatcherTest.class.st | 40 +++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/src/Keymapping-Tests/KMDispatcherTest.class.st b/src/Keymapping-Tests/KMDispatcherTest.class.st index d10846a94ca..a07635b6c82 100644 --- a/src/Keymapping-Tests/KMDispatcherTest.class.st +++ b/src/Keymapping-Tests/KMDispatcherTest.class.st @@ -126,3 +126,43 @@ KMDispatcherTest >> testNoStaggeredTrigger [ self deny: flag1. self assert: flag2 ] + +{ #category : 'tests' } +KMDispatcherTest >> testRepeatEvents [ + | morph flag category pressA repeatPressA pressB repeatPressB pressC | + category := KMCategory named: #TestBlah. + KMRepository default addCategory: category. + + morph := BorderedMorph new. + morph kmDispatcher reset. + flag := false. + + category addKeymapEntry: (KMKeymap named: #Foo shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: [flag := true]). + morph attachKeymapCategory: #TestBlah. + + pressA := self eventKey: $a. + morph kmDispatcher dispatchKeystroke: pressA. + self assert: morph kmDispatcher buffer asArray equals: {pressA}. + + repeatPressA := (self eventKey: $a) isRepeat: true; yourself. + morph kmDispatcher dispatchKeystroke: repeatPressA. + self assert: morph kmDispatcher buffer asArray equals: {pressA. repeatPressA}. + self assert: (morph kmDispatcher buffer asArray collect: [ :v | v isRepeat ]) equals: {false. true}. + + pressB := self eventKey: $b. + morph kmDispatcher dispatchKeystroke: pressB. + self assert: morph kmDispatcher buffer asArray equals: {pressA. repeatPressA. pressB}. + self assert: (morph kmDispatcher buffer asArray collect: [ :v | v isRepeat ]) equals: {false. true. false}. + + repeatPressB := (self eventKey: $b) isRepeat: true; yourself. + morph kmDispatcher dispatchKeystroke: repeatPressB. + self assert: morph kmDispatcher buffer asArray equals: {pressA. repeatPressA. pressB. repeatPressB}. + self assert: (morph kmDispatcher buffer asArray collect: [ :v | v isRepeat ]) equals: {false. true. false. true}. + + pressC := self eventKey: $c. + morph kmDispatcher + dispatchKeystroke: pressC. + self assert: morph kmDispatcher buffer isEmpty. + + self assert: flag +] From 4644c40ec9adc14176e5fe48adbf40509eddc754 Mon Sep 17 00:00:00 2001 From: Caro Date: Mon, 21 Oct 2024 17:01:38 -0300 Subject: [PATCH 09/20] Temporarily creating tests for stepping through using the EnhancedDebugSession. These tests should be parametrized in the future. They are commited like this to ease the performance comparison between DebugSession and EnhancedDebugSession --- .../EnhancedStepThroughTest.class.st | 39 +++++++++++++++++++ src/Debugger-Model/Process.extension.st | 6 +++ 2 files changed, 45 insertions(+) create mode 100644 src/Debugger-Model-Tests/EnhancedStepThroughTest.class.st diff --git a/src/Debugger-Model-Tests/EnhancedStepThroughTest.class.st b/src/Debugger-Model-Tests/EnhancedStepThroughTest.class.st new file mode 100644 index 00000000000..f16595cf05b --- /dev/null +++ b/src/Debugger-Model-Tests/EnhancedStepThroughTest.class.st @@ -0,0 +1,39 @@ +Class { + #name : 'EnhancedStepThroughTest', + #superclass : 'StepThroughTest', + #category : 'Debugger-Model-Tests-Core', + #package : 'Debugger-Model-Tests', + #tag : 'Core' +} + +{ #category : 'utilities' } +EnhancedStepThroughTest >> settingUpSessionAndProcessAndContextForBlock: aBlock [ + super settingUpSessionAndProcessAndContextForBlock: aBlock. + session := process newEnhancedDebugSessionNamed: 'test session' startedAt: context +] + +{ #category : 'helper' } +EnhancedStepThroughTest >> stepA1 [ + self evalBlockThenReturnOne: [ self stepA2 ] +] + +{ #category : 'helper' } +EnhancedStepThroughTest >> stepA2 [ + ^ 2+2 +] + +{ #category : 'helper' } +EnhancedStepThroughTest >> stepB1 [ + self stepB2. + self stepB3 +] + +{ #category : 'helper' } +EnhancedStepThroughTest >> stepB2 [ + ^ 42 +] + +{ #category : 'helper' } +EnhancedStepThroughTest >> stepB3 [ + ^ 43 +] diff --git a/src/Debugger-Model/Process.extension.st b/src/Debugger-Model/Process.extension.st index fb62bb8ffea..72304439630 100644 --- a/src/Debugger-Model/Process.extension.st +++ b/src/Debugger-Model/Process.extension.st @@ -28,6 +28,12 @@ Process >> newDebugSessionNamed: aString startedAt: aContext [ ^DebugSession named: aString on: self startedAt: aContext ] +{ #category : '*Debugger-Model' } +Process >> newEnhancedDebugSessionNamed: aString startedAt: aContext [ + + ^EnhancedDebugSession named: aString on: self startedAt: aContext +] + { #category : '*Debugger-Model' } Process >> popTo: aContext [ "Pop self down to aContext by remote returning from aContext's callee. Unwind blocks will be executed on the way. From 4de0debf57ee83dccd8bb572e134cc2f4fa1e65e Mon Sep 17 00:00:00 2001 From: Hernan Morales Durand <4825959+hernanmd@users.noreply.github.com> Date: Wed, 23 Oct 2024 14:49:20 +0200 Subject: [PATCH 10/20] Major update of the Keymap Descriptions to a first version of a Shortcut Editor --- .../CmdShortcutActivation.class.st | 7 + src/Keymapping-Core/KMCategory.class.st | 11 + .../CmdShortcutActivation.extension.st | 32 +++ .../KMCategory.extension.st | 7 + .../KMCategoryItemPresenter.class.st | 96 ++++++++ .../KMDescriptionPresenter.class.st | 217 +++++++++++++++--- .../KMKeymap.extension.st | 14 ++ .../SpDropListPresenter.extension.st | 7 + 8 files changed, 363 insertions(+), 28 deletions(-) create mode 100644 src/Keymapping-Tools-Spec/CmdShortcutActivation.extension.st create mode 100644 src/Keymapping-Tools-Spec/KMCategory.extension.st create mode 100644 src/Keymapping-Tools-Spec/KMCategoryItemPresenter.class.st create mode 100644 src/Keymapping-Tools-Spec/KMKeymap.extension.st create mode 100644 src/Keymapping-Tools-Spec/SpDropListPresenter.extension.st diff --git a/src/Commander-Activators-Shortcut/CmdShortcutActivation.class.st b/src/Commander-Activators-Shortcut/CmdShortcutActivation.class.st index 49d8bd7353a..beb23dc6524 100644 --- a/src/Commander-Activators-Shortcut/CmdShortcutActivation.class.st +++ b/src/Commander-Activators-Shortcut/CmdShortcutActivation.class.st @@ -82,6 +82,13 @@ CmdShortcutActivation class >> settingInputWidgetForNode: aShortcutSetting [ ^ theme newRow: {catcherMorph} ] +{ #category : 'accessing' } +CmdShortcutActivation >> action [ + "Answer a defining the receiver's action" + + ^ self annotatedClass class lookupSelector: self declarationSelector +] + { #category : 'settings' } CmdShortcutActivation >> buildSettingNodeOn: aBuilder [ | nodeBuilder | diff --git a/src/Keymapping-Core/KMCategory.class.st b/src/Keymapping-Core/KMCategory.class.st index cb0144b095a..b9db51d2e64 100644 --- a/src/Keymapping-Core/KMCategory.class.st +++ b/src/Keymapping-Core/KMCategory.class.st @@ -89,6 +89,12 @@ KMCategory >> hasKeymapNamed: aKeymapEntryName at: aPlatform [ ^ (self entriesAt: aPlatform) hasKeymapNamed: aKeymapEntryName ] +{ #category : 'accessing' } +KMCategory >> icon [ + + ^ self iconNamed: #keymapBrowser +] + { #category : 'initialization' } KMCategory >> initialize [ @@ -137,6 +143,11 @@ KMCategory >> matchesCompletely: aString [ entry matchesCompletely: aString ] ] +{ #category : 'accessing' } +KMCategory >> model [ + ^ self +] + { #category : 'accessing' } KMCategory >> name [ ^ name diff --git a/src/Keymapping-Tools-Spec/CmdShortcutActivation.extension.st b/src/Keymapping-Tools-Spec/CmdShortcutActivation.extension.st new file mode 100644 index 00000000000..4a97f18378f --- /dev/null +++ b/src/Keymapping-Tools-Spec/CmdShortcutActivation.extension.st @@ -0,0 +1,32 @@ +Extension { #name : 'CmdShortcutActivation' } + +{ #category : '*Keymapping-Tools-Spec' } +CmdShortcutActivation >> description [ + + ^ String empty +] + +{ #category : '*Keymapping-Tools-Spec' } +CmdShortcutActivation >> name [ + + ^ self declarationSelector asString +] + +{ #category : '*Keymapping-Tools-Spec' } +CmdShortcutActivation >> scope [ + "The receiver's scope is the package name where is installed" + + ^ self annotatedClass packageName +] + +{ #category : '*Keymapping-Tools-Spec' } +CmdShortcutActivation >> scopeName [ + + ^ self scope asString +] + +{ #category : '*Keymapping-Tools-Spec' } +CmdShortcutActivation >> shortcut [ + + ^ self keyCombination asString +] diff --git a/src/Keymapping-Tools-Spec/KMCategory.extension.st b/src/Keymapping-Tools-Spec/KMCategory.extension.st new file mode 100644 index 00000000000..02715f44c08 --- /dev/null +++ b/src/Keymapping-Tools-Spec/KMCategory.extension.st @@ -0,0 +1,7 @@ +Extension { #name : 'KMCategory' } + +{ #category : '*Keymapping-Tools-Spec' } +KMCategory >> scopeName [ + + ^ self name +] diff --git a/src/Keymapping-Tools-Spec/KMCategoryItemPresenter.class.st b/src/Keymapping-Tools-Spec/KMCategoryItemPresenter.class.st new file mode 100644 index 00000000000..a349b1be340 --- /dev/null +++ b/src/Keymapping-Tools-Spec/KMCategoryItemPresenter.class.st @@ -0,0 +1,96 @@ +Class { + #name : 'KMCategoryItemPresenter', + #superclass : 'SpPresenter', + #instVars : [ + 'categoryName', + 'shortcuts' + ], + #category : 'Keymapping-Tools-Spec', + #package : 'Keymapping-Tools-Spec' +} + +{ #category : 'copying' } +KMCategoryItemPresenter >> , aKMCategory [ + + self shortcuts addAll: aKMCategory allEntries keymaps asOrderedCollection + +] + +{ #category : 'comparing' } +KMCategoryItemPresenter >> = anObject [ + "Answer whether the receiver and anObject represent the same object." + + self == anObject ifTrue: [ ^ true ]. + self class = anObject class ifFalse: [ ^ false ]. + ^ categoryName = anObject categoryName and: [ + shortcuts = anObject shortcuts ] +] + +{ #category : 'adding' } +KMCategoryItemPresenter >> addAll: aCollection [ + "Add all shortcuts in aCollection to the receiver" + + self shortcuts addAll: aCollection +] + +{ #category : 'accessing' } +KMCategoryItemPresenter >> categoryName [ + + ^ categoryName +] + +{ #category : 'accessing' } +KMCategoryItemPresenter >> categoryName: anObject [ + + categoryName := anObject +] + +{ #category : 'comparing' } +KMCategoryItemPresenter >> hash [ + "Answer an integer value that is related to the identity of the receiver." + + ^ categoryName hash bitXor: shortcuts hash +] + +{ #category : 'accessing' } +KMCategoryItemPresenter >> icon [ + + ^ self iconNamed: self systemIconName +] + +{ #category : 'accessing' } +KMCategoryItemPresenter >> model [ + "Required by ?" + + ^ self +] + +{ #category : 'accessing' } +KMCategoryItemPresenter >> name [ + + ^ self categoryName +] + +{ #category : 'printing' } +KMCategoryItemPresenter >> printOn: aStream [ + "Generate a string representation of the receiver based on its instance variables." + + super printOn: aStream. + aStream + nextPutAll: ' ['; + print: categoryName; + nextPutAll: ']' +] + +{ #category : 'accessing' } +KMCategoryItemPresenter >> shortcuts [ + + ^ shortcuts + ifNil: [ shortcuts := OrderedCollection new ] +] + +{ #category : 'accessing' } +KMCategoryItemPresenter >> shortcuts: anObject [ + + shortcuts := anObject +] diff --git a/src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st b/src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st index 9b0b75f8dae..afe0850bbf5 100644 --- a/src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st +++ b/src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st @@ -7,21 +7,14 @@ Class { #instVars : [ 'shortcutList', 'actionBar', - 'categoryList' + 'categoryList', + 'shortcutDetails', + 'selectedAction' ], #category : 'Keymapping-Tools-Spec', #package : 'Keymapping-Tools-Spec' } -{ #category : 'layout' } -KMDescriptionPresenter class >> defaultLayout [ - ^ SpBoxLayout newTopToBottom - add: #categoryList withConstraints: [ :c | c height: 25 ]; - add: #shortcutList; - add: #actionBar withConstraints: [ :c | c height: 25 ]; - yourself -] - { #category : 'instance creation' } KMDescriptionPresenter class >> descriptionText [ @@ -45,7 +38,7 @@ KMDescriptionPresenter class >> icon [ KMDescriptionPresenter class >> menuCommandOn: aBuilder [ - (aBuilder item: 'Keymap Descriptions') + (aBuilder item: 'Shortcuts Editor') action: [ self open ]; order: 34; parent: #Tools; @@ -56,15 +49,40 @@ KMDescriptionPresenter class >> menuCommandOn: aBuilder [ { #category : 'instance creation' } KMDescriptionPresenter class >> open [ "Open the receiver's on all the system keymap categories" - + + KMRepository reset. ^ self new - categories: KMRepository default categories keys; + addShortcutActivationCmdInstances; + addKeymapCategoryInstances; + addAllAPIsEntry; open ] { #category : 'api' } -KMDescriptionPresenter >> categories: aCollectionOfSymbols [ - categoryList items: (aCollectionOfSymbols collect: [ :e | KMRepository default categoryForName: e ]) +KMDescriptionPresenter >> addAllAPIsEntry [ + "Set the receiver's category items to a list of categories in aCollectionOfSymbols. + We also build an 'All' category including all keymaps in aCollectionOfSymbols" + + | newCategoryItem kmNamedCategories | + + newCategoryItem := KMCategoryItemPresenter new categoryName: 'All'. + kmNamedCategories := KMRepository default categories. + kmNamedCategories inject: newCategoryItem into: [ : a : b | a , b ]. + newCategoryItem addAll: self shortcutActivationCmdInstances. + + categoryList prependCollection: {newCategoryItem} +] + +{ #category : 'api - keymaps' } +KMDescriptionPresenter >> addKeymapCategoryInstances [ + + self kmCategories: KMRepository default categories keys +] + +{ #category : 'api - commander' } +KMDescriptionPresenter >> addShortcutActivationCmdInstances [ + + categoryList appendCollection: self shortcutActivationCategoriesItems. ] { #category : 'initialization' } @@ -72,23 +90,44 @@ KMDescriptionPresenter >> connectPresenters [ categoryList transmitTo: shortcutList - transform: [ :category | (category model entriesAt: #all) keymaps sorted: [ :keymap | keymap shortcut asString ] ascending ] + transform: [ :item | self keymapsAtCategory: item ]. + + shortcutList + transmitTo: shortcutDetails + transform: [ :item | self shortcutDetailsFor: item ] + postTransmission: [ :presenter | selectedAction ifNotNil: [ :actionBlock | self updateCodePresenter: actionBlock ] ] ] -{ #category : 'initialization - deprecated' } -KMDescriptionPresenter >> initializeWidgets [ - categoryList := self newDropList. - shortcutList := self newTable. - actionBar := self newActionBar. +{ #category : 'layout' } +KMDescriptionPresenter >> defaultLayout [ - categoryList display: [ :category | category name ]. + ^ SpPanedLayout newTopToBottom + add: (SpBoxLayout newTopToBottom + spacing: 5; + add: (SpBoxLayout newLeftToRight + add: 'Filter scopes' expand: false; + add: categoryList; + yourself) + expand: false; + add: shortcutList); + add: (SpBoxLayout newTopToBottom + add: shortcutDetails; + add: actionBar withConstraints: [ :c | c height: 25 ]); + yourself +] - shortcutList - addColumn: (SpStringTableColumn title: 'Shortcut' evaluated: #shortcut); - addColumn: (SpStringTableColumn title: 'Name' evaluated: #name); - addColumn: (SpStringTableColumn title: 'Description' evaluated: #description); - beResizable. +{ #category : 'callbacks' } +KMDescriptionPresenter >> highlightColor [ + ^ self application configuration isDarkTheme + ifTrue: [ Color lightGray ] + ifFalse: [ Color veryVeryLightGray ] +] + +{ #category : 'initialization' } +KMDescriptionPresenter >> initializeActionBar [ + + actionBar := self newActionBar. actionBar addLast: (SpButtonPresenter new @@ -97,9 +136,131 @@ KMDescriptionPresenter >> initializeWidgets [ yourself) ] +{ #category : 'initialization' } +KMDescriptionPresenter >> initializeCategoryList [ + + categoryList := self newDropList. + categoryList display: [ :category | category name ]. +] + +{ #category : 'initialization' } +KMDescriptionPresenter >> initializePresenters [ + + self + initializeCategoryList; + initializeShortcutList; + initializeShortcutDetails; + initializeActionBar +] + +{ #category : 'initialization' } +KMDescriptionPresenter >> initializeShortcutDetails [ + + shortcutDetails := self newCode. + +] + +{ #category : 'initialization' } +KMDescriptionPresenter >> initializeShortcutList [ + + shortcutList := self newTable. + shortcutList + addColumn: (SpStringTableColumn new + title: 'API'; + evaluated: [ : each | each class name ]; + beSortable; + yourself); + addColumn: (SpStringTableColumn new + title: 'Scope'; + evaluated: [ :each | each scopeName ]; + beSortable; + yourself); + addColumn: (SpStringTableColumn title: 'Shortcut' evaluated: #shortcut); + addColumn: (SpStringTableColumn title: 'Name' evaluated: #name); + addColumn: (SpStringTableColumn title: 'Description' evaluated: #description); + beResizable. +] + { #category : 'initialization' } KMDescriptionPresenter >> initializeWindow: aWindowPresenter [ aWindowPresenter - title: 'Shortcuts description'; + title: 'Shortcuts Editor'; initialExtent: 600 @ 350 ] + +{ #category : 'initialization' } +KMDescriptionPresenter >> keymapsAtCategory: aKMCategoryOrKMCategoryItemPresenter [ + "Answer a of keymaps " + + ^ (aKMCategoryOrKMCategoryItemPresenter isKindOf: KMCategoryItemPresenter) + ifFalse: [ (aKMCategoryOrKMCategoryItemPresenter model entriesAt: #all) keymaps asOrderedCollection ] + ifTrue: [ aKMCategoryOrKMCategoryItemPresenter shortcuts ] +] + +{ #category : 'api - keymaps' } +KMDescriptionPresenter >> kmCategories: aCollectionOfSymbols [ + "Set the receiver's category items to a list of categories in aCollectionOfSymbols. + We also build an 'All' category including all keymaps in aCollectionOfSymbols" + + categoryList appendCollection: (self kmCategoriesAt: aCollectionOfSymbols) +] + +{ #category : 'api - keymaps' } +KMDescriptionPresenter >> kmCategoriesAt: aCollectionOfSymbols [ + + ^ aCollectionOfSymbols + collect: [ :e | KMRepository default categoryForName: e ] + as: OrderedCollection +] + +{ #category : 'api - commander' } +KMDescriptionPresenter >> shortcutActivationCategories [ + "Answer a of <...> representing each a category of shortcuts created using the Commander 1 framework" + + ^ (self shortcutActivationCmdInstances + groupedBy: [ : cmdShortcutActivation | cmdShortcutActivation annotatedClass packageName ]) values +] + +{ #category : 'api - commander' } +KMDescriptionPresenter >> shortcutActivationCategoriesItems [ + "Answer a of representing each a category of shortcuts created using the Commander 1 framework" + + ^ self shortcutActivationCategories + collect: [ : shortcuts | + KMCategoryItemPresenter new + categoryName: shortcuts anyOne annotatedClass packageName; + shortcuts: shortcuts; + yourself ] +] + +{ #category : 'api - commander' } +KMDescriptionPresenter >> shortcutActivationCmdInstances [ + + ^ CmdShortcutActivation registeredInstances copyWithoutAll: CmdShortcutActivation redefiningInstances +] + +{ #category : 'callbacks' } +KMDescriptionPresenter >> shortcutDetailsFor: anObject [ + + ^ anObject + ifNotNil: [ : aKMKeymapOrCmdShortcutActivation | + selectedAction := aKMKeymapOrCmdShortcutActivation action. + selectedAction method sourceCode ] + ifNil: [ String empty ] +] + +{ #category : 'callbacks' } +KMDescriptionPresenter >> updateCodePresenter: actionBlock [ + + shortcutDetails + beForMethod: selectedAction method; + text: selectedAction method sourceCode. + + selectedAction isClosure ifTrue: [ + shortcutDetails addTextSegmentDecoration: + (SpTextPresenterDecorator forHighlight + interval: (selectedAction sourceNode sourceInterval first to: + selectedAction sourceNode sourceInterval last + 1); + highlightColor: self highlightColor; + yourself) ] +] diff --git a/src/Keymapping-Tools-Spec/KMKeymap.extension.st b/src/Keymapping-Tools-Spec/KMKeymap.extension.st new file mode 100644 index 00000000000..70783a4dc19 --- /dev/null +++ b/src/Keymapping-Tools-Spec/KMKeymap.extension.st @@ -0,0 +1,14 @@ +Extension { #name : 'KMKeymap' } + +{ #category : '*Keymapping-Tools-Spec' } +KMKeymap >> scope [ + + ^ KMRepository default categories + detect: [ : cat | cat keymaps includes: self ] +] + +{ #category : '*Keymapping-Tools-Spec' } +KMKeymap >> scopeName [ + + ^ self scope scopeName +] diff --git a/src/Keymapping-Tools-Spec/SpDropListPresenter.extension.st b/src/Keymapping-Tools-Spec/SpDropListPresenter.extension.st new file mode 100644 index 00000000000..f751f36a5da --- /dev/null +++ b/src/Keymapping-Tools-Spec/SpDropListPresenter.extension.st @@ -0,0 +1,7 @@ +Extension { #name : 'SpDropListPresenter' } + +{ #category : '*Keymapping-Tools-Spec' } +SpDropListPresenter >> prependCollection: items [ + + model collection: items , model collection +] From 2beea03b82cc3772168a27cb53a68b734c83e2d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hern=C3=A1n=20Morales=20Durand?= <4825959+hernanmd@users.noreply.github.com> Date: Wed, 23 Oct 2024 17:41:17 +0000 Subject: [PATCH 11/20] Update KMDescriptionPresenter.class.st Remove unnecessary KM repository reset --- src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st b/src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st index afe0850bbf5..b68f6127cb0 100644 --- a/src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st +++ b/src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st @@ -50,7 +50,6 @@ KMDescriptionPresenter class >> menuCommandOn: aBuilder [ KMDescriptionPresenter class >> open [ "Open the receiver's on all the system keymap categories" - KMRepository reset. ^ self new addShortcutActivationCmdInstances; addKeymapCategoryInstances; From 3fc240cdf869f4282e2739b0d4fcc4e26a6e201f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hern=C3=A1n=20Morales=20Durand?= Date: Fri, 25 Oct 2024 10:20:04 +0200 Subject: [PATCH 12/20] Do not use method extensions for Commander activations --- .../CmdShortcutActivation.class.st | 35 +++++++++++++++++++ .../CmdShortcutActivation.extension.st | 32 ----------------- 2 files changed, 35 insertions(+), 32 deletions(-) delete mode 100644 src/Keymapping-Tools-Spec/CmdShortcutActivation.extension.st diff --git a/src/Commander-Activators-Shortcut/CmdShortcutActivation.class.st b/src/Commander-Activators-Shortcut/CmdShortcutActivation.class.st index beb23dc6524..80d5592d1f8 100644 --- a/src/Commander-Activators-Shortcut/CmdShortcutActivation.class.st +++ b/src/Commander-Activators-Shortcut/CmdShortcutActivation.class.st @@ -98,6 +98,15 @@ CmdShortcutActivation >> buildSettingNodeOn: aBuilder [ ^nodeBuilder ] +{ #category : 'printing' } +CmdShortcutActivation >> description [ + "Answer a describing the receiver. We use the `action` method comments to retrieve the description" + + ^ self action comment + ifNil: [ String empty ] + ifNotNil: [ : comm | comm ] +] + { #category : 'accessing' } CmdShortcutActivation >> keyCombination [ ^ keyCombination @@ -108,6 +117,12 @@ CmdShortcutActivation >> keyCombination: anObject [ keyCombination := anObject ] +{ #category : 'printing' } +CmdShortcutActivation >> name [ + + ^ self declarationSelector asString +] + { #category : 'printing' } CmdShortcutActivation >> printOn: aStream [ super printOn: aStream. @@ -116,6 +131,26 @@ CmdShortcutActivation >> printOn: aStream [ aStream nextPut: $) ] +{ #category : 'printing' } +CmdShortcutActivation >> scope [ + "The receiver's scope is the package name where is installed" + + ^ self annotatedClass packageName +] + +{ #category : 'printing' } +CmdShortcutActivation >> scopeName [ + + ^ self scope asString +] + +{ #category : 'printing' } +CmdShortcutActivation >> shortcut [ + "Answer a representation of the receiver's key combination" + + ^ self keyCombination asString +] + { #category : 'command execution' } CmdShortcutActivation >> tryExecuteCommandInContext: aToolContext byEvents: anEventBuffer [ diff --git a/src/Keymapping-Tools-Spec/CmdShortcutActivation.extension.st b/src/Keymapping-Tools-Spec/CmdShortcutActivation.extension.st deleted file mode 100644 index 4a97f18378f..00000000000 --- a/src/Keymapping-Tools-Spec/CmdShortcutActivation.extension.st +++ /dev/null @@ -1,32 +0,0 @@ -Extension { #name : 'CmdShortcutActivation' } - -{ #category : '*Keymapping-Tools-Spec' } -CmdShortcutActivation >> description [ - - ^ String empty -] - -{ #category : '*Keymapping-Tools-Spec' } -CmdShortcutActivation >> name [ - - ^ self declarationSelector asString -] - -{ #category : '*Keymapping-Tools-Spec' } -CmdShortcutActivation >> scope [ - "The receiver's scope is the package name where is installed" - - ^ self annotatedClass packageName -] - -{ #category : '*Keymapping-Tools-Spec' } -CmdShortcutActivation >> scopeName [ - - ^ self scope asString -] - -{ #category : '*Keymapping-Tools-Spec' } -CmdShortcutActivation >> shortcut [ - - ^ self keyCombination asString -] From 98c493a91d1f782f7662097b255c1fd3e60b10b6 Mon Sep 17 00:00:00 2001 From: Hernan Morales Durand <4825959+hernanmd@users.noreply.github.com> Date: Fri, 25 Oct 2024 13:15:33 +0200 Subject: [PATCH 13/20] Updated dependencies --- src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st | 2 +- .../SystemDependenciesTest.class.st | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st b/src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st index b68f6127cb0..6aa1c1e53f6 100644 --- a/src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st +++ b/src/Keymapping-Tools-Spec/KMDescriptionPresenter.class.st @@ -24,7 +24,7 @@ KMDescriptionPresenter class >> descriptionText [ { #category : 'examples' } KMDescriptionPresenter class >> example [ self new - categories: #(GlobalShortcuts MonticelloShortcuts); + kmCategories: #(WindowShortcuts); open ] diff --git a/src/System-Dependencies-Tests/SystemDependenciesTest.class.st b/src/System-Dependencies-Tests/SystemDependenciesTest.class.st index 246014e0937..33dd0298261 100644 --- a/src/System-Dependencies-Tests/SystemDependenciesTest.class.st +++ b/src/System-Dependencies-Tests/SystemDependenciesTest.class.st @@ -49,7 +49,7 @@ SystemDependenciesTest >> knownBasicToolsDependencies [ #'Refactoring-Critics' #'Commander-Core' #Reflectivity #'Reflectivity-Tools' #Shout 'HeuristicCompletion-Model' #VariablesLibrary #'Spec2-CommonWidgets' #'NewTools-Scopes' - #'Traits-Tests' 'NewTools-Scopes') + #'Traits-Tests' 'NewTools-Scopes' #'Commander-Activators-Shortcut') ] { #category : 'known dependencies' } @@ -112,6 +112,7 @@ SystemDependenciesTest >> knownSpec2Dependencies [ ^ #( 'WebBrowser-Core' "Spec's Link adapter" + 'NewTools-SpTextPresenterDecorators' ) ] @@ -128,7 +129,7 @@ SystemDependenciesTest >> knownUIDependencies [ "ideally this list should be empty" ^ #('AST-Core-Tests' 'Athens-Cairo' 'Athens-Core' - #'Athens-Morphic' #'Refactoring-Critics' #'Refactoring-Environment' 'Reflectivity-Tools' #Shout #'Tool-Diff' #'Tool-FileList' #'HeuristicCompletion-Model' 'NECompletion-Morphic' #VariablesLibrary #'Tools-CodeNavigation' #'Spec2-CommonWidgets' 'NewTools-Scopes') + #'Athens-Morphic' #'Refactoring-Critics' #'Refactoring-Environment' 'Reflectivity-Tools' #Shout #'Tool-Diff' #'Tool-FileList' #'HeuristicCompletion-Model' 'NECompletion-Morphic' #VariablesLibrary #'Tools-CodeNavigation' #'Spec2-CommonWidgets' 'NewTools-Scopes' #'Commander-Activators-Shortcut') ] { #category : 'accessing' } From 742a8bbb83f432a3d543648e4b2f4e322b954535 Mon Sep 17 00:00:00 2001 From: Koen De Hondt Date: Fri, 25 Oct 2024 14:16:13 +0200 Subject: [PATCH 14/20] Fix typo in "heigh" --- src/General-Rules/ReCyclomaticComplexityRule.class.st | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/General-Rules/ReCyclomaticComplexityRule.class.st b/src/General-Rules/ReCyclomaticComplexityRule.class.st index 82e34271c41..cf612406154 100644 --- a/src/General-Rules/ReCyclomaticComplexityRule.class.st +++ b/src/General-Rules/ReCyclomaticComplexityRule.class.st @@ -23,13 +23,13 @@ ReCyclomaticComplexityRule class >> group [ { #category : 'accessing' } ReCyclomaticComplexityRule class >> rationale [ - ^ 'When the cyclomatic complexity is heigh, try to refactor your code' + ^ 'When the cyclomatic complexity is high, try to refactor your code' ] { #category : 'accessing' } ReCyclomaticComplexityRule class >> ruleName [ - ^ 'The cyclomatic complexity is heigh' + ^ 'The cyclomatic complexity is high' ] { #category : 'running' } From 5b996837da1af504352a7bdfe7342254072b336d Mon Sep 17 00:00:00 2001 From: Pablo Tesone Date: Thu, 31 Oct 2024 12:06:58 +0100 Subject: [PATCH 15/20] Adding more tests to the EnhancedDebugSession --- .../EnhancedStepThroughTest.class.st | 26 ------- .../StepThroughTest.class.st | 67 ++++++++++++++++--- src/Kernel-CodeModel/Context.class.st | 1 + .../InstructionStream.class.st | 3 +- 4 files changed, 59 insertions(+), 38 deletions(-) diff --git a/src/Debugger-Model-Tests/EnhancedStepThroughTest.class.st b/src/Debugger-Model-Tests/EnhancedStepThroughTest.class.st index f16595cf05b..7c9475686e6 100644 --- a/src/Debugger-Model-Tests/EnhancedStepThroughTest.class.st +++ b/src/Debugger-Model-Tests/EnhancedStepThroughTest.class.st @@ -11,29 +11,3 @@ EnhancedStepThroughTest >> settingUpSessionAndProcessAndContextForBlock: aBlock super settingUpSessionAndProcessAndContextForBlock: aBlock. session := process newEnhancedDebugSessionNamed: 'test session' startedAt: context ] - -{ #category : 'helper' } -EnhancedStepThroughTest >> stepA1 [ - self evalBlockThenReturnOne: [ self stepA2 ] -] - -{ #category : 'helper' } -EnhancedStepThroughTest >> stepA2 [ - ^ 2+2 -] - -{ #category : 'helper' } -EnhancedStepThroughTest >> stepB1 [ - self stepB2. - self stepB3 -] - -{ #category : 'helper' } -EnhancedStepThroughTest >> stepB2 [ - ^ 42 -] - -{ #category : 'helper' } -EnhancedStepThroughTest >> stepB3 [ - ^ 43 -] diff --git a/src/Debugger-Model-Tests/StepThroughTest.class.st b/src/Debugger-Model-Tests/StepThroughTest.class.st index 877507fa9aa..e8117c49603 100644 --- a/src/Debugger-Model-Tests/StepThroughTest.class.st +++ b/src/Debugger-Model-Tests/StepThroughTest.class.st @@ -6,6 +6,15 @@ Class { #tag : 'Core' } +{ #category : 'helper' } +StepThroughTest >> evalBlock: aBlockClosure afterLoop: remainingCount [ + + remainingCount = 1 ifTrue: [ ^ aBlockClosure value ]. + + ^ self evalBlock: aBlockClosure afterLoop: remainingCount - 1. + +] + { #category : 'helper' } StepThroughTest >> evalBlockThenReturnOne: aBlock [ aBlock value. @@ -38,6 +47,17 @@ StepThroughTest >> stepB3 [ ^ 43 ] +{ #category : 'helper' } +StepThroughTest >> stepC1 [ + self evalBlock: [ self stepC2 ] afterLoop: 100 +] + +{ #category : 'helper' } +StepThroughTest >> stepC2 [ + + ^ 5 +] + { #category : 'tests' } StepThroughTest >> testStepThrough [ "In a context c, define a block b, send a message to another method to get b evaluated. @@ -48,15 +68,15 @@ StepThroughTest >> testStepThrough [ session stepInto. "Reached node 'self evalBlockThenReturnOne: [self stepA2]' of method stepA1" "Checking that the execution is indeed at this node" - self assert: (session interruptedContext method) equals: (self class>>#stepA1). - node := self class>>#stepA1 sourceNodeForPC: session interruptedContext pc. + self assert: (session interruptedContext method) equals: (self class lookupSelector: #stepA1). + node := (self class lookupSelector: #stepA1) sourceNodeForPC: session interruptedContext pc. self assert: node isMessage. self assert: node receiver isSelfVariable. self assert: node selector equals: #evalBlockThenReturnOne:. session stepThrough. "With fullblocks the method of the suspended context is a compiledBlock, not the method having it" - expectedMethod := (self class >> #stepA1) literalAt: 1 . + expectedMethod := (self class lookupSelector: #stepA1) literalAt: 1 . "Checking that after the step through, the execution is at the 'self stepA2' node of the stepA1 method" self assert: (session interruptedContext method) equals: expectedMethod. @@ -72,34 +92,61 @@ StepThroughTest >> testStepThroughDoesTheSameThingAsStepOverWhenNoBlockIsInvolve | node | self settingUpSessionAndProcessAndContextForBlock: [ self stepB1 ]. - [session interruptedContext method == (self class>>#stepB1)] + [session interruptedContext method == (self class lookupSelector: #stepB1)] whileFalse: [ session stepInto ]. "Reached node 'self stepB2' of method stepB1" - self assert: session interruptedContext method equals: self class>>#stepB1. + self assert: session interruptedContext method equals: (self class lookupSelector:#stepB1). session stepOver. - self assert: (session interruptedContext method) equals: (self class>>#stepB1). + self assert: (session interruptedContext method) equals: (self class lookupSelector:#stepB1). "Checking that after the step over, we reached the node 'self stepB3' of method stepB1" - node := self class>>#stepB1 sourceNodeForPC: session interruptedContext pc. + node := (self class lookupSelector:#stepB1) sourceNodeForPC: session interruptedContext pc. self assert: node isMessage. self assert: node receiver isSelfVariable. self assert: node selector equals: #stepB3. "Set up the debugged execution again" self settingUpSessionAndProcessAndContextForBlock: [ self stepB1 ]. - [session interruptedContext method == (self class>>#stepB1)] + [session interruptedContext method == (self class lookupSelector:#stepB1)] whileFalse: [ session stepInto ]. "Reached node 'self stepB2' of method stepB1" - self assert: session interruptedContext method equals: self class>>#stepB1. + self assert: session interruptedContext method equals: (self class lookupSelector:#stepB1). session stepThrough. "Checking that after the step through, we reached the node 'self stepB3' of method stepB1 (the same node that was reached with the step over" - node := self class>>#stepB1 sourceNodeForPC: session interruptedContext pc. + node := (self class lookupSelector:#stepB1) sourceNodeForPC: session interruptedContext pc. self assert: node isMessage. self assert: node receiver isSelfVariable. self assert: node selector equals: #stepB3 ] +{ #category : 'tests' } +StepThroughTest >> testStepThroughLonger [ + "In a context c, define a block b, send a message to another method to get b evaluated. + Testing that a step through on this message send moves the execution to the point where the block b is about to be evaluated." + | node expectedMethod | + + self settingUpSessionAndProcessAndContextForBlock: [ self stepC1 ]. + session stepInto. + session stepInto. + "Reached node 'self evalBlock: [ self stepC2 ] afterLoop: 10' of method stepC1" + "Checking that the execution is indeed at this node" + self assert: (session interruptedContext method) equals: (self class lookupSelector:#stepC1). + node := (self class lookupSelector:#stepC1) sourceNodeForPC: session interruptedContext pc. + + session stepThrough. + + "With fullblocks the method of the suspended context is a compiledBlock, not the method having it" + expectedMethod := (self class lookupSelector: #stepC1) literalAt: 1 . + + "Checking that after the step through, the execution is at the 'self stepA2' node of the stepA1 method" + self assert: (session interruptedContext method) equals: expectedMethod. + node := expectedMethod sourceNodeForPC: session interruptedContext pc. + self assert: node isMessage. + self assert: node receiver isSelfVariable. + self assert: node selector equals: #stepC2 +] + { #category : 'tests' } StepThroughTest >> testStepThroughUntilTermination [ "Stepping over a message node brings the execution to the next node in the same method." diff --git a/src/Kernel-CodeModel/Context.class.st b/src/Kernel-CodeModel/Context.class.st index 18598f94065..e9b63dee35e 100644 --- a/src/Kernel-CodeModel/Context.class.st +++ b/src/Kernel-CodeModel/Context.class.st @@ -28,6 +28,7 @@ Class { 'receiver' ], #classVars : [ + 'ExceptionsToCapture', 'PrimitiveFailToken', 'SpecialPrimitiveSimulators', 'TryNamedPrimitiveTemplateMethod' diff --git a/src/Kernel-CodeModel/InstructionStream.class.st b/src/Kernel-CodeModel/InstructionStream.class.st index 014f95b32a7..9c23f88db93 100644 --- a/src/Kernel-CodeModel/InstructionStream.class.st +++ b/src/Kernel-CodeModel/InstructionStream.class.st @@ -262,8 +262,7 @@ InstructionStream >> interpretNextSistaV1InstructionFor: client [ offset < 8 ifTrue: [^client popIntoTemporaryVariable: offset]. offset = 8 ifTrue: [ ^ client doPop ]. - offset = 9 ifTrue: [ byte traceCr. -^ client trap ]. + offset = 9 ifTrue: [ ^ client trap ]. ^self interpretUnusedBytecode: client at: savedPC]. "2 byte and 3 byte codes" From 679822cd0ae7f6535d9ad72297dfec26b5dfeef3 Mon Sep 17 00:00:00 2001 From: Pablo Tesone Date: Fri, 8 Nov 2024 16:22:32 +0100 Subject: [PATCH 16/20] - Adding more tests --- .../StepThroughTest.class.st | 121 ++++++++++++++++++ src/Debugger-Model/DebugSession.class.st | 5 +- .../EnhancedDebugSession.class.st | 7 +- src/Debugging-Core/UnknownBytecode.class.st | 5 + .../InstructionStream.class.st | 3 + 5 files changed, 139 insertions(+), 2 deletions(-) diff --git a/src/Debugger-Model-Tests/StepThroughTest.class.st b/src/Debugger-Model-Tests/StepThroughTest.class.st index e8117c49603..c2268a0cefc 100644 --- a/src/Debugger-Model-Tests/StepThroughTest.class.st +++ b/src/Debugger-Model-Tests/StepThroughTest.class.st @@ -1,6 +1,9 @@ Class { #name : 'StepThroughTest', #superclass : 'DebuggerTest', + #instVars : [ + 'aBlock' + ], #category : 'Debugger-Model-Tests-Core', #package : 'Debugger-Model-Tests', #tag : 'Core' @@ -58,6 +61,39 @@ StepThroughTest >> stepC2 [ ^ 5 ] +{ #category : 'helper' } +StepThroughTest >> stepD1 [ + + aBlock := [ 2 + 3 ]. + + self stepD2 + +] + +{ #category : 'helper' } +StepThroughTest >> stepD2 [ + + aBlock value +] + +{ #category : 'helper' } +StepThroughTest >> stepE1 [ + + | tmpBlock | + tmpBlock := [ 2 - 3 ]. + + self evalBlockThenReturnOne: tmpBlock +] + +{ #category : 'helper' } +StepThroughTest >> stepF1 [ + + | tmpBlock | + tmpBlock := [ 2 - 3 ]. + + tmpBlock value +] + { #category : 'tests' } StepThroughTest >> testStepThrough [ "In a context c, define a block b, send a message to another method to get b evaluated. @@ -120,6 +156,91 @@ StepThroughTest >> testStepThroughDoesTheSameThingAsStepOverWhenNoBlockIsInvolve self assert: node selector equals: #stepB3 ] +{ #category : 'tests' } +StepThroughTest >> testStepThroughInABlockInAInstanceVariable [ + "In a context c, define a block b, send a message to another method to get b evaluated. + Testing that a step through on this message send moves the execution to the point where the block b is about to be evaluated." + | node expectedMethod | + + self settingUpSessionAndProcessAndContextForBlock: [ self stepD1 ]. + + session stepInto. + session stepInto. + session stepInto. + + "Reached node 'self evalBlock: [ self stepC2 ] afterLoop: 10' of method stepC1" + "Checking that the execution is indeed at this node" + self assert: (session interruptedContext method) equals: (self class lookupSelector: #stepD1). + node := (self class lookupSelector:#stepD1) sourceNodeForPC: session interruptedContext pc. + + session stepThrough. + + "With fullblocks the method of the suspended context is a compiledBlock, not the method having it" + expectedMethod := (self class lookupSelector: #stepD1) literalAt: 1 . + + "Checking that after the step through, the execution is at the 'self stepA2' node of the stepA1 method" + self assert: (session interruptedContext method) equals: expectedMethod. + node := expectedMethod sourceNodeForPC: session interruptedContext pc. + self assert: node isMessage. + self assert: node receiver value equals: 2. + self assert: node selector equals: #+ +] + +{ #category : 'tests' } +StepThroughTest >> testStepThroughInABlockInATemporary [ + + | node expectedMethod | + + self settingUpSessionAndProcessAndContextForBlock: [ self stepE1 ]. + + session stepInto. + session stepInto. + session stepInto. + + self assert: (session interruptedContext method) equals: (self class lookupSelector: #stepE1). + node := (self class lookupSelector:#stepE1) sourceNodeForPC: session interruptedContext pc. + +1halt. + session stepThrough. + + "With fullblocks the method of the suspended context is a compiledBlock, not the method having it" + expectedMethod := (self class lookupSelector: #stepE1) literalAt: 1 . + + "Checking that after the step through, the execution is at the 'self stepA2' node of the stepA1 method" + self assert: (session interruptedContext method) equals: expectedMethod. + node := expectedMethod sourceNodeForPC: session interruptedContext pc. + self assert: node isMessage. + self assert: node receiver value equals: 2. + self assert: node selector equals: #- +] + +{ #category : 'tests' } +StepThroughTest >> testStepThroughInABlockInATemporaryDirectly [ + + | node expectedMethod | + + self settingUpSessionAndProcessAndContextForBlock: [ self stepF1 ]. + + session stepInto. + session stepInto. + session stepInto. + + self assert: (session interruptedContext method) equals: (self class lookupSelector: #stepF1). + node := (self class lookupSelector:#stepF1) sourceNodeForPC: session interruptedContext pc. + + session stepThrough. + + "With fullblocks the method of the suspended context is a compiledBlock, not the method having it" + expectedMethod := (self class lookupSelector: #stepF1) literalAt: 1 . + + "Checking that after the step through, the execution is at the 'self stepA2' node of the stepA1 method" + self assert: (session interruptedContext method) equals: expectedMethod. + node := expectedMethod sourceNodeForPC: session interruptedContext pc. + self assert: node isMessage. + self assert: node receiver value equals: 2. + self assert: node selector equals: #- +] + { #category : 'tests' } StepThroughTest >> testStepThroughLonger [ "In a context c, define a block b, send a message to another method to get b evaluated. diff --git a/src/Debugger-Model/DebugSession.class.st b/src/Debugger-Model/DebugSession.class.st index ab81dbf10ba..8cf42f2e5a5 100644 --- a/src/Debugger-Model/DebugSession.class.st +++ b/src/Debugger-Model/DebugSession.class.st @@ -558,7 +558,10 @@ DebugSession >> stepOver: aContext [ { #category : 'debugging actions' } DebugSession >> stepThrough [ - self stepThrough: interruptedContext + 1halt. + [self stepThrough: interruptedContext] + on: UnknownBytecode + do: [ :e | self halt ] ] { #category : 'debugging actions' } diff --git a/src/Debugger-Model/EnhancedDebugSession.class.st b/src/Debugger-Model/EnhancedDebugSession.class.st index 53dcf6828e5..01a0ffdab78 100644 --- a/src/Debugger-Model/EnhancedDebugSession.class.st +++ b/src/Debugger-Model/EnhancedDebugSession.class.st @@ -110,10 +110,15 @@ EnhancedDebugSession >> stepThrough: aContext [ { #category : 'preparation' } EnhancedDebugSession >> updateFullBlocksOf: aContext withIndex: anIndex [ - | originalBlock newBlock newCompiledBlock | + | originalBlock newBlock newCompiledBlock blockIndex | originalBlock := aContext at: anIndex. originalBlock isBlock ifFalse: [ ^ self ]. + + (blockIndex := originalBlocks indexOf: originalBlock) > 0 + ifTrue: [ + aContext at: anIndex put: (newBlocks at: blockIndex). + ^ self ]. newBlock := originalBlock clone. newCompiledBlock := newBlock compiledBlock clone. diff --git a/src/Debugging-Core/UnknownBytecode.class.st b/src/Debugging-Core/UnknownBytecode.class.st index 2e6dc472e7f..d81ed0ffbb1 100644 --- a/src/Debugging-Core/UnknownBytecode.class.st +++ b/src/Debugging-Core/UnknownBytecode.class.st @@ -9,6 +9,11 @@ Class { #package : 'Debugging-Core' } +{ #category : 'testing' } +UnknownBytecode class >> captureIfSignalledWhenStepping [ + ^self == UnknownBytecode +] + { #category : 'accessing' } UnknownBytecode >> bytecode [ ^ bytecode diff --git a/src/Kernel-CodeModel/InstructionStream.class.st b/src/Kernel-CodeModel/InstructionStream.class.st index 9c23f88db93..d69c5b92571 100644 --- a/src/Kernel-CodeModel/InstructionStream.class.st +++ b/src/Kernel-CodeModel/InstructionStream.class.st @@ -285,6 +285,9 @@ InstructionStream >> interpretSistaV1ExtendedPush: extB for: client [ { #category : 'interpreting' } InstructionStream >> interpretUnusedBytecode: client at: startPC [ + + "We recover the PC to the real bytecode that is unknown" + client pc: startPC. ^ client unusedBytecode ] From 342280416b916bb1bf34b3028658804f74ec3df5 Mon Sep 17 00:00:00 2001 From: Pablo Tesone Date: Tue, 12 Nov 2024 11:22:33 +0100 Subject: [PATCH 17/20] The Bytecode interpreter should do the same that the VM, it should not raise an exception in the interpreter but put a new context in it with the message send taken from the Smalltalk Special Array --- src/Debugger-Model-Tests/StepThroughTest.class.st | 1 - src/Debugger-Model/DebugSession.class.st | 5 +---- src/Debugger-Model/Process.extension.st | 2 +- src/Debugging-Core/Context.extension.st | 14 ++++++++++++++ src/Kernel-CodeModel/InstructionStream.class.st | 2 +- src/Kernel/InstructionClient.class.st | 7 +++++++ 6 files changed, 24 insertions(+), 7 deletions(-) diff --git a/src/Debugger-Model-Tests/StepThroughTest.class.st b/src/Debugger-Model-Tests/StepThroughTest.class.st index c2268a0cefc..c74ac491e3e 100644 --- a/src/Debugger-Model-Tests/StepThroughTest.class.st +++ b/src/Debugger-Model-Tests/StepThroughTest.class.st @@ -200,7 +200,6 @@ StepThroughTest >> testStepThroughInABlockInATemporary [ self assert: (session interruptedContext method) equals: (self class lookupSelector: #stepE1). node := (self class lookupSelector:#stepE1) sourceNodeForPC: session interruptedContext pc. -1halt. session stepThrough. "With fullblocks the method of the suspended context is a compiledBlock, not the method having it" diff --git a/src/Debugger-Model/DebugSession.class.st b/src/Debugger-Model/DebugSession.class.st index 8cf42f2e5a5..ab81dbf10ba 100644 --- a/src/Debugger-Model/DebugSession.class.st +++ b/src/Debugger-Model/DebugSession.class.st @@ -558,10 +558,7 @@ DebugSession >> stepOver: aContext [ { #category : 'debugging actions' } DebugSession >> stepThrough [ - 1halt. - [self stepThrough: interruptedContext] - on: UnknownBytecode - do: [ :e | self halt ] + self stepThrough: interruptedContext ] { #category : 'debugging actions' } diff --git a/src/Debugger-Model/Process.extension.st b/src/Debugger-Model/Process.extension.st index 72304439630..d053f04d00a 100644 --- a/src/Debugger-Model/Process.extension.st +++ b/src/Debugger-Model/Process.extension.st @@ -31,7 +31,7 @@ Process >> newDebugSessionNamed: aString startedAt: aContext [ { #category : '*Debugger-Model' } Process >> newEnhancedDebugSessionNamed: aString startedAt: aContext [ - ^EnhancedDebugSession named: aString on: self startedAt: aContext + ^ EnhancedDebugSession named: aString on: self startedAt: aContext ] { #category : '*Debugger-Model' } diff --git a/src/Debugging-Core/Context.extension.st b/src/Debugging-Core/Context.extension.st index e529de024ac..2834114157f 100644 --- a/src/Debugging-Core/Context.extension.st +++ b/src/Debugging-Core/Context.extension.st @@ -393,6 +393,20 @@ Context >> unusedBytecode [ ^ self respondsToUnknownBytecode ] +{ #category : '*Debugging-Core' } +Context >> unusedBytecode: aBytecode at: startPC [ + + | selector newContext | + + "I am the implementation when the unusedBycode is detected by the instruction stream. + I should not throw the exception, but do the same behavior than the VM. Pushing a new Context with the unusedBytecode selector (taken from the specialObjectsArray" + + selector := Smalltalk specialObjectsArray at:58. + newContext := self class sender: self receiver: self method: (self class lookupSelector: selector) arguments: #(). + + ^ newContext +] + { #category : '*Debugging-Core' } Context >> updatePCForQuickPrimitiveRestart [ diff --git a/src/Kernel-CodeModel/InstructionStream.class.st b/src/Kernel-CodeModel/InstructionStream.class.st index d69c5b92571..a8c134c152e 100644 --- a/src/Kernel-CodeModel/InstructionStream.class.st +++ b/src/Kernel-CodeModel/InstructionStream.class.st @@ -288,7 +288,7 @@ InstructionStream >> interpretUnusedBytecode: client at: startPC [ "We recover the PC to the real bytecode that is unknown" client pc: startPC. - ^ client unusedBytecode + ^ client unusedBytecode: (self compiledCode at: startPC) at: startPC ] { #category : 'scanning' } diff --git a/src/Kernel/InstructionClient.class.st b/src/Kernel/InstructionClient.class.st index e256feddbd1..d99159284fc 100644 --- a/src/Kernel/InstructionClient.class.st +++ b/src/Kernel/InstructionClient.class.st @@ -233,3 +233,10 @@ InstructionClient >> trap [ InstructionClient >> unusedBytecode [ "an unused bytecode is encountered" ] + +{ #category : 'instruction decoding' } +InstructionClient >> unusedBytecode: aBytecode at: startPC [ + + "I will just call the default operation" + self unusedBytecode +] From cd6d853f06c28ada4aed952e8a958c46c2e92bfa Mon Sep 17 00:00:00 2001 From: Pablo Tesone Date: Fri, 15 Nov 2024 15:08:24 +0100 Subject: [PATCH 18/20] Adding a test using a block in another process --- .../StepThroughTest.class.st | 45 ++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/src/Debugger-Model-Tests/StepThroughTest.class.st b/src/Debugger-Model-Tests/StepThroughTest.class.st index c74ac491e3e..8466ff26711 100644 --- a/src/Debugger-Model-Tests/StepThroughTest.class.st +++ b/src/Debugger-Model-Tests/StepThroughTest.class.st @@ -2,7 +2,8 @@ Class { #name : 'StepThroughTest', #superclass : 'DebuggerTest', #instVars : [ - 'aBlock' + 'aBlock', + 'failed' ], #category : 'Debugger-Model-Tests-Core', #package : 'Debugger-Model-Tests', @@ -94,6 +95,33 @@ StepThroughTest >> stepF1 [ tmpBlock value ] +{ #category : 'helper' } +StepThroughTest >> stepG1 [ + + | sem | + + sem := Semaphore new. + + self stepG2: [ 1 + 3 ] sem: sem. + +] + +{ #category : 'helper' } +StepThroughTest >> stepG2: aTmp sem: sem [ + + [ + sem wait. + [ + aTmp value. + failed := false ] onErrorDo: [ failed := true ] ] forkAt: + Processor activePriority + 1. + + sem signal. + + [ failed isNil ] whileTrue: [ Processor yield ]. + +] + { #category : 'tests' } StepThroughTest >> testStepThrough [ "In a context c, define a block b, send a message to another method to get b evaluated. @@ -240,6 +268,21 @@ StepThroughTest >> testStepThroughInABlockInATemporaryDirectly [ self assert: node selector equals: #- ] +{ #category : 'tests' } +StepThroughTest >> testStepThroughInOtherProcess [ + + self settingUpSessionAndProcessAndContextForBlock: [ self stepG1 ]. + + session stepInto. + + session stepThrough. + session stepThrough. + session stepThrough. + session stepThrough. + + self deny: failed. +] + { #category : 'tests' } StepThroughTest >> testStepThroughLonger [ "In a context c, define a block b, send a message to another method to get b evaluated. From 5d9681841193a5135cb5067423fb7c8487d656d9 Mon Sep 17 00:00:00 2001 From: Pablo Tesone Date: Fri, 15 Nov 2024 15:56:20 +0100 Subject: [PATCH 19/20] Adding implementation with HaltingBlock --- ...edStepThroughWithHaltingBlockTest.class.st | 16 +++ .../StepThroughTest.class.st | 2 +- ...ancedDebugSessionWithHaltingBlock.class.st | 121 ++++++++++++++++++ src/Debugger-Model/HaltingBlock.class.st | 84 ++++++++++++ 4 files changed, 222 insertions(+), 1 deletion(-) create mode 100644 src/Debugger-Model-Tests/EnhancedStepThroughWithHaltingBlockTest.class.st create mode 100644 src/Debugger-Model/EnhancedDebugSessionWithHaltingBlock.class.st create mode 100644 src/Debugger-Model/HaltingBlock.class.st diff --git a/src/Debugger-Model-Tests/EnhancedStepThroughWithHaltingBlockTest.class.st b/src/Debugger-Model-Tests/EnhancedStepThroughWithHaltingBlockTest.class.st new file mode 100644 index 00000000000..bd58fa9354e --- /dev/null +++ b/src/Debugger-Model-Tests/EnhancedStepThroughWithHaltingBlockTest.class.st @@ -0,0 +1,16 @@ +Class { + #name : 'EnhancedStepThroughWithHaltingBlockTest', + #superclass : 'StepThroughTest', + #category : 'Debugger-Model-Tests-Core', + #package : 'Debugger-Model-Tests', + #tag : 'Core' +} + +{ #category : 'utilities' } +EnhancedStepThroughWithHaltingBlockTest >> settingUpSessionAndProcessAndContextForBlock: aBlock [ + + super settingUpSessionAndProcessAndContextForBlock: aBlock. + session := EnhancedDebugSessionWithHaltingBlock named: 'test session' on: process startedAt: context + + +] diff --git a/src/Debugger-Model-Tests/StepThroughTest.class.st b/src/Debugger-Model-Tests/StepThroughTest.class.st index 8466ff26711..fb6036652f8 100644 --- a/src/Debugger-Model-Tests/StepThroughTest.class.st +++ b/src/Debugger-Model-Tests/StepThroughTest.class.st @@ -113,7 +113,7 @@ StepThroughTest >> stepG2: aTmp sem: sem [ sem wait. [ aTmp value. - failed := false ] onErrorDo: [ failed := true ] ] forkAt: + failed := false ] on: Exception do: [ failed := true ] ] forkAt: Processor activePriority + 1. sem signal. diff --git a/src/Debugger-Model/EnhancedDebugSessionWithHaltingBlock.class.st b/src/Debugger-Model/EnhancedDebugSessionWithHaltingBlock.class.st new file mode 100644 index 00000000000..70f582c2959 --- /dev/null +++ b/src/Debugger-Model/EnhancedDebugSessionWithHaltingBlock.class.st @@ -0,0 +1,121 @@ +Class { + #name : 'EnhancedDebugSessionWithHaltingBlock', + #superclass : 'DebugSession', + #instVars : [ + 'originalBlocks', + 'newBlocks' + ], + #category : 'Debugger-Model-Core', + #package : 'Debugger-Model', + #tag : 'Core' +} + +{ #category : 'menu - operations' } +EnhancedDebugSessionWithHaltingBlock >> findNextContext: aContext [ + + | callingContext idx haltingBlock newContext | + + originalBlocks ifEmpty: [ ^ aContext ]. + + (aContext receiver isKindOf: Halt) ifFalse: [ ^ aContext ]. + + callingContext := aContext. + [ callingContext method = (HaltingBlock >> #haltIfStepping) ] whileFalse: [ callingContext := callingContext sender ]. + + haltingBlock := callingContext receiver. + [ callingContext receiver class = HaltingBlock ] whileTrue: [ callingContext := callingContext sender ]. + + newContext := haltingBlock originalBlock asContextWithSender: callingContext. + newContext stepToSendOrReturn. + + ^ newContext +] + +{ #category : 'initialization' } +EnhancedDebugSessionWithHaltingBlock >> initialize [ + + super initialize. + originalBlocks := OrderedCollection new. + newBlocks := OrderedCollection new. +] + +{ #category : 'preparation' } +EnhancedDebugSessionWithHaltingBlock >> prepareContextForStepThrough: aContext [ + + 1 to: aContext size do: [ :idx | + self updateFullBlocksOf: aContext withIndex: idx ] +] + +{ #category : 'clean-up' } +EnhancedDebugSessionWithHaltingBlock >> revertBlocks [ + + newBlocks asArray elementsForwardIdentityTo: originalBlocks asArray. + +] + +{ #category : 'debugging actions' } +EnhancedDebugSessionWithHaltingBlock >> stepOver: aContext [ + "Send the selected message in selectedContext, and regain control + after the invoked method returns." + + | newContext | + aContext stepIntoQuickMethod: false. + (self isContextPostMortem: aContext) ifTrue: [^ self]. + + newContext := interruptedProcess completeStep: aContext. + self updateContextTo: + (newContext == aContext + ifTrue: [ (self stepToFirstInterestingBytecodeIn: interruptedProcess) ] + ifFalse: [ newContext ]). + + self triggerEvent: #stepOver +] + +{ #category : 'debugging actions' } +EnhancedDebugSessionWithHaltingBlock >> stepThrough: aContext [ + "Send messages until you return to selectedContext. + Used to step into a block in the method." + + | newContext | + + aContext stepIntoQuickMethod: false. + (self isContextPostMortem: aContext) ifTrue: [^ self]. + + self prepareContextForStepThrough: aContext. + + newContext := interruptedProcess completeStep: aContext. + + newContext := self findNextContext: newContext. + + self revertBlocks. + + self updateContextTo: + (newContext == aContext + ifTrue: [ (self stepToFirstInterestingBytecodeIn: interruptedProcess) ] + ifFalse: [ newContext ]). + + self triggerEvent: #stepThrough +] + +{ #category : 'preparation' } +EnhancedDebugSessionWithHaltingBlock >> updateFullBlocksOf: aContext withIndex: anIndex [ + + | originalBlock newBlock blockIndex | + + originalBlock := aContext at: anIndex. + originalBlock isBlock ifFalse: [ ^ self ]. + + (blockIndex := originalBlocks indexOf: originalBlock) > 0 + ifTrue: [ + aContext at: anIndex put: (newBlocks at: blockIndex). + ^ self ]. + + newBlock := HaltingBlock new + originalBlock: originalBlock; + yourself. + + originalBlocks add: originalBlock. + newBlocks add: newBlock. + + aContext at: anIndex put: newBlock. +] diff --git a/src/Debugger-Model/HaltingBlock.class.st b/src/Debugger-Model/HaltingBlock.class.st new file mode 100644 index 00000000000..1d10bf11e9b --- /dev/null +++ b/src/Debugger-Model/HaltingBlock.class.st @@ -0,0 +1,84 @@ +Class { + #name : 'HaltingBlock', + #superclass : 'FullBlockClosure', + #type : 'variable', + #instVars : [ + 'originalBlock' + ], + #category : 'Debugger-Model-Core', + #package : 'Debugger-Model', + #tag : 'Core' +} + +{ #category : 'as yet unclassified' } +HaltingBlock >> haltIfStepping [ + + self halt +] + +{ #category : 'accessing' } +HaltingBlock >> originalBlock [ + ^ originalBlock +] + +{ #category : 'accessing' } +HaltingBlock >> originalBlock: aBlock [ + + outerContext := aBlock outerContext. + numArgs := aBlock numArgs. + receiver := aBlock receiver. + originalBlock := aBlock +] + +{ #category : 'evaluating' } +HaltingBlock >> value [ + + self valueWithArguments: #() +] + +{ #category : 'evaluating' } +HaltingBlock >> value: firstArg [ + + ^ self valueWithArguments: { firstArg } +] + +{ #category : 'evaluating' } +HaltingBlock >> value: firstArg value: secondArg [ + + ^ self valueWithArguments: { firstArg. secondArg } +] + +{ #category : 'evaluating' } +HaltingBlock >> value: firstArg value: secondArg value: thirdArg [ + + ^ self valueWithArguments: { firstArg. secondArg. thirdArg } +] + +{ #category : 'evaluating' } +HaltingBlock >> value: firstArg value: secondArg value: thirdArg value: fourthArg [ + + ^ self valueWithArguments: { firstArg. secondArg. thirdArg. fourthArg } +] + +{ #category : 'evaluating' } +HaltingBlock >> valueNoContextSwitch [ + + self haltIfStepping. + ^ originalBlock valueNoContextSwitch + +] + +{ #category : 'evaluating' } +HaltingBlock >> valueNoContextSwitch: anArg [ + + self haltIfStepping. + ^ originalBlock valueNoContextSwitch: anArg + +] + +{ #category : 'evaluating' } +HaltingBlock >> valueWithArguments: anArray [ + + self haltIfStepping. + ^ originalBlock valueWithArguments: anArray +] From 450b8387f2a780a4d4edd569db41fda361538f59 Mon Sep 17 00:00:00 2001 From: Pablo Tesone Date: Fri, 15 Nov 2024 16:15:36 +0100 Subject: [PATCH 20/20] Halting only if we are stepping --- .../DebuggerSteppingState.class.st | 16 ++++++++++++++ .../EnhancedDebugSession.class.st | 21 ++----------------- ...ancedDebugSessionWithHaltingBlock.class.st | 20 ++---------------- src/Debugger-Model/HaltingBlock.class.st | 4 ++-- 4 files changed, 22 insertions(+), 39 deletions(-) create mode 100644 src/Debugger-Model/DebuggerSteppingState.class.st diff --git a/src/Debugger-Model/DebuggerSteppingState.class.st b/src/Debugger-Model/DebuggerSteppingState.class.st new file mode 100644 index 00000000000..7e735895f49 --- /dev/null +++ b/src/Debugger-Model/DebuggerSteppingState.class.st @@ -0,0 +1,16 @@ +" +I am a process variable to hold if we are stepping through or not +" +Class { + #name : 'DebuggerSteppingState', + #superclass : 'ProcessLocalVariable', + #category : 'Debugger-Model-Core', + #package : 'Debugger-Model', + #tag : 'Core' +} + +{ #category : 'accessing' } +DebuggerSteppingState >> default [ + + ^ false +] diff --git a/src/Debugger-Model/EnhancedDebugSession.class.st b/src/Debugger-Model/EnhancedDebugSession.class.st index 01a0ffdab78..12e9e8f461d 100644 --- a/src/Debugger-Model/EnhancedDebugSession.class.st +++ b/src/Debugger-Model/EnhancedDebugSession.class.st @@ -53,7 +53,8 @@ EnhancedDebugSession >> initialize [ EnhancedDebugSession >> prepareContextForStepThrough: aContext [ 1 to: aContext size do: [ :idx | - self updateFullBlocksOf: aContext withIndex: idx ] + self updateFullBlocksOf: aContext withIndex: idx ]. + ] { #category : 'clean-up' } @@ -63,24 +64,6 @@ EnhancedDebugSession >> revertBlocks [ ] -{ #category : 'debugging actions' } -EnhancedDebugSession >> stepOver: aContext [ - "Send the selected message in selectedContext, and regain control - after the invoked method returns." - - | newContext | - aContext stepIntoQuickMethod: false. - (self isContextPostMortem: aContext) ifTrue: [^ self]. - - newContext := interruptedProcess completeStep: aContext. - self updateContextTo: - (newContext == aContext - ifTrue: [ (self stepToFirstInterestingBytecodeIn: interruptedProcess) ] - ifFalse: [ newContext ]). - - self triggerEvent: #stepOver -] - { #category : 'debugging actions' } EnhancedDebugSession >> stepThrough: aContext [ "Send messages until you return to selectedContext. diff --git a/src/Debugger-Model/EnhancedDebugSessionWithHaltingBlock.class.st b/src/Debugger-Model/EnhancedDebugSessionWithHaltingBlock.class.st index 70f582c2959..672b5038383 100644 --- a/src/Debugger-Model/EnhancedDebugSessionWithHaltingBlock.class.st +++ b/src/Debugger-Model/EnhancedDebugSessionWithHaltingBlock.class.st @@ -53,24 +53,6 @@ EnhancedDebugSessionWithHaltingBlock >> revertBlocks [ ] -{ #category : 'debugging actions' } -EnhancedDebugSessionWithHaltingBlock >> stepOver: aContext [ - "Send the selected message in selectedContext, and regain control - after the invoked method returns." - - | newContext | - aContext stepIntoQuickMethod: false. - (self isContextPostMortem: aContext) ifTrue: [^ self]. - - newContext := interruptedProcess completeStep: aContext. - self updateContextTo: - (newContext == aContext - ifTrue: [ (self stepToFirstInterestingBytecodeIn: interruptedProcess) ] - ifFalse: [ newContext ]). - - self triggerEvent: #stepOver -] - { #category : 'debugging actions' } EnhancedDebugSessionWithHaltingBlock >> stepThrough: aContext [ "Send messages until you return to selectedContext. @@ -83,7 +65,9 @@ EnhancedDebugSessionWithHaltingBlock >> stepThrough: aContext [ self prepareContextForStepThrough: aContext. + interruptedProcess psValueAt: (DebuggerSteppingState soleInstance index) put: true. newContext := interruptedProcess completeStep: aContext. + interruptedProcess psValueAt: (DebuggerSteppingState soleInstance index) put: false. newContext := self findNextContext: newContext. diff --git a/src/Debugger-Model/HaltingBlock.class.st b/src/Debugger-Model/HaltingBlock.class.st index 1d10bf11e9b..0a4e932ea7d 100644 --- a/src/Debugger-Model/HaltingBlock.class.st +++ b/src/Debugger-Model/HaltingBlock.class.st @@ -10,10 +10,10 @@ Class { #tag : 'Core' } -{ #category : 'as yet unclassified' } +{ #category : 'exceptions' } HaltingBlock >> haltIfStepping [ - self halt + DebuggerSteppingState value ifTrue: [ self halt ] ] { #category : 'accessing' }