Merge pull request #125 from OpenSmock/Issue_0113

Issue 0113
OpenSmock · Dec 17, 2023 · 3e31999 · 3e31999
2 parents fa6c4f9 + 02922ed
commit 3e31999
Show file tree

Hide file tree

Showing 13 changed files with 226 additions and 81 deletions.
diff --git a/src/Pyramid-Bloc/PyramidMainExtension.class.st b/src/Pyramid-Bloc/PyramidMainExtension.class.st
@@ -78,7 +78,8 @@ PyramidMainExtension >> initialize [
 						                yourself);
 				               add: (PyramidPointInputPresenter new
 						                value: self defaultExtent;
-						                whenValueChangedDo: [ :point | self extent: point ];
+						                whenValueChangedDo: [ :point |
+							                self extent: point ];
 						                yourself);
 				               yourself);
 		              yourself.
@@ -95,22 +96,26 @@ PyramidMainExtension >> initialize [
 
 
 	containerElement := BlElement new
+		                    id: #MainExtension_containerElement;
 		                    constraintsDo: [ :c |
 			                    c vertical matchParent.
 			                    c horizontal matchParent ];
 		                    clipChildren: false;
 		                    zIndex: 0;
 		                    yourself.
 	borderElement := BlElement new
+		                 id: #MainExtension_borderElement;
 		                 border: self defaultBorder;
 		                 outskirts: BlOutskirts outside;
 		                 constraintsDo: [ :c |
 			                 c vertical matchParent.
 			                 c horizontal matchParent ];
 		                 clipChildren: false;
 		                 zIndex: 1;
+								preventMeAndChildrenMouseEvents;
 		                 yourself.
 	sizeElement := BlElement new
+		               id: #MainExtension_sizeElement;
 		               size: self defaultExtent;
 		               clipChildren: false;
 		               addChildren: {

diff --git a/src/Pyramid-Bloc/PyramidMenuExtension.class.st b/src/Pyramid-Bloc/PyramidMenuExtension.class.st
@@ -30,11 +30,11 @@ PyramidMenuExtension >> installOn: aBuilder [
 
 	self builder: aBuilder.
 
-	self elementAtDisplay background: Color gray.
+	self elementAtDisplays background: Color gray.
 
-	self elementAtEvents
-		when: BlSecondaryMouseUpEvent
-		do: [ :evt | self showMenuAt: evt ]
+	self elementAtEvents addEventHandler: (BlEventHandler
+			 on: BlSecondaryMouseUpEvent
+			 do: [ :evt | self showMenuAt: evt ])
 ]
 
 { #category : #accessing }
@@ -73,9 +73,9 @@ PyramidMenuExtension >> showMenuAt: anEvent [
 		chooseColorSubMenu addItem: [ :item |
 			item
 				name: color printString;
-				action: [ self elementAtDisplay background: color ];
+				action: [ self elementAtDisplays background: color ];
 				icon: [
-					self elementAtDisplay background paint color = color
+					self elementAtDisplays background paint color = color
 						ifTrue: [ self iconNamed: #testGreen ]
 						ifFalse: [ self iconNamed: #testNotRun ] ] ] ].
 

diff --git a/src/Pyramid-Bloc/PyramidMouseTransformExtension.class.st b/src/Pyramid-Bloc/PyramidMouseTransformExtension.class.st
@@ -22,19 +22,23 @@ PyramidMouseTransformExtension >> installOn: aBuilder [
 
 	self builder: aBuilder.
 
-	self elementAtEvents when: BlMiddleMouseDownEvent do: [ :evt |
-		self origin: self currentTransformTranslation - evt position.
-		self isDragging: true ].
-
-	self elementAtEvents when: BlMouseMoveEvent do: [ :evt |
-		evt middleButtonPressed ifFalse: [ self isDragging: false ].
-		self isDragging ifTrue: [
-			self elementAtTransforms transformDo: [ :t |
-				t translateBy: evt position + self origin ].
-			self builder signalTransformationChanged ] ].
-	self elementAtEvents
-		when: BlMiddleMouseUpEvent
-		do: [ :evt | self isDragging: false ]
+	self elementAtEvents addEventHandler: (BlEventHandler
+			 on: BlMiddleMouseDownEvent
+			 do: [ :evt |
+				 self origin: self currentTransformTranslation - evt position.
+				 self isDragging: true ]).
+
+	self elementAtEvents addEventHandler: (BlEventHandler
+			 on: BlMouseMoveEvent
+			 do: [ :evt |
+				 evt middleButtonPressed ifFalse: [ self isDragging: false ].
+				 self isDragging ifTrue: [
+					 self elementAtTransforms transformDo: [ :t |
+						 t translateBy: evt position + self origin ].
+					 self builder signalTransformationChanged ] ]).
+	self elementAtEvents addEventHandler: (BlEventHandler
+			 on: BlMiddleMouseUpEvent
+			 do: [ :evt | self isDragging: false ])
 ]
 
 { #category : #accessing }

diff --git a/src/Pyramid-Bloc/PyramidPluginTestMode.class.st b/src/Pyramid-Bloc/PyramidPluginTestMode.class.st
@@ -0,0 +1,113 @@
+Class {
+	#name : #PyramidPluginTestMode,
+	#superclass : #Object,
+	#traits : 'TPyramidPlugin + TPyramidEditorExtension',
+	#classTraits : 'TPyramidPlugin classTrait + TPyramidEditorExtension classTrait',
+	#instVars : [
+		'button',
+		'spacePlugin',
+		'isTestOnGoing',
+		'builder'
+	],
+	#category : #'Pyramid-Bloc-plugin-testmode'
+}
+
+{ #category : #adding }
+PyramidPluginTestMode >> addPanelsOn: aPyramidSimpleWindow [
+
+	aPyramidSimpleWindow
+		at: #topRight
+		addItem: [ :builder |
+		builder makeButtonWithIcon: self button order: 0 ].
+]
+
+{ #category : #'as yet unclassified' }
+PyramidPluginTestMode >> builder [
+
+	^ builder
+]
+
+{ #category : #actions }
+PyramidPluginTestMode >> button [ 
+
+	^ button
+]
+
+{ #category : #connecting }
+PyramidPluginTestMode >> connectOn: aPyramidEditor [
+
+	spacePlugin := aPyramidEditor plugins
+		               detect: [ :p | p isKindOf: PyramidSpacePlugin ]
+		               ifNone: [  ].
+
+	spacePlugin ifNotNil: [ 	builder := spacePlugin builder ]
+
+]
+
+{ #category : #actions }
+PyramidPluginTestMode >> initialize [
+
+	isTestOnGoing := false.
+	button := SpButtonPresenter new
+		          icon: self startTestIcon;
+		          help: 'Switch between test/edit mode.';
+		          action: [ self switchToTestMode ];
+		          yourself
+]
+
+{ #category : #accessing }
+PyramidPluginTestMode >> isTestOnGoing [
+	^ isTestOnGoing
+]
+
+{ #category : #accessing }
+PyramidPluginTestMode >> isTestOnGoing: aBoolean [
+
+	isTestOnGoing := aBoolean
+]
+
+{ #category : #'as yet unclassified' }
+PyramidPluginTestMode >> startTestIcon [
+
+	^ self iconNamed: #smallDoIt
+]
+
+{ #category : #'as yet unclassified' }
+PyramidPluginTestMode >> stopTestIcon [
+
+	^ self iconNamed: #stop
+]
+
+{ #category : #actions }
+PyramidPluginTestMode >> switchToTestMode [
+	"
+	if test ok
+	0. isTestOnGoing: false.
+	1. event element visibility: visible.
+	2. displayAddons element visibility: visible.
+	if test nok
+	0. isTestOnGoing: true.
+	1. event element visibility: gone.
+	2. displayAddons element visibility: gone."
+
+	| event displayPosition |
+	self builder ifNil: [
+		self flag:
+			'If builder is nil then there is no space plugin loaded on current Pyramid instance.'.
+		self inform:
+			'No space plugin found. Please reload the Pyramid plugins on WorldMenu.'.
+		^ self ].
+	event := self elementAtEvents.
+	displayPosition := self elementAtDisplaysAddons.
+	self isTestOnGoing
+		ifTrue: [
+			self isTestOnGoing: false.
+			self button icon: self startTestIcon.
+			event visibility: BlVisibility visible.
+			displayPosition visibility: BlVisibility visible ]
+		ifFalse: [
+			self isTestOnGoing: true.
+			self button icon: self stopTestIcon.
+			event visibility: BlVisibility gone.
+			displayPosition visibility: BlVisibility gone ]
+]
diff --git a/src/Pyramid-Bloc/PyramidPositionExtension.class.st b/src/Pyramid-Bloc/PyramidPositionExtension.class.st
@@ -30,8 +30,10 @@ PyramidPositionExtension >> installOn: aBuilder [
 
 	self builder: aBuilder.
 
-	self elementAtEvents when: BlMouseMoveEvent do: [ :evt |
-		self display text:
-			(evt position - self currentTransformTranslation) asRopedText ].
-	self elementAtDisplay addChild: self display.
+	self elementAtEvents addEventHandler: (BlEventHandler
+			 on: BlMouseMoveEvent
+			 do: [ :evt |
+				 self display text:
+					 (evt position - self currentTransformTranslation) asRopedText ]).
+	self elementAtDisplaysAddons addChild: self display
 ]
diff --git a/src/Pyramid-Bloc/PyramidSelectionMakerExtension.class.st b/src/Pyramid-Bloc/PyramidSelectionMakerExtension.class.st
@@ -120,23 +120,24 @@ PyramidSelectionMakerExtension >> installOn: aBuilder [
 
 	self builder: aBuilder.
 
-	self elementAtDisplay addChild: self selectionGhost.
-	self elementAtEvents
-		when: BlPrimaryMouseDownEvent
-		do: [ :evt | self dragStart: evt ].
-	self elementAtEvents
-		when: BlSecondaryMouseDownEvent
-		do: [ :evt | self dragStart: evt ].
-
-	self elementAtEvents
-		when: BlMouseMoveEvent
-		do: [ :evt | self dragEvent: evt ].
-
-	self elementAtEvents
-		when: BlPrimaryMouseUpEvent
-		do: [ :evt | self dragEnd: evt ].
-	self elementAtEvents when: BlSecondaryMouseUpEvent do: [ :evt |
-		self dragEnd: evt ]
+	self elementAtDisplaysAddons addChild: self selectionGhost.
+	self elementAtEvents addEventHandler: (BlEventHandler
+			 on: BlPrimaryMouseDownEvent
+			 do: [ :evt | self dragStart: evt ]).
+	self elementAtEvents addEventHandler: (BlEventHandler
+			 on: BlSecondaryMouseDownEvent
+			 do: [ :evt | self dragStart: evt ]).
+
+	self elementAtEvents addEventHandler: (BlEventHandler
+			 on: BlMouseMoveEvent
+			 do: [ :evt | self dragEvent: evt ]).
+
+	self elementAtEvents addEventHandler: (BlEventHandler
+			 on: BlPrimaryMouseUpEvent
+			 do: [ :evt | self dragEnd: evt ]).
+	self elementAtEvents addEventHandler: (BlEventHandler
+			 on: BlSecondaryMouseUpEvent
+			 do: [ :evt | self dragEnd: evt ])
 ]
 
 { #category : #accessing }

diff --git a/src/Pyramid-Bloc/PyramidSelectionWidgetBorderBuilder.class.st b/src/Pyramid-Bloc/PyramidSelectionWidgetBorderBuilder.class.st
@@ -90,12 +90,14 @@ PyramidSelectionWidgetBorderBuilder >> leftLabelFor: aBlElement [
 	label := self labelWithColor: self mainLeftColor.
 	label transformDo: [ :t | t rotateBy: -90 ].
 
-	aBlElement when: BlElementExtentChangedEvent do: [ :evt |
-		label text: (aBlElement height < 50
-				 ifTrue: [ '' asRopedText ]
-				 ifFalse: [ aBlElement height printString asRopedText ]).
-		label requestLayout.
-		label position: -22 @ (aBlElement height - 20 / 2) ].
+	aBlElement addEventHandler: (BlEventHandler
+			 on: BlElementExtentChangedEvent
+			 do: [ :evt |
+				 label text: (aBlElement height < 50
+						  ifTrue: [ '' asRopedText ]
+						  ifFalse: [ aBlElement height printString asRopedText ]).
+				 label requestLayout.
+				 label position: -22 @ (aBlElement height - 20 / 2) ]).
 	^ label
 ]
 
@@ -167,11 +169,13 @@ PyramidSelectionWidgetBorderBuilder >> topLabelFor: aBlElement [
 	| label |
 	label := self labelWithColor: self mainTopColor.
 
-	aBlElement when: BlElementExtentChangedEvent do: [ :evt |
-		label text: (aBlElement width < 50
-				 ifTrue: [ '' asRopedText ]
-				 ifFalse: [ aBlElement width printString asRopedText ]).
-		label requestLayout.
-		label position: aBlElement width - 20 / 2 @ -13 ].
+	aBlElement addEventHandler: (BlEventHandler
+			 on: BlElementExtentChangedEvent
+			 do: [ :evt |
+				 label text: (aBlElement width < 50
+						  ifTrue: [ '' asRopedText ]
+						  ifFalse: [ aBlElement width printString asRopedText ]).
+				 label requestLayout.
+				 label position: aBlElement width - 20 / 2 @ -13 ]).
 	^ label
 ]
diff --git a/src/Pyramid-Bloc/PyramidSelectionWidgetExtension.class.st b/src/Pyramid-Bloc/PyramidSelectionWidgetExtension.class.st
@@ -127,7 +127,7 @@ PyramidSelectionWidgetExtension >> isDragging: anObject [
 PyramidSelectionWidgetExtension >> makeMonoSelectionFor: aBlElement [
 
 	| monoSelection eventElement dragGhostElement borderElement |
-	monoSelection := (BlOverlayElement on: aBlElement).
+	monoSelection := BlOverlayElement on: aBlElement.
 	monoSelection clipChildren: false.
 
 	dragGhostElement := BlElement new
@@ -145,12 +145,15 @@ PyramidSelectionWidgetExtension >> makeMonoSelectionFor: aBlElement [
 			                c vertical matchParent.
 			                c horizontal matchParent ];
 		                zIndex: 100;
-		                when: BlPrimaryMouseDownEvent
-		                do: [ :evt | self centerDragStart: evt ];
-		                when: BlMouseEvent
-		                do: [ :evt | self centerDragEvent: evt ];
-		                when: BlPrimaryMouseUpEvent
-		                do: [ :evt | self centerDragEnd: evt ];
+		                addEventHandler: (BlEventHandler
+				                 on: BlPrimaryMouseDownEvent
+				                 do: [ :evt | self centerDragStart: evt ]);
+		                addEventHandler: (BlEventHandler
+				                 on: BlMouseEvent
+				                 do: [ :evt | self centerDragEvent: evt ]);
+		                addEventHandler: (BlEventHandler
+				                 on: BlPrimaryMouseUpEvent
+				                 do: [ :evt | self centerDragEnd: evt ]);
 		                yourself.
 	borderElement := PyramidSelectionWidgetBorderBuilder new build.
 

diff --git a/src/Pyramid-Bloc/PyramidSpaceBuilder.class.st b/src/Pyramid-Bloc/PyramidSpaceBuilder.class.st
@@ -31,6 +31,7 @@ PyramidSpaceBuilder class >> defaultEditorBuilder [
 			           { #displays. #transforms. #main. #events. #widgets };
 		           yourself.
 
+	(builder overlays at: #displays) element addChild: (BlElement new id: #displaysAddons; clipChildren: false; yourself).
 	self defaultEditorExtensions do: [ :class |
 		builder addExtension: class new ].
 
@@ -93,12 +94,12 @@ PyramidSpaceBuilder >> build [
 
 	self overlays ifEmpty: [ ^ self space ].
 
-	self space
-		when: BlKeyDownEvent
-		do: [ :evt | self keyboard add: evt key ].
-	self space
-		when: BlKeyUpEvent
-		do: [ :evt | self keyboard remove: evt key ].
+	self space addEventHandler: (BlEventHandler
+			 on: BlKeyDownEvent
+			 do: [ :evt | self keyboard add: evt key ]).
+	self space addEventHandler: (BlEventHandler
+			 on: BlKeyUpEvent
+			 do: [ :evt | self keyboard remove: evt key ]).
 
 	self signalTransformationChanged.
 	self topMostOverlay buildOn: self space root.

diff --git a/src/Pyramid-Bloc/PyramidSpaceContainer.class.st b/src/Pyramid-Bloc/PyramidSpaceContainer.class.st
@@ -29,5 +29,8 @@ PyramidSpaceContainer >> element: anObject [
 { #category : #initialization }
 PyramidSpaceContainer >> initialize [
 
-	element := BlElement new constraintsDo: [ :c | c vertical matchParent . c horizontal matchParent ]; clipChildren: false; yourself
+	element := (BlElement id: (self class name asSymbol))
+		           constraintsDo: [ :c | c vertical matchParent. c horizontal matchParent ];
+		           clipChildren: false;
+		           yourself
 ]
diff --git a/src/Pyramid-Bloc/PyramidSpacePlugin.class.st b/src/Pyramid-Bloc/PyramidSpacePlugin.class.st
@@ -60,8 +60,9 @@ PyramidSpacePlugin >> makePresenterWithBlSpace: aBlSpace [
 	host containerMorph: morph.
 
 	aBlSpace host: host.
-	aBlSpace when: BlSpaceDestroyedEvent do: [ :evt |
-		self updateMorphInCaseOfFaillure: morph ].
+	aBlSpace addEventHandler: (BlEventHandler
+			 on: BlSpaceDestroyedEvent
+			 do: [ :evt | self updateMorphInCaseOfFaillure: morph ]).
 
 	self morphicPresenter morph: morph.
 	self morphicPresenter whenDisplayDo: [ aBlSpace show ]