Merge

src/NewTools-ChangeSorter/SpChangeSorterPresenter.class.st

@@ -394,8 +394,7 @@ SpChangeSorterPresenter >> initialize [
 SpChangeSorterPresenter >> initializeAnnouncements [
 
 	SystemAnnouncer uniqueInstance weak
-		when: ClassAdded , ClassCommented , ClassRecategorized , ClassModifiedClassDefinition , ClassRemoved , ClassRenamed , MethodAdded , MethodModified
-			, MethodRecategorized , MethodRemoved , ProtocolAnnouncement
+		when: ClassAdded , ClassCommented , ClassRepackaged , ClassModifiedClassDefinition , ClassRemoved , ClassRenamed , MethodAdded , MethodModified , MethodRecategorized , MethodRemoved , ProtocolAnnouncement
 		send: #updateClassesList
 		to: self
 ]

src/NewTools-CodeCritiques/ClassDescription.extension.st

@@ -0,0 +1,8 @@
+Extension { #name : 'ClassDescription' }
+
+{ #category : '*NewTools-CodeCritiques' }
+ClassDescription >> criticNameOn: aStream [
+	"This behavior may be folded later by changing the name of this method or using another one."
+
+	aStream << self name << ' (' << self package name << ')'
+]

src/NewTools-CodeCritiques/CompiledMethod.extension.st

@@ -0,0 +1,14 @@
+Extension { #name : 'CompiledMethod' }
+
+{ #category : '*NewTools-CodeCritiques' }
+CompiledMethod >> criticNameOn: aStream [
+	"This behavior may be folded later by changing the name of this method or using another one."
+
+	aStream
+		<< self methodClass name
+		<< '>>#'
+		<< self selector
+		<< ' ('
+		<< self methodClass package name
+		<< ')'
+]

src/NewTools-CodeCritiques/RPackage.extension.st

@@ -0,0 +1,8 @@
+Extension { #name : 'RPackage' }
+
+{ #category : '*NewTools-CodeCritiques' }
+RPackage >> criticNameOn: aStream [
+	"This behavior may be folded later by changing the name of this method or using another one."
+
+	aStream << self packageName
+]

src/NewTools-CodeCritiques/StCritiqueBrowserPresenter.class.st

@@ -143,32 +143,28 @@ StCritiqueBrowserPresenter >> allRules [
 
 { #category : 'private' }
 StCritiqueBrowserPresenter >> applyRules [
+
 	| packageCount nbPackage process rules |
 	rules := self allRules.
 	nbPackage := rbEnvironment packages size.
 	packageCount := 0.
 	self updateTree.
-	process := [ rbEnvironment packages
-		do: [ :package | 
-			| windowTitle |
-			packageCount := packageCount + 1.
-			windowTitle := String
-				streamContents: [ :s | 
-					s << 'run rules on ' << package packageName << ' ('
-						<< packageCount asString << '/' << nbPackage asString << ')' ].
-			self setTitle: windowTitle.
-			checker
-				runRules: rules
-				onPackage: package
-				withoutTestCase: removeTestCase ].
-	checker rule: rules.
-	self setTitle: self defaultTitle.
-	cache packages: rbEnvironment.
-	cache initCache.
-	self rules: (self allRules select: [ :r | self hasBrokenRules: r]).
-    self rulesModel refresh.
-    self rebuildLayout.
-	self updateTree. ] newProcess.
+	process := [
+	           rbEnvironment packages do: [ :package |
+		           | windowTitle |
+		           packageCount := packageCount + 1.
+		           windowTitle := String streamContents: [ :s |
+			                          s << 'run rules on ' << package name << ' (' << packageCount asString << '/' << nbPackage asString << ')' ].
+		           self setTitle: windowTitle.
+		           checker runRules: rules onPackage: package withoutTestCase: removeTestCase ].
+	           checker rule: rules.
+	           self setTitle: self defaultTitle.
+	           cache packages: rbEnvironment.
+	           cache initCache.
+	           self rules: (self allRules select: [ :r | self hasBrokenRules: r ]).
+	           self rulesModel refresh.
+	           self rebuildLayout.
+	           self updateTree ] newProcess.
 	process name: 'SmallLint'.
 	process resume
 ]

src/NewTools-Debugger-Tests/StDebuggerActionModelTest.class.st

@@ -113,7 +113,7 @@ StDebuggerActionModelTest >> methodWithBlockContext [
 { #category : 'helper' }
 StDebuggerActionModelTest >> methodWithDeadBlockContext [
 
-	^ [ (1+1 ) printString ]
+	^ [ (1 + 1) printString ]
 ]
 
 { #category : 'helper' }
@@ -127,14 +127,13 @@ StDebuggerActionModelTest >> newSessionWithBlockContext [
 	| process method |
 	method := self class >> #methodWithBlockContext.
 	methodWithBlockContextOriginalSource := method sourceCode.
-	process := [ method valueWithReceiver: self arguments: #(  ) ]
-		           newProcess.
-	self
-		setSessionAndDebuggerModelForMethod: method
-		inContext: process suspendedContext.
+	process := [ method valueWithReceiver: self arguments: #(  ) ] newProcess.
+	self setSessionAndDebuggerModelForMethod: method inContext: process suspendedContext.
 
-	4 timesRepeat: [
-		debugActionModel stepInto: debugActionModel topContext ]
+	[ debugActionModel topContext closure isNil ] whileTrue: [
+		debugActionModel stepInto: debugActionModel topContext ].
+	"Step on (1 + 1) message"
+	debugActionModel stepInto: debugActionModel topContext
 ]
 
 { #category : 'helper' }
@@ -807,6 +806,19 @@ StDebuggerActionModelTest >> testIsInterruptedContextSubclassResponsibilityExcep
 	self assert: debugActionModel isInterruptedContextSubclassResponsibilityException
 ]
 
+{ #category : 'tests - predicates' }
+StDebuggerActionModelTest >> testIsInterruptedContextSubclassResponsibilityExceptionWithSteps [
+
+	| dummyActionModel |
+	dummyActionModel := StTestDebuggerProvider new
+		                    debuggerWithMissingSubclassResponsibilityContextWithSteps
+		                    debuggerActionModel.
+	self changeSession: dummyActionModel session.
+	dummyActionModel clear.
+	self assert:
+		debugActionModel isInterruptedContextSubclassResponsibilityException
+]
+
 { #category : 'tests - actions' }
 StDebuggerActionModelTest >> testPeelToFirstLike [
 

src/NewTools-Debugger-Tests/StDebuggerCommandTest.class.st

@@ -241,6 +241,47 @@ StDebuggerCommandTest >> testCommandsInMissingSubclassResponsibilityContext [
 	debugger debuggerActionModel clear
 ]
 
+{ #category : 'tests' }
+StDebuggerCommandTest >> testCommandsInMissingSubclassResponsibilityContextWithSteps [
+
+	| debugger |
+	[
+	debugger := debuggerProvider
+		            debuggerWithMissingSubclassResponsibilityContextWithSteps.
+	self assert: debugger debuggerActionModel
+			isInterruptedContextSubclassResponsibilityException.
+
+	"Executable commands relative to context"
+	self assert:
+		(StDefineSubclassResponsabilityCommand forContext: debugger)
+			canBeExecuted.
+	self assert:
+		(StDefineMissingEntityCommand forContext: debugger) canBeExecuted.
+	self assert: (StRestartCommand forContext: debugger) canBeExecuted.
+	self assert:
+		(StReturnValueCommand forContext: debugger) canBeExecuted.
+
+	"Non-executable commands relative to context"
+	self deny: (StStepIntoCommand forContext: debugger) canBeExecuted.
+	self deny: (StStepOverCommand forContext: debugger) canBeExecuted.
+	self deny: (StStepThroughCommand forContext: debugger) canBeExecuted.
+	self deny:
+		(StRunToSelectionCommand forContext: debugger) canBeExecuted.
+	self deny: (StProceedCommand forContext: debugger) canBeExecuted.
+	self deny: (StDefineClassCommand forContext: debugger) canBeExecuted.
+	self deny: (StDefineMethodCommand forContext: debugger) canBeExecuted.
+
+	"Executable commands, whatever the context"
+	self assert:
+		(StCopyStackToClipboardCommand forContext: debugger) canBeExecuted.
+	self assert:
+		(StFileOutMethodCommand forContext: debugger) canBeExecuted.
+	self assert:
+		(StPeelToFirstCommand forContext: debugger) canBeExecuted.
+	self assert: (StWhereIsCommand forContext: debugger) canBeExecuted ]
+		ensure: [ debugger ifNotNil: [ debugger clear ] ]
+]
+
 { #category : 'tests' }
 StDebuggerCommandTest >> testCommandsInRunnableContext [
 

src/NewTools-Debugger-Tests/StTestDebuggerProvider.class.st

@@ -94,6 +94,31 @@ StTestDebuggerProvider >> debuggerWithMissingSubclassResponsibilityContext [
 			^ self newDebugger ]
 ]
 
+{ #category : 'helpers' }
+StTestDebuggerProvider >> debuggerWithMissingSubclassResponsibilityContextWithSteps [
+
+	| ctx dbg |
+	ctx := [
+	       StDummyDebuggerPresenter new
+		       unimplementedSubclassResponsibility ] asContext.
+
+	self
+		sessionFor: ctx
+		exception: (OupsNullException fromSignallerContext: ctx).
+	dbg := self newDebugger.
+	dbg
+		application: dbg class currentApplication;
+		initialize.
+	"We reach the subclass responsability"
+	dbg
+		stepOver;
+		stepOver;
+		stepInto;
+		stepOver.
+
+	^ dbg
+]
+
 { #category : 'helpers' }
 StTestDebuggerProvider >> debuggerWithObjectHalting [
 	[ StDebuggerObjectForTests new haltingMethod ]

src/NewTools-Debugger/StDebugger.class.st

@@ -448,11 +448,13 @@ StDebugger >> createMissingMethodFor: aMessage in: aClass [
 StDebugger >> createSubclassResponsibility [
 
 	| senderContext msg chosenClass |
-	senderContext := self interruptedContext sender.
+	senderContext := self signalingSubclassResponsabilityContext.
 	msg := Message
 		       selector: senderContext selector
 		       arguments: senderContext arguments.
-	chosenClass := self requestClassFrom: senderContext receiver class to: senderContext methodClass.
+	chosenClass := self
+		               requestClassFrom: senderContext receiver class
+		               to: senderContext methodClass.
 	chosenClass ifNil: [ ^ self ].
 	self debuggerActionModel
 		implement: msg
@@ -1126,6 +1128,16 @@ StDebugger >> setStackAndCodeContainer [
 		                         ifFalse: [ self stackAndCodeLayout ]
 ]
 
+{ #category : 'accessing - context' }
+StDebugger >> signalingSubclassResponsabilityContext [
+
+	| signalingContext |
+	signalingContext := self interruptedContext.
+	[ signalingContext selector = #subclassResponsibility ] whileFalse: [
+		signalingContext := signalingContext sender ].
+	^ signalingContext sender
+]
+
 { #category : 'stack' }
 StDebugger >> stack [
 	^ self debuggerActionModel stack 

src/NewTools-Debugger/StDebuggerActionModel.class.st

@@ -338,15 +338,18 @@ StDebuggerActionModel >> recompileMethodTo: aString inContext: aContext notifyin
 
 	| methodContext homePC |
 	aContext ifNil: [ ^ self ].
+	"Get the home before to recompile the method, we can lost it (for clean blocks)"
+	methodContext := aContext home.
+
 	self session
 		recompileMethodTo: aString
 		inContext: aContext
 		notifying: aNotifyer.
 
-	methodContext := aContext home.
 	homePC := methodContext isDead
 		ifTrue: [ methodContext endPC ]
 		ifFalse: [ methodContext pc ].
+
 	previousASTScope := (methodContext compiledCode sourceNodeForPC:
 		                     homePC) scope
 ]

src/NewTools-Inspector-Extensions/Pragma.extension.st

@@ -3,9 +3,14 @@ Extension { #name : 'Pragma' }
 { #category : '*NewTools-Inspector-Extensions' }
 Pragma >> inspectionSourceCodeMethod [
 	<inspectorPresentationOrder: 30 title: 'Method'>
-
+	| interval |
+
+	interval := self sourceNode sourceInterval.
 	^ SpCodePresenter new 
-		beForMethod: self method;
-		text: self method sourceCode;
+		beForMethod: method ast;
+		text: method sourceCode;
+		addTextSegmentDecoration: (SpTextPresenterDecorator forHighlight
+			interval: (interval first to: interval last + 1);
+			yourself);
 		yourself
 ]

src/NewTools-MethodBrowsers/MessageListPresenter.class.st

@@ -302,8 +302,7 @@ MessageListPresenter >> packageOf: anItem [
 
 { #category : 'private' }
 MessageListPresenter >> protocolNameForItem: anItem [
-
-	^ anItem protocolName ifNil: [ '' ]
+	^ anItem category ifNil: [ '' ]
 ]
 
 { #category : 'actions' }

src/NewTools-RewriterTools/StRewriterRuleEditorPresenter.class.st

@@ -45,7 +45,7 @@ StRewriterRuleEditorPresenter class >> icon [
 
 { #category : 'accessing' }
 StRewriterRuleEditorPresenter class >> iconName [
-	^ #workspaceIcon
+	^ #workspace
 ]
 
 { #category : 'world menu' }

src/NewTools-Spotter-Extensions/SystemWindow.extension.st

@@ -5,7 +5,7 @@ SystemWindow >> stActDefault [
 
 	^ self isTopWindow
 		ifTrue: [ self comeToFront ] "rise above non-window morphs"
-		ifFalse:[ self activate ]
+		ifFalse:[ self restoreAndActivate ]
 ]
 
 { #category : '*NewTools-Spotter-Extensions' }