Change breakpoints with debugpoints

Author: Nyan11

src/ExecutableRequirements-Tests/ExReqRepositoryReportTest.class.st

@@ -46,9 +46,8 @@ ExReqRepositoryReportTest >> testCreateTracingPoints [
 	self assert: ExReqTracingPoint all isEmpty.
 	self assert: self report tracingPoints isEmpty.
 	self report createTracingPoints.
-	self assert: ExReqTracingPoint all isEmpty.
+	self assert: ExReqTracingPoint all isNotEmpty.
 	self assert: self report tracingPoints isNotEmpty
-	
 ]
 
 { #category : 'tests' }
@@ -68,6 +67,7 @@ ExReqRepositoryReportTest >> testInstallTracingPoints [
 	self assert: ExReqTracingPoint all isEmpty.
 	self assert: self report tracingPoints isEmpty.
 	self report installTracingPoints.
+	
 	self assert: ExReqTracingPoint all isNotEmpty.
 	self assert: self report tracingPoints isNotEmpty.
 	self report removeTracingPoints.

src/ExecutableRequirements/ExReqPostconditionTracingPoint.class.st

@@ -1,7 +1,8 @@
 Class {
 	#name : 'ExReqTracingPoint',
-	#superclass : 'Breakpoint',
+	#superclass : 'DebugPoint',
 	#instVars : [
+		'isPrecondition',
 		'stepReports'
 	],
 	#classVars : [
@@ -15,47 +16,93 @@ Class {
 { #category : 'accessing' }
 ExReqTracingPoint class >> all [
 
-	^ TracingPoints ifNil: [
-		  TracingPoints := OrderedCollection new ]
+	^ TracingPoints ifNil: [ TracingPoints := Set new ]
 ]
 
-{ #category : 'cleanup' }
-ExReqTracingPoint class >> cleanUp [
-
-	<script>
-	ExReqPreconditionTracingPoint allInstances do: [ :each | 
-		each link uninstall.
-		each remove ].
-	ExReqPostconditionTracingPoint allInstances do: [ :each |
-		each link uninstall.
-		each remove ].
-	self all removeAll.
-	Smalltalk image garbageCollect
+{ #category : 'accessing' }
+ExReqTracingPoint >> bePostcondition [
+
+	isPrecondition := false
 ]
 
 { #category : 'accessing' }
-ExReqTracingPoint class >> removeBreakpoint: aBreakpoint [
+ExReqTracingPoint >> bePrecondition [
+
+	isPrecondition := true
+]
 
-	| nodes |
-	nodes := aBreakpoint link nodes copy.
-	self notifyBreakpointRemoved: aBreakpoint fromNodes: nodes.
-	self all remove: aBreakpoint ifAbsent: [ ].
+{ #category : 'API' }
+ExReqTracingPoint >> hitWithContext: aContext [
+
+	"We do not emit an event for some obscure reason ..."
+	self enabled ifFalse: [ ^ false ].
+	self saveContext: aContext.
+	(self checkBehaviors allSatisfy: [ :behavior | behavior execute ])
+		ifFalse: [ ^ false ].
+	self sideEffectBehaviors do: [ :behavior | behavior execute ].
+	
+	self enabled: false.
+	self verifyStepsConditionWithContext: aContext.
+	self enabled: true.
+	^ true
 ]
 
-{ #category : 'api' }
-ExReqTracingPoint >> breakInContext: aContext node: aNode [
+{ #category : 'API' }
+ExReqTracingPoint >> hitWithContext: aContext value: aValue [
 
-	self isEnabled ifFalse: [ ^ self ].
+	(self hitWithContext: aContext) ifFalse: [ ^ self ].
+	self enabled ifFalse: [ ^ self ].
 	self enabled: false.
 	self verifyStepsConditionWithContext: aContext.
 	self enabled: true
 ]
 
-{ #category : 'initialization' }
+{ #category : 'accessing' }
 ExReqTracingPoint >> initialize [
 
 	super initialize.
-	enabled := true
+	isPrecondition := true.
+]
+
+{ #category : 'accessing' }
+ExReqTracingPoint >> isPrecondition [
+
+	^ isPrecondition
+]
+
+{ #category : 'default values' }
+ExReqTracingPoint >> metaLink [
+
+	^ self isPrecondition
+		ifTrue: [ self preconditionMetaLink ]
+		ifFalse: [ self postconditionMetaLink ]
+]
+
+{ #category : 'accessing' }
+ExReqTracingPoint >> name [
+
+	^ name ifNil: [ #TracingPoint ]
+]
+
+{ #category : 'default values' }
+ExReqTracingPoint >> postconditionMetaLink [
+
+	^ MetaLink new
+		  metaObject: self;
+		  options: #( #+ optionCompileOnLinkInstallation );
+		  selector: #hitWithContext:;
+		  control: #after;
+		  arguments: #( context )
+]
+
+{ #category : 'default values' }
+ExReqTracingPoint >> preconditionMetaLink [
+
+	^ MetaLink new
+		  metaObject: self;
+		  options: #( #+ optionCompileOnLinkInstallation );
+		  selector: #hitWithContext:;
+		  arguments: #( context )
 ]
 
 { #category : 'accessing' }
@@ -65,13 +112,25 @@ ExReqTracingPoint >> stepReports [
 ]
 
 { #category : 'accessing' }
-ExReqTracingPoint >> stepReports: aCollection [
+ExReqTracingPoint >> stepReports: anObject [
+
+	stepReports := anObject
+]
+
+{ #category : 'accessing' }
+ExReqTracingPoint >> type [
 
-	stepReports := aCollection
+	^ #TracingPoint
 ]
 
-{ #category : 'api' }
+{ #category : 'API' }
 ExReqTracingPoint >> verifyStepsConditionWithContext: aContext [
 
-	self shouldBeImplemented
+	self isPrecondition
+		ifTrue: [
+			self stepReports do: [ :stepReport |
+				stepReport verifyStepPreconditionWithContext: aContext ] ]
+		ifFalse: [
+			self stepReports do: [ :stepReport |
+				stepReport verifyStepPostconditionWithContext: aContext ] ]
 ]

src/ExecutableRequirements/ExReqPreconditionTracingPoint.class.st

@@ -16,14 +16,36 @@ ExReqTracingPointContainer >> createTracingPoint [
 
 	| astNode |
 	astNode := self stepReports first step node.
-	preconditionTracingPoint := ExReqPreconditionTracingPoint new
+
+	preconditionTracingPoint := ExReqTracingPoint new
+		                            bePrecondition;
 		                            node: astNode;
+		                            stepReports: self stepReports;
 		                            yourself.
-	postconditionTracingPoint := ExReqPostconditionTracingPoint new
+	postconditionTracingPoint := ExReqTracingPoint new
+		                             bePostcondition;
 		                             node: astNode;
+		                             stepReports: self stepReports;
 		                             yourself.
-	preconditionTracingPoint stepReports: self stepReports.
-	postconditionTracingPoint stepReports: self stepReports.
+
+	self installTracingPoint: preconditionTracingPoint withBehaviors: {  }.
+	self installTracingPoint: postconditionTracingPoint withBehaviors: {  }
+]
+
+{ #category : 'as yet unclassified' }
+ExReqTracingPointContainer >> installTracingPoint: dp withBehaviors: aListOfBehaviorClasses [
+
+	| ml |
+	ml := dp metaLink.
+
+	dp link: ml.
+	dp install.
+	ExReqTracingPoint add: dp.
+
+	"adding behaviors"
+	aListOfBehaviorClasses do: [ :bhc | dp addBehavior: bhc new ].
+
+	^ dp
 ]
 
 { #category : 'initialization' }