Breakpoints: added experimental breakpoint notifications (trivial ded…

…icated observer) and refactorised a bit.

Modified the standard Break meta-behavior so that it includes more contextual elements (added metalink parameters).

src/Reflectivity-Tools-Tests/BreakpointObserverTest.class.st

@@ -0,0 +1,98 @@
+Class {
+	#name : #BreakpointObserverTest,
+	#superclass : #TestCase,
+	#instVars : [
+		'oldObservers',
+		'breakpoint',
+		'cls',
+		'previousBreakpoints',
+		'observer'
+	],
+	#category : #'Reflectivity-Tools-Tests'
+}
+
+{ #category : #helpers }
+BreakpointObserverTest >> newDummyClass [
+	^ Object
+		subclass: #DummyClassForBreakpoint
+		instanceVariableNames: ''
+		classVariableNames: ''
+		package: 'DummyPackage'
+]
+
+{ #category : #running }
+BreakpointObserverTest >> setUp [
+	"Hooks that subclasses may override to define the fixture of test."
+
+	super setUp.
+	previousBreakpoints := Breakpoint all copy.
+	oldObservers := Breakpoint observers copy.
+	Breakpoint observers removeAll.
+	cls := self newDummyClass.
+	breakpoint := Breakpoint new.
+	cls compile: 'dummy ^42'.
+	breakpoint
+		node: (cls >> #dummy) ast;
+		once.
+	observer := DummyBreakpointObserver new
+]
+
+{ #category : #running }
+BreakpointObserverTest >> tearDown [
+	|pkg|
+	Breakpoint observers removeAll.
+	Breakpoint observers addAll: oldObservers.
+	cls ifNotNil: [ cls isObsolete ifFalse: [ cls removeFromSystem ] ].
+	pkg := 'DummyPackage' asPackageIfAbsent: [ ]. 
+	pkg ifNotNil: [ pkg removeFromSystem ].
+	Breakpoint removeAll.
+	Breakpoint all addAll: previousBreakpoints.
+	super tearDown
+]
+
+{ #category : #tests }
+BreakpointObserverTest >> testNotifyBreakpointAdded [
+	Breakpoint registerObserver: observer.
+	breakpoint install.
+	self assert: observer tag class equals: BreakpointAddedNotification.
+	self assert: observer tag breakpoint identicalTo: breakpoint.
+	self assertCollection: observer tag nodes equals: { (cls >> #dummy) ast } asSet
+]
+
+{ #category : #tests }
+BreakpointObserverTest >> testNotifyBreakpointHit [
+	Breakpoint registerObserver: observer.
+	breakpoint install.
+	self should: [cls new dummy] raise: Break.	
+	self assert: observer tag class equals: BreakpointHitNotification.
+	self assert: observer tag breakpoint identicalTo: breakpoint.
+	self assert: observer tag valueOrNil isNil
+
+]
+
+{ #category : #tests }
+BreakpointObserverTest >> testNotifyBreakpointRemoved [	
+	breakpoint install.
+	Breakpoint registerObserver: observer.
+	breakpoint remove.
+	self assert: observer tag class equals: BreakpointRemovedNotification.
+	self assert: observer tag breakpoint identicalTo: breakpoint.
+	self assertCollection: observer tag nodes equals: { (cls >> #dummy) ast } asSet
+]
+
+{ #category : #tests }
+BreakpointObserverTest >> testRegisterObserver [
+	|obs|
+	obs := DummyBreakpointObserver new.
+	Breakpoint registerObserver: obs.
+	self assertCollection: Breakpoint observers includesAll: {obs}
+]
+
+{ #category : #tests }
+BreakpointObserverTest >> testUnregisterObserver [
+	|obs|
+	obs := DummyBreakpointObserver new.
+	Breakpoint registerObserver: obs.
+	Breakpoint unregisterObserver: obs.
+	self assertEmpty: Breakpoint observers
+]

src/Reflectivity-Tools-Tests/BreakpointTest.class.st

@@ -38,6 +38,19 @@ BreakpointTest >> tearDown [
 	super tearDown.
 ]
 
+{ #category : #tests }
+BreakpointTest >> testAddRemoveBreakpoint [
+	|bp|
+	cls compile: 'dummy ^42'.
+	self assertEmpty: Breakpoint all.
+	bp := Breakpoint new.
+	bp	node: (cls >> #dummy) ast.
+	Breakpoint addBreakpoint: bp.
+	self assertCollection: Breakpoint all includesAll: {bp}.
+	Breakpoint removeBreakpoint: bp.
+	self assertEmpty: Breakpoint all.
+]
+
 { #category : #tests }
 BreakpointTest >> testModifyMethodWithBreakpoint [
 	cls compile: 'dummy ^42'.

src/Reflectivity-Tools-Tests/DummyBreakpointObserver.class.st

@@ -0,0 +1,23 @@
+"
+I am a dummy breakpoint observer.
+I am also an example observer.
+I receives update notifications from the Breakpoint class whenever a breakpoint is added, modified or removed.
+"
+Class {
+	#name : #DummyBreakpointObserver,
+	#superclass : #Object,
+	#instVars : [
+		'tag'
+	],
+	#category : #'Reflectivity-Tools-Tests'
+}
+
+{ #category : #accessing }
+DummyBreakpointObserver >> tag [
+	^ tag
+]
+
+{ #category : #updating }
+DummyBreakpointObserver >> update: anAspect [
+	tag := anAspect 
+]

src/Reflectivity/Break.class.st

@@ -14,3 +14,10 @@ Break class >> break [
 	<debuggerCompleteToSender>
 	self signal
 ]
+
+{ #category : #break }
+Break class >> break: aBreakpoint inContext: aContext node: node [
+	<debuggerCompleteToSender>
+	aBreakpoint class notifyBreakpointHit: aBreakpoint inContext: aContext node: node.	
+	self break
+]

src/Reflectivity/Breakpoint.class.st

@@ -24,11 +24,18 @@ Class {
 		'options'
 	],
 	#classVars : [
-		'AllBreakpoints'
+		'AllBreakpoints',
+		'Observers'
 	],
 	#category : #'Reflectivity-Breakpoints'
 }
 
+{ #category : #all }
+Breakpoint class >> addBreakpoint: aBreakpoint [
+	self all add: aBreakpoint.
+	self notifyBreakpointAdded: aBreakpoint
+]
+
 { #category : #all }
 Breakpoint class >> all [ 
 	^ AllBreakpoints ifNil: [ AllBreakpoints := OrderedCollection new ]
@@ -68,7 +75,7 @@ Breakpoint class >> handleClassRemoved: anAnnouncement [
 	self all copy do: [ :breakpoint |
 		breakpoint link methods
 			detect: [ :m | m methodClass = anAnnouncement classRemoved ]
-			ifFound: [ self all remove: breakpoint ] ]
+			ifFound: [ self removeBreakpoint: breakpoint ] ]
 ]
 
 { #category : #'system announcements' }
@@ -98,6 +105,44 @@ Breakpoint class >> isInstalledIn: aMethod [
 	^ false
 ]
 
+{ #category : #'observers - experimental' }
+Breakpoint class >> notifyBreakpointAdded: aBreakpoint [
+	| notification |
+	notification := BreakpointAddedNotification
+		on: aBreakpoint
+		nodes: aBreakpoint link nodes.
+	self notifyObservers: notification
+]
+
+{ #category : #'observers - experimental' }
+Breakpoint class >> notifyBreakpointHit: aBreakpoint inContext: aContext node: node [
+	| notification |
+	notification := BreakpointHitNotification
+		on: aBreakpoint
+		nodes: {node}.
+	self notifyObservers: notification
+]
+
+{ #category : #'observers - experimental' }
+Breakpoint class >> notifyBreakpointRemoved: aBreakpoint fromNodes: nodes [
+	| notification |
+	notification := BreakpointRemovedNotification
+		on: aBreakpoint
+		nodes: nodes.
+	self notifyObservers: notification
+]
+
+{ #category : #'observers - experimental' }
+Breakpoint class >> notifyObservers: aNotification [
+	self observers
+		do: [ :observer | observer ifNotNil: [ observer update: aNotification ] ]
+]
+
+{ #category : #'observers - experimental' }
+Breakpoint class >> observers [
+	^Observers ifNil:[Observers := WeakOrderedCollection new]
+]
+
 { #category : #'class initialization' }
 Breakpoint class >> registerInsterestToSystemAnnouncement [
 	<systemEventRegistration>
@@ -108,12 +153,25 @@ Breakpoint class >> registerInsterestToSystemAnnouncement [
 	SystemAnnouncer uniqueInstance weak when: ClassRemoved send: #handleClassRemoved: to: self
 ]
 
+{ #category : #'observers - experimental' }
+Breakpoint class >> registerObserver: anObject [
+	self observers addIfNotPresent: anObject
+]
+
 { #category : #cleanup }
 Breakpoint class >> removeAll [ 
 	<script>
 	self all copy do: #remove
 ]
 
+{ #category : #all }
+Breakpoint class >> removeBreakpoint: aBreakpoint [
+	| nodes |
+	nodes := aBreakpoint link nodes copy.
+	self all remove: aBreakpoint.
+	self notifyBreakpointRemoved: aBreakpoint fromNodes: nodes
+]
+
 { #category : #cleanup }
 Breakpoint class >> removeFrom: aNode [
 	| links breakpointsToRemove |
@@ -127,7 +185,12 @@ Breakpoint class >> removeFromMethod: aMethod [
 	self all copy do: [ :breakpoint |
 		breakpoint link methods
 			detect: [ :m | m == aMethod ]
-			ifFound: [ self all remove: breakpoint ] ]
+			ifFound: [ self removeBreakpoint: breakpoint  ] ]
+]
+
+{ #category : #'observers - experimental' }
+Breakpoint class >> unregisterObserver: anObject [
+	self observers remove: anObject
 ]
 
 { #category : #api }
@@ -139,11 +202,16 @@ Breakpoint >> always [
 
 { #category : #links }
 Breakpoint >> breakLink [
- 	"for now it should just halt in base level"
+	"for now it should just halt in base level"
+
 	^ MetaLink new
 		metaObject: Break;
-		selector: #break;
-		options: options
+		selector: #break:inContext:node:;
+		options: options;
+		arguments:
+			{(RFLiteralVariableNode value: self).
+			#context.
+			#node}
 ]
 
 { #category : #links }
@@ -169,7 +237,7 @@ Breakpoint >> initialize [
 
 { #category : #install }
 Breakpoint >> install [
-	self class all add: self.
+	self class addBreakpoint: self.
 	self node link: self link
 ]
 
@@ -216,6 +284,6 @@ Breakpoint >> options: anArray [
 
 { #category : #install }
 Breakpoint >> remove [
-	self class all remove: self.
+	self class removeBreakpoint: self.
 	link uninstall
 ]

src/Reflectivity/BreakpointActivationNotification.class.st

@@ -0,0 +1,27 @@
+"
+A trivial breakpoint activation notification. 
+"
+Class {
+	#name : #BreakpointActivationNotification,
+	#superclass : #BreakpointNotification,
+	#instVars : [
+		'activated'
+	],
+	#category : #'Reflectivity-Breakpoints'
+}
+
+{ #category : #accessing }
+BreakpointActivationNotification >> activated [
+	^ activated
+]
+
+{ #category : #accessing }
+BreakpointActivationNotification >> activated: anObject [
+	activated := anObject
+]
+
+{ #category : #initialize }
+BreakpointActivationNotification >> initialize [ 	
+	super initialize.
+	activated := true
+]

src/Reflectivity/BreakpointAddedNotification.class.st

@@ -0,0 +1,8 @@
+"
+A trivial breakpoint added notification. 
+"
+Class {
+	#name : #BreakpointAddedNotification,
+	#superclass : #BreakpointNotification,
+	#category : #'Reflectivity-Breakpoints'
+}

src/Reflectivity/BreakpointHitNotification.class.st

@@ -0,0 +1,22 @@
+"
+I am a notification sent to Breakpoint observers when a breakpoint is hit.
+I can hold a value from the execution context the breakpoint was hit. 
+"
+Class {
+	#name : #BreakpointHitNotification,
+	#superclass : #BreakpointNotification,
+	#instVars : [
+		'valueOrNil'
+	],
+	#category : #'Reflectivity-Breakpoints'
+}
+
+{ #category : #accessing }
+BreakpointHitNotification >> valueOrNil [
+	^ valueOrNil
+]
+
+{ #category : #accessing }
+BreakpointHitNotification >> valueOrNil: anObject [
+	valueOrNil := anObject
+]