From b95b2d8f884eceffca6d33a46459686eaf9bc190 Mon Sep 17 00:00:00 2001 From: StevenCostiou Date: Wed, 12 Aug 2020 12:05:20 +0200 Subject: [PATCH] Fixes https://github.com/pharo-project/pharo/issues/7038 Added a fastTDD mode, disabled by default. When disabled, asks the user in which class and in which protocol to create methods in the debugger. --- .../StDebuggerTest.class.st | 30 +++++- src/NewTools-Debugger/StDebugger.class.st | 99 ++++++++++++++----- 2 files changed, 101 insertions(+), 28 deletions(-) diff --git a/src/NewTools-Debugger-Tests/StDebuggerTest.class.st b/src/NewTools-Debugger-Tests/StDebuggerTest.class.st index b38b46482..f10af79d9 100644 --- a/src/NewTools-Debugger-Tests/StDebuggerTest.class.st +++ b/src/NewTools-Debugger-Tests/StDebuggerTest.class.st @@ -3,7 +3,8 @@ Class { #superclass : #TestCase, #instVars : [ 'session', - 'debugger' + 'debugger', + 'oldFastTDD' ], #category : #'NewTools-Debugger-Tests-Presenters' } @@ -82,13 +83,16 @@ StDebuggerTest >> setUp [ session := DebugSession named: 'test session' on: process - startedAt: context + startedAt: context. + oldFastTDD := self debuggerClass fastTDD. + self debuggerClass fastTDD: true ] { #category : #running } StDebuggerTest >> tearDown [ session clear. + self debuggerClass fastTDD: oldFastTDD. super tearDown ] @@ -200,6 +204,12 @@ StDebuggerTest >> testExtendedToolsPragma [ self assert: StDebugger extendedToolsPragma equals: #debuggerExtensionOrder:showByDefault: ] +{ #category : #'tests - initialization' } +StDebuggerTest >> testFastTDD [ + self debuggerClass fastTDD: nil. + self deny: self debuggerClass fastTDD +] + { #category : #'tests - receiver inspector' } StDebuggerTest >> testInspectorHeaderLabel [ | dbg displayedLabel | @@ -306,6 +316,22 @@ StDebuggerTest >> testRegisterExtensionTool [ self assertCollection: dbg extensionTools includesAll: { object } ] +{ #category : #'tests - actions' } +StDebuggerTest >> testRequestClassFrom [ + + self + assert: (self debugger requestClassFrom: self class) + identicalTo: self class +] + +{ #category : #'tests - actions' } +StDebuggerTest >> testRequestProtocolIn [ + + self + assert: (self debugger requestProtocolIn: self class) + equals: Protocol unclassified +] + { #category : #'tests - raw inspection' } StDebuggerTest >> testRestoreReceiverRawInspectionSelection [ ] diff --git a/src/NewTools-Debugger/StDebugger.class.st b/src/NewTools-Debugger/StDebugger.class.st index 13b30ec6d..43062b4c3 100644 --- a/src/NewTools-Debugger/StDebugger.class.st +++ b/src/NewTools-Debugger/StDebugger.class.st @@ -91,6 +91,7 @@ Class { 'DefaultDebugger', 'ErrorRecursion', 'ExtensionToolsSettings', + 'FastTDD', 'UsingSpecSelector' ], #category : #'NewTools-Debugger-View' @@ -315,6 +316,29 @@ StDebugger class >> extensionToolsSettings [ ifNil: [ ExtensionToolsSettings := Dictionary new ] ] +{ #category : #settings } +StDebugger class >> fastTDD [ + ^FastTDD ifNil:[FastTDD := false] +] + +{ #category : #settings } +StDebugger class >> fastTDD: aBoolean [ + + FastTDD := aBoolean +] + +{ #category : #settings } +StDebugger class >> fastTDDSettingsOn: aBuilder [ + + (aBuilder setting: #fastTDD) + label: 'Fast TDD'; + target: self; + default: false; + parent: #debugging; + description: 'Create classes and methods directly in the receiver''s class +without requesting information from the user' +] + { #category : #opening } StDebugger class >> handlesContext: aContext [ ^self availableAutomatically @@ -551,15 +575,14 @@ StDebugger >> createMissingClass [ { #category : #actions } StDebugger >> createMissingMethod [ + | msg chosenClass | self flag: #DBG_MISSINGTEST. msg := self interruptedContext tempAt: 1. - "chosenClass := (self - requestSuperclassOf: self interruptedContext receiver class - to: ProtoObject - toImplement: msg selector - ifCancel: [ ^ self ]) value." - chosenClass := self interruptedContext receiver class. + chosenClass := self requestClassFrom: + self interruptedContext receiver class. + chosenClass ifNil: [ ^ self ]. + self createMissingMethodFor: msg in: chosenClass ] @@ -568,7 +591,7 @@ StDebugger >> createMissingMethodFor: aMessage in: aClass [ self flag: #DBG_MISSINGTEST. self debuggerActionModel implement: aMessage - classified: Protocol unclassified + classified: (self requestProtocolIn: aClass) inClass: aClass forContext: self interruptedContext. self selectTopContext @@ -576,18 +599,16 @@ StDebugger >> createMissingMethodFor: aMessage in: aClass [ { #category : #actions } StDebugger >> createSubclassResponsibility [ + | senderContext msg msgCategory chosenClass | senderContext := self interruptedContext sender. msg := Message - selector: senderContext selector - arguments: senderContext arguments. - msgCategory := senderContext methodClass organization - categoryOfElement: msg selector. - chosenClass := (self - requestSuperclassOf: senderContext receiver class - to: senderContext methodClass - toImplement: senderContext selector - ifCancel: [ ^ self ]) value. + selector: senderContext selector + arguments: senderContext arguments. + msgCategory := senderContext methodClass organization + categoryOfElement: msg selector. + chosenClass := self requestClassFrom: senderContext receiver class. + chosenClass ifNil: [ ^ self ]. self debuggerActionModel implement: msg classified: msgCategory @@ -909,19 +930,45 @@ StDebugger >> removeSessionHolderSubscriptions [ ] { #category : #'ui requests' } -StDebugger >> requestSuperclassOf: aClass to: aSuperclass toImplement: aSelector ifCancel: cancelBlock [ +StDebugger >> requestClassFrom: aClass [ + + self class fastTDD ifTrue: [ ^ aClass ]. + ^ self requestSuperclassOf: aClass to: ProtoObject +] + +{ #category : #'ui requests' } +StDebugger >> requestProtocolIn: aClass [ + + | entryCompletion applicants | + self class fastTDD ifTrue: [ ^ Protocol unclassified ]. + applicants := AbstractTool protocolSuggestionsFor: aClass. + entryCompletion := EntryCompletion new + dataSourceBlock: [ :currText | applicants ]; + filterBlock: [ :currApplicant :currText | + currText size > 3 and: [ + currApplicant asLowercase includesSubstring: + currText asString asLowercase ] ]. + ^ (UIManager default + request: 'Start typing for suggestions (3 characters minimum)' + initialAnswer: Protocol unclassified + title: 'Choose a protocol' + entryCompletion: entryCompletion) ifEmpty: [ + Protocol unclassified ] +] + +{ #category : #'ui requests' } +StDebugger >> requestSuperclassOf: aClass to: aSuperclass [ + | classes | classes := OrderedCollection with: aClass. classes addAll: (aClass allSuperclassesIncluding: aSuperclass). - classes - addAll: (aClass traits sort: [ :t1 :t2 | t1 asString < t2 asString ]). - classes size = 1 - ifTrue: [ ^ classes first ]. - ^ (UIManager default - chooseFrom: (classes collect: [ :c | c name ]) - values: classes - title: 'Define #' , aSelector , ' in which class?') - ifNil: [ cancelBlock ] + classes addAll: + (aClass traits sort: [ :t1 :t2 | t1 asString < t2 asString ]). + classes size = 1 ifTrue: [ ^ classes first ]. + ^ UIManager default + chooseFrom: (classes collect: [ :c | c name ]) + values: classes + title: 'Define selector in:' ] { #category : #actions }