fixed delete keyboard shortcut

OpenPonk · Oct 14, 2023 · ebf35e9 · ebf35e9
1 parent 18c2f27
commit ebf35e9
Show file tree

Hide file tree

Showing 9 changed files with 153 additions and 57 deletions.
diff --git a/repository/OpenPonk-Roassal3/OPRSDraggableControlPoints.class.st b/repository/OpenPonk-Roassal3/OPRSDraggableControlPoints.class.st
@@ -18,11 +18,13 @@ OPRSDraggableControlPoints >> connectWithCanvas [
 	interaction := canvas propertyAt: OPRSSelectableCanvas ifAbsent: [
 		               line
 			               when: RSMouseLeftClick
-			               do: [ :event | self showHandles ].
+			               do: [ :event | self showHandles ]
+			               for: self.
 		               canvas
 			               when: RSMouseLeftClick
 			               do: [ :event |
-			               event shape = line ifFalse: [ self removeHandles ] ].
+			               event shape = line ifFalse: [ self removeHandles ] ]
+			               for: self.
 		               ^ self ].
 	interaction
 		when: OPRSSelectionEndEvent

diff --git a/repository/OpenPonk-Roassal3/OPRSKeyNavigationCanvasInteraction.class.st b/repository/OpenPonk-Roassal3/OPRSKeyNavigationCanvasInteraction.class.st
@@ -0,0 +1,19 @@
+Class {
+	#name : #OPRSKeyNavigationCanvasInteraction,
+	#superclass : #RSKeyNavigationCanvasInteraction,
+	#category : #'OpenPonk-Roassal3-Interactions'
+}
+
+{ #category : #events }
+OPRSKeyNavigationCanvasInteraction >> processKeyDown: evt [
+
+	| keyName |
+	keyName := evt keyName.
+	keyName = #I ifTrue: [ ^ self ].
+	keyName = #O ifTrue: [ ^ self ].
+	(#( #+ #PLUS #KP_ADD ) includes: keyName) ifTrue: [
+		^ self zoomIn: evt canvas ].
+	(#( #- #MINUS #KP_SUBTRACT ) includes: keyName) ifTrue: [
+		^ self zoomOut: evt canvas ].
+	^ super processKeyDown: evt
+]
diff --git a/repository/OpenPonk-Roassal3/OPRSRemoveable.class.st b/repository/OpenPonk-Roassal3/OPRSRemoveable.class.st
@@ -4,6 +4,12 @@ Class {
 	#category : #'OpenPonk-Roassal3-Interactions'
 }
 
+{ #category : #testing }
+OPRSRemoveable class >> isDeprecated [
+	"does not work with UML"
+	^ true
+]
+
 { #category : #hooks }
 OPRSRemoveable >> onShape: aCanvas [
 	aCanvas

diff --git a/repository/OpenPonk-Spec/HandMorph.extension.st b/repository/OpenPonk-Spec/HandMorph.extension.st
@@ -0,0 +1,31 @@
+Extension { #name : #HandMorph }
+
+{ #category : #'*OpenPonk-Spec' }
+HandMorph >> sendKeyboardEvent: anEvent [
+
+	self flag:
+		'Part of ugly hack to find out if ctrl is currently pressed'.
+	OPDiagramRemoveFigureCommand lastEvent: anEvent.
+	self flag:
+		'Original method below'.
+
+	"Send the event to the morph currently holding the focus, or if none to
+	the owner of the hand."
+	^ self
+		sendEvent: anEvent
+		focus: self keyboardFocus
+		clear: [self keyboardFocus: nil]
+]
+
+{ #category : #'*OpenPonk-Spec' }
+HandMorph >> sendMouseEvent: anEvent [
+
+	self flag:
+		'Part of ugly hack to find out if ctrl is currently pressed'.
+	OPDiagramRemoveFigureCommand lastEvent: anEvent.
+	self flag:
+		'Original method below'.
+
+	"Send the event to the morph currently holding the focus, or if none to the owner of the hand."
+	^self sendEvent: anEvent focus: self mouseFocus clear:[self mouseFocus: nil]
+]
diff --git a/repository/OpenPonk-Spec/OPCanvasPresenter.class.st b/repository/OpenPonk-Spec/OPCanvasPresenter.class.st
@@ -26,6 +26,16 @@ OPCanvasPresenter >> canvas [
 	^ currentCanvas
 ]
 
+{ #category : #initialization }
+OPCanvasPresenter >> connectPresenters [
+
+	super connectPresenters.
+	onZoomChange := [ :event |  ].
+	onExtentChange := [ :event |  ].
+	self whenBuiltDo: [ :adptr |
+		CmdKMDispatcher attachedTo: adptr widget withCommandsFrom: self ]
+]
+
 { #category : #'private-focus' }
 OPCanvasPresenter >> createCommandContext [
 	"Subclases should override it if they provide any selection"
@@ -50,14 +60,6 @@ OPCanvasPresenter >> editor [
 	^ self owner
 ]
 
-{ #category : #'private-focus' }
-OPCanvasPresenter >> ensureKeyBindingsFor: aWidget [
-
-	self flag: 'Does not work in P11'.
-	super ensureKeyBindingsFor: aWidget.
-	^ self enableCommanderShortcutsIn: aWidget
-]
-
 { #category : #toolbar }
 OPCanvasPresenter >> exportAsPng [
 
@@ -170,8 +172,6 @@ OPCanvasPresenter >> exportCanvasToSvg: aFileReference silently: aSilentlyBoolea
 OPCanvasPresenter >> initialize [
 
 	super initialize.
-	onZoomChange := [ :event |  ].
-	onExtentChange := [ :event |  ].
 	self script: [ :canvas | self initializeCanvas: canvas ]
 ]
 
@@ -184,9 +184,9 @@ OPCanvasPresenter >> initializeCanvas: aCanvas [
 						 (RSDraggableCanvasInteraction right
 							  hasDraggableAnimation: false;
 							  yourself).
-						 RSKeyNavigationCanvasInteraction new.
+						 OPRSKeyNavigationCanvasInteraction new.
 						 OPRSZoomableCanvasInteraction new.
-						 OPRSRemoveable new.
+						 "OPRSRemoveable new."
 						 RSScrollBarsCanvasInteraction new };
 				 configuration: (OPRSControlConfiguration new
 						  noLegend;

diff --git a/repository/OpenPonk-Spec/OPDiagramFigureCommand.class.st b/repository/OpenPonk-Spec/OPDiagramFigureCommand.class.st
@@ -12,6 +12,9 @@ Class {
 		'controllers',
 		'diagramElements'
 	],
+	#classInstVars : [
+		'lastEvent'
+	],
 	#category : #'OpenPonk-Spec-Diagram-Figure-Commands'
 }
 

diff --git a/repository/OpenPonk-Spec/OPDiagramRemoveFigureCommand.class.st b/repository/OpenPonk-Spec/OPDiagramRemoveFigureCommand.class.st
@@ -13,13 +13,38 @@ OPDiagramRemoveFigureCommand class >> canBeExecutedInContext: aToolContext [
 
 { #category : #testing }
 OPDiagramRemoveFigureCommand class >> canvasShortcutActivation [
+
 	<classAnnotation>
-	^ CmdShortcutActivation by: Character delete meta for: OPCanvasPresenter
+	^ CmdShortcutActivation
+		  by: (KMKeyCombinationChoice withShortcuts: {
+					   (KMSingleKeyCombination new key:
+						    (KeyboardKey new withValue: 16rffff andName: #delete)).
+					   ((KMSingleKeyCombination new key:
+						     (KeyboardKey new withValue: 16rffff andName: #delete))
+						    modifiedBy: KMModifier meta) })
+		  for: OPCanvasPresenter
 ]
 
 { #category : #accessing }
-OPDiagramRemoveFigureCommand >> defaultMenuIcon [
+OPDiagramRemoveFigureCommand class >> lastEvent [
+
+	self flag:
+		'Part of ugly hack to find out if ctrl is currently pressed'.
+
+	^ lastEvent
+]
+
+{ #category : #accessing }
+OPDiagramRemoveFigureCommand class >> lastEvent: anEvent [
 
+	self flag:
+		'Part of ugly hack to find out if ctrl is currently pressed'.
+
+	lastEvent := anEvent
+]
+
+{ #category : #accessing }
+OPDiagramRemoveFigureCommand >> defaultMenuIcon [
 	^ self iconNamed: #glamorousTrash
 ]
 
@@ -31,13 +56,50 @@ OPDiagramRemoveFigureCommand >> defaultMenuItemName [
 		  ifFalse: [ 'Remove all ' , models size asString , ' from model' ]
 ]
 
+{ #category : #utilities }
+OPDiagramRemoveFigureCommand >> doAndReturnFocus: aBlock [
+
+	| result window wasActive |
+	window := diagramController canvasPresenter window window.
+	wasActive := window isActive.
+	result := aBlock value.
+	window activate.
+	^ result
+]
+
 { #category : #execution }
 OPDiagramRemoveFigureCommand >> execute [
 
+	| lastEvent |
+	lastEvent := self class lastEvent.
+	(lastEvent isNotNil and: [
+		 lastEvent controlKeyPressed or: [ lastEvent commandKeyPressed ] ])
+		ifTrue: [ self unsafeExecute ]
+		ifFalse: [ self safeExecute ]
+]
+
+{ #category : #execution }
+OPDiagramRemoveFigureCommand >> safeExecute [
+
+	| result |
+	result := self doAndReturnFocus: [
+		          UIManager default
+			          proceed:
+				          'Permanently remove from model? (to skip this confirmation, hold '
+				          , OSPlatform current defaultModifier name
+				          , ' next time)'
+			          title: 'Remove?' ].
+	result ifNil: [ ^ self ].
+	result ifFalse: [ ^ self ].
+	self unsafeExecute
+]
+
+{ #category : #execution }
+OPDiagramRemoveFigureCommand >> unsafeExecute [
+
 	diagramController deselectAll.
-	figures do: [ :each | 
-		(diagramController hasControllerForFigure: each) ifTrue: [ 
+	figures do: [ :each |
+		(diagramController hasControllerForFigure: each) ifTrue: [
 			diagramController removeFromCanvas: each ] ].
-	"diagramController selectedElements do: [ :each | diagramController removeFromCanvas: each]."
 	canvas signalUpdate
 ]
diff --git a/repository/OpenPonk-Spec/OPEditor.class.st b/repository/OpenPonk-Spec/OPEditor.class.st
@@ -11,7 +11,6 @@ Class {
 		'zoomLabel',
 		'diagramController',
 		'plugin',
-		'shortcuts',
 		'canvasPresenter',
 		'canvasMenu',
 		'form',
@@ -129,19 +128,7 @@ OPEditor >> canvasPresenter [
 	^ canvasPresenter
 ]
 
-{ #category : #shortcuts }
-OPEditor >> collectShortcuts [
-	^ ((PragmaCollector
-		filter: [ :prg | 
-	prg selector = #opEditorShortcut:
-		and: [ prg arguments first = self plugin class name ] ])
-		reset;
-		collect:
-				[ :prg | prg methodClass theNonMetaClass perform: prg methodSelector with: self ])
-		flattened
-]
-
-{ #category : #'as yet unclassified' }
+{ #category : #initialization }
 OPEditor >> connectPresenters [
 
 	| menu |
@@ -162,20 +149,12 @@ OPEditor >> diagramController [
 	^ diagramController
 ]
 
-{ #category : #'private-focus' }
-OPEditor >> ensureKeyBindingsFor: aWidget [
-
-	self flag: 'Does not work in P11'.
-	super ensureKeyBindingsFor: aWidget.
-	^ self enableCommanderShortcutsIn: aWidget
-]
-
 { #category : #'accessing - spec' }
 OPEditor >> form [
 	^ form
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #initialization }
 OPEditor >> initializePresenters [
 
 	canvasMenu := self newMenuBar.
@@ -229,7 +208,7 @@ OPEditor >> openEmptyModel: aModel [
 	self rebuildWidget
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #initialization }
 OPEditor >> openFormOn: aController [
 
 	form editController: aController
@@ -259,12 +238,6 @@ OPEditor >> rebuildWidget [
 	self update
 ]
 
-{ #category : #shortcuts }
-OPEditor >> registerShortcutsOn: aPresenter [
-	shortcuts := self collectShortcuts.
-	shortcuts do: [ :each | aPresenter bindKeyCombination: each key toAction: each value ]
-]
-
 { #category : #initialization }
 OPEditor >> setModelBeforeInitialization: aPlugin [
 	self plugin: aPlugin
@@ -278,15 +251,9 @@ OPEditor >> tabDeleted [
 		diagramController diagramElement.
 	self workbench projectController removeDiagramController:
 		diagramController.
-	self unregisterShortcutsOn: self workbench.
 	diagramController removeRender
 ]
 
-{ #category : #shortcuts }
-OPEditor >> unregisterShortcutsOn: aPresenter [
-	shortcuts do: [ :pair | aPresenter removeKeyCombination: pair key ]
-]
-
 { #category : #updating }
 OPEditor >> updateUndoRedo [
 	self flag: #unused.
@@ -308,8 +275,8 @@ OPEditor >> workbench [
 
 { #category : #'accessing - spec' }
 OPEditor >> workbench: aWorkbench [
-	workbench := aWorkbench.
-	self registerShortcutsOn: workbench
+
+	workbench := aWorkbench
 ]
 
 { #category : #'accessing - spec' }

diff --git a/repository/OpenPonk-Spec/ToggleMenuItemShortcut.extension.st b/repository/OpenPonk-Spec/ToggleMenuItemShortcut.extension.st
@@ -0,0 +1,6 @@
+Extension { #name : #ToggleMenuItemShortcut }
+
+{ #category : #'*OpenPonk-Spec' }
+ToggleMenuItemShortcut class >> keyTextShortcuts [
+	^ #('cmd'. 'alt'. 'shift'.'ctrl'. 'meta' '⌘' '⇧' 'delete')
+]