From 841e58bbd2695023dd942303f0061a11a4d49ae1 Mon Sep 17 00:00:00 2001
From: CyrilFerlicot <cyril@ferlicot.me>
Date: Tue, 4 Feb 2025 11:22:15 +0100
Subject: [PATCH] Move keymapping UI to NewTools

To fix a dependency test
---
 .../BaselineOfNewTools.class.st               |   5 +
 .../KMCategory.extension.st                   |  13 ++
 .../KMCategoryAll.class.st                    |  95 +++++++++
 .../KMDescriptionPresenter.class.st           | 186 ++++++++++++++++++
 src/NewTools-Keymapping/KMKeymap.extension.st |  14 ++
 src/NewTools-Keymapping/package.st            |   1 +
 6 files changed, 314 insertions(+)
 create mode 100644 src/NewTools-Keymapping/KMCategory.extension.st
 create mode 100644 src/NewTools-Keymapping/KMCategoryAll.class.st
 create mode 100644 src/NewTools-Keymapping/KMDescriptionPresenter.class.st
 create mode 100644 src/NewTools-Keymapping/KMKeymap.extension.st
 create mode 100644 src/NewTools-Keymapping/package.st

diff --git a/src/BaselineOfNewTools/BaselineOfNewTools.class.st b/src/BaselineOfNewTools/BaselineOfNewTools.class.st
index be4d48a9..cae05655 100644
--- a/src/BaselineOfNewTools/BaselineOfNewTools.class.st
+++ b/src/BaselineOfNewTools/BaselineOfNewTools.class.st
@@ -113,6 +113,8 @@ BaselineOfNewTools >> baseline: spec [
 
 			package: 'NewTools-WelcomeBrowser';
 			
+			package: 'NewTools-Keymapping';
+			
 			package: 'ColorPicker';
 			package: 'ColorPicker-Tests' with: [ spec requires: #( ColorPicker ) ].
 
@@ -191,6 +193,8 @@ BaselineOfNewTools >> baseline: spec [
 						
 			group: 'WelcomeBrowser' with: #( 'NewTools-WelcomeBrowser' );
 			
+			group: 'Keymapping' with: #( 'NewTools-Keymapping' );
+			
 			group: 'ColorPickerGroup' with: #('ColorPicker' 'ColorPicker-Tests');
 
 			group: 'default' with: #( 
@@ -210,6 +214,7 @@ BaselineOfNewTools >> baseline: spec [
 						'Profiler'
 						'SettingsBrowser'
 						'WelcomeBrowser'
+						'Keymapping'
 						'ColorPickerGroup' ) ]
 ]
 
diff --git a/src/NewTools-Keymapping/KMCategory.extension.st b/src/NewTools-Keymapping/KMCategory.extension.st
new file mode 100644
index 00000000..70060f3b
--- /dev/null
+++ b/src/NewTools-Keymapping/KMCategory.extension.st
@@ -0,0 +1,13 @@
+Extension { #name : 'KMCategory' }
+
+{ #category : '*NewTools-Keymapping' }
+KMCategory >> scopeName [
+
+	^  self name
+]
+
+{ #category : '*NewTools-Keymapping' }
+KMCategory >> shortcuts [
+
+	^ (self entriesAt: #all) keymaps
+]
diff --git a/src/NewTools-Keymapping/KMCategoryAll.class.st b/src/NewTools-Keymapping/KMCategoryAll.class.st
new file mode 100644
index 00000000..e448820b
--- /dev/null
+++ b/src/NewTools-Keymapping/KMCategoryAll.class.st
@@ -0,0 +1,95 @@
+Class {
+	#name : 'KMCategoryAll',
+	#superclass : 'Object',
+	#instVars : [
+		'categoryName',
+		'shortcuts'
+	],
+	#category : 'NewTools-Keymapping',
+	#package : 'NewTools-Keymapping'
+}
+
+{ #category : 'copying' }
+KMCategoryAll >> , aKMCategory [
+
+	self shortcuts addAll: aKMCategory allEntries keymaps
+]
+
+{ #category : 'comparing' }
+KMCategoryAll >> = anObject [
+	"Answer whether the receiver and anObject represent the same object."
+
+	self == anObject ifTrue: [ ^ true ].
+	self class = anObject class ifFalse: [ ^ false ].
+	^ categoryName = anObject categoryName and: [
+		  shortcuts = anObject shortcuts ]
+]
+
+{ #category : 'adding' }
+KMCategoryAll >> addAll: aCollection [ 
+	"Add all shortcuts in aCollection to the receiver"
+	
+	self shortcuts addAll: aCollection
+]
+
+{ #category : 'accessing' }
+KMCategoryAll >> categoryName [
+
+	^ categoryName
+]
+
+{ #category : 'accessing' }
+KMCategoryAll >> categoryName: anObject [
+
+	categoryName := anObject
+]
+
+{ #category : 'comparing' }
+KMCategoryAll >> hash [
+	"Answer an integer value that is related to the identity of the receiver."
+
+	^ categoryName hash bitXor: shortcuts hash
+]
+
+{ #category : 'accessing' }
+KMCategoryAll >> icon [
+
+	^ self iconNamed: self systemIconName
+]
+
+{ #category : 'accessing' }
+KMCategoryAll >> model [
+	"Required by <SpDropListPresenter> ?"
+
+	^ self
+]
+
+{ #category : 'accessing' }
+KMCategoryAll >> name [
+
+	^  self categoryName
+]
+
+{ #category : 'printing' }
+KMCategoryAll >> printOn: aStream [
+	"Generate a string representation of the receiver based on its instance variables."
+
+	super printOn: aStream.
+	aStream
+		nextPutAll: ' [';
+		print: categoryName;
+		nextPutAll: ']'
+]
+
+{ #category : 'accessing' }
+KMCategoryAll >> shortcuts [
+
+	^ shortcuts
+		ifNil: [ shortcuts := OrderedCollection new ]
+]
+
+{ #category : 'accessing' }
+KMCategoryAll >> shortcuts: anObject [
+
+	shortcuts := anObject
+]
diff --git a/src/NewTools-Keymapping/KMDescriptionPresenter.class.st b/src/NewTools-Keymapping/KMDescriptionPresenter.class.st
new file mode 100644
index 00000000..2342e32f
--- /dev/null
+++ b/src/NewTools-Keymapping/KMDescriptionPresenter.class.st
@@ -0,0 +1,186 @@
+"
+A KMDescription is a window showing the description of shortcuts for a specified set of symbols reprensenting KMCategories
+"
+Class {
+	#name : 'KMDescriptionPresenter',
+	#superclass : 'StPresenter',
+	#instVars : [
+		'actionBar',
+		'categoryList',
+		'shortcutTable',
+		'inputPresenter'
+	],
+	#category : 'NewTools-Keymapping',
+	#package : 'NewTools-Keymapping'
+}
+
+{ #category : 'accessing' }
+KMDescriptionPresenter class >> defaultPreferredExtent [
+
+	^ 900 @ 650
+]
+
+{ #category : 'instance creation' }
+KMDescriptionPresenter class >> descriptionText [
+
+	^ 'Show the system''s shortcuts'
+]
+
+{ #category : 'accessing' }
+KMDescriptionPresenter class >> icon [
+
+	^ self iconNamed: #keymapBrowser
+]
+
+{ #category : 'instance creation' }
+KMDescriptionPresenter class >> menuCommandOn: aBuilder [
+	<worldMenu>
+
+	(aBuilder item: 'Shortcuts Browser')
+		action: [ self open ];
+		order: 34;
+		parent: #Tools;
+		icon: self icon;
+		help: self descriptionText
+]
+
+{ #category : 'instance creation' }
+KMDescriptionPresenter class >> open [
+
+	<script>
+	^ (self newApplication: StPharoApplication current) open
+]
+
+{ #category : 'initialization' }
+KMDescriptionPresenter >> allAPIsEntry [
+	"Set the receiver's category items to a list of categories in aCollectionOfSymbols.
+	We also build an 'All' category including all keymaps in aCollectionOfSymbols"
+
+	| newCategoryItem |
+	newCategoryItem := KMCategoryAll new categoryName: 'All'.
+	KMRepository default categories inject: newCategoryItem into: [ : a : b | a , b ].
+	newCategoryItem addAll: self shortcutActivationCmdInstances.
+	^ newCategoryItem
+]
+
+{ #category : 'initialization' }
+KMDescriptionPresenter >> connectPresenters [
+
+	categoryList transmitTo: shortcutTable transform: [ :item | self keymapsAtCategory: item model ].
+	inputPresenter whenTextChangedDo: [ :text | self filterTable: text ].
+	shortcutTable whenActivatedDo: [ :item | item value inspect selectedItem ]
+]
+
+{ #category : 'layout' }
+KMDescriptionPresenter >> defaultLayout [
+
+	^ SpBoxLayout newTopToBottom
+		  spacing: 6;
+		  add: (SpBoxLayout newLeftToRight
+				   add: 'Filter scopes' expand: false;
+				   add: categoryList;
+				   yourself)
+		  expand: false;
+		  add: inputPresenter expand: false;
+		  add: shortcutTable;
+		  add: actionBar withConstraints: [ :c | c height: 25 ];
+		  yourself
+]
+
+{ #category : 'callbacks' }
+KMDescriptionPresenter >> filterTable: aText [
+
+	| newItems |
+	aText ifEmpty: [
+		shortcutTable items: (self keymapsAtCategory: categoryList selectedItem).
+		^ self ].
+
+	newItems := (self keymapsAtCategory: categoryList selectedItem) select: [ :each |
+		            { each name. each scopeName. each description } anySatisfy: [ :aString | 
+								aString includesSubstring: aText caseSensitive: false ] ].
+	shortcutTable items: newItems
+]
+
+{ #category : 'initialization' }
+KMDescriptionPresenter >> initialize [
+
+	| shortcutCategories |
+	super initialize.
+
+	shortcutCategories := { self allAPIsEntry } , self shortcutActivationCategoriesItems
+	                      , (KMRepository default categories keys collect: [ :e | KMRepository default categoryForName: e ]).
+	categoryList items: shortcutCategories
+]
+
+{ #category : 'initialization' }
+KMDescriptionPresenter >> initializePresenters [
+
+	categoryList := self newDropList
+		                display: [ :category | category name ];
+		                yourself.
+	inputPresenter := self newTextInput
+		                  placeholder: 'Filter';
+		                  yourself.
+
+	shortcutTable := self newTable.
+	shortcutTable
+		activateOnDoubleClick;
+		addColumn: (SpStringTableColumn new
+				 title: 'Name';
+				 evaluated: #name;
+				 beSortable;
+				 yourself);
+		addColumn: (SpStringTableColumn title: 'Shortcut' evaluated: #shortcut);
+		addColumn: (SpStringTableColumn title: 'Description' evaluated: #description);
+		addColumn: (SpStringTableColumn new
+				 title: 'Scope';
+				 evaluated: [ :each | each scopeName ];
+				 beSortable;
+				 width: 150;
+				 yourself);
+		beResizable.
+
+	actionBar := self newActionBar.
+	actionBar
+		addLast: (SpButtonPresenter new
+				 action: [ "self application tools browser openOn:" shortcutTable selectedItem action browser ];
+				 label: 'Browse';
+				 yourself);
+		addLast: (SpButtonPresenter new
+				 action: [ self application tools inspector openOn: shortcutTable selectedItem inspect ];
+				 label: 'Inspect';
+				 yourself)
+]
+
+{ #category : 'callbacks' }
+KMDescriptionPresenter >> keymapsAtCategory: aKMCategoryOrKMCategoryAll [
+	"Answer a <Collection> of keymaps"
+	^ aKMCategoryOrKMCategoryAll shortcuts
+]
+
+{ #category : 'initialization' }
+KMDescriptionPresenter >> shortcutActivationCategoriesItems [
+	"Answer a <Collection> of <KMCategoryItemPresenter> representing each a category of shortcuts created using the Commander 1 framework"
+	
+	| shortcutActivationCategories |
+	shortcutActivationCategories := (self shortcutActivationCmdInstances groupedBy: [ :cmdShortcutActivation |
+		                                 cmdShortcutActivation annotatedClass packageName ]) values.
+
+	^ shortcutActivationCategories collect: [ :shortcuts |
+		  KMCategoryAll new
+			  categoryName: shortcuts anyOne annotatedClass packageName;
+			  shortcuts: shortcuts;
+			  yourself ]
+]
+
+{ #category : 'initialization' }
+KMDescriptionPresenter >> shortcutActivationCmdInstances [
+
+	^ CmdShortcutActivation registeredInstances copyWithoutAll: CmdShortcutActivation redefiningInstances
+]
+
+{ #category : 'initialization' }
+KMDescriptionPresenter >> windowTitle [
+
+	^ 'Shortcuts Browser'
+]
diff --git a/src/NewTools-Keymapping/KMKeymap.extension.st b/src/NewTools-Keymapping/KMKeymap.extension.st
new file mode 100644
index 00000000..30b90bbd
--- /dev/null
+++ b/src/NewTools-Keymapping/KMKeymap.extension.st
@@ -0,0 +1,14 @@
+Extension { #name : 'KMKeymap' }
+
+{ #category : '*NewTools-Keymapping' }
+KMKeymap >> scope [
+
+	^ KMRepository default categories 
+		detect: [ : cat | cat keymaps includes: self ]
+]
+
+{ #category : '*NewTools-Keymapping' }
+KMKeymap >> scopeName [
+
+	^  self scope scopeName
+]
diff --git a/src/NewTools-Keymapping/package.st b/src/NewTools-Keymapping/package.st
new file mode 100644
index 00000000..7fa410c9
--- /dev/null
+++ b/src/NewTools-Keymapping/package.st
@@ -0,0 +1 @@
+Package { #name : 'NewTools-Keymapping' }