~drgeo-developers/drgeo/trunk

« back to all changes in this revision

Viewing changes to src/Commander.pck.st

  • Committer: Hilaire Fernandes
  • Date: 2022-08-07 09:38:52 UTC
  • Revision ID: hilaire.fernandes@gmail.com-20220807093852-kbalk8ybjj3hqv90
Move in necessary packages

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
'From Cuis 6.0 [latest update: #5435] on 4 August 2022 at 11:05:05 pm'!
 
2
'Description '!
 
3
!provides: 'Commander' 1 4!
 
4
SystemOrganization addCategory: 'Commander'!
 
5
 
 
6
 
 
7
!classDefinition: #CommandBuilder category: 'Commander'!
 
8
Object subclass: #CommandBuilder
 
9
        instanceVariableNames: 'cmdPragma commands model'
 
10
        classVariableNames: ''
 
11
        poolDictionaries: ''
 
12
        category: 'Commander'!
 
13
!classDefinition: 'CommandBuilder class' category: 'Commander'!
 
14
CommandBuilder class
 
15
        instanceVariableNames: ''!
 
16
 
 
17
!classDefinition: #CommandRecord category: 'Commander'!
 
18
Object subclass: #CommandRecord
 
19
        instanceVariableNames: 'id order icon label target selector arguments help'
 
20
        classVariableNames: ''
 
21
        poolDictionaries: ''
 
22
        category: 'Commander'!
 
23
!classDefinition: 'CommandRecord class' category: 'Commander'!
 
24
CommandRecord class
 
25
        instanceVariableNames: ''!
 
26
 
 
27
 
 
28
!CommandBuilder commentStamp: '<historical>' prior: 0!
 
29
I build a group of commands (think menu) and possible sub-group of commands (think sub-menu). 
 
30
I collect the command data from class methods tagged with a given pragma.
 
31
 
 
32
- commands is a dictionnary where:
 
33
        - value:  is a sorted collection of CommandRecord instances describing a group of commands
 
34
        - key is the id (symbol) of the command group
 
35
        There is always a top level group of commands with the key #root.
 
36
        The key of a sub-group of commands is the 'id' of the parent CommandRecord (read newEntry:in:)
 
37
- model : a defaut model used for the command   . Eeach command record can provide its own model
 
38
 
 
39
Test the example:
 
40
 
 
41
(CommandBuilder on: #exampleCommand) getMenu popUpInWorld!
 
42
 
 
43
!CommandRecord commentStamp: 'hlsf 8/4/2022 22:37:14' prior: 0!
 
44
I am the record of a command.
 
45
 
 
46
- id: a symbol identifier
 
47
- order: a (possibly float) number, the lowest, the higher in the menu I am placed
 
48
- icon: a form or symbol (theme)
 
49
- label: a string, if nil id is used as default label
 
50
- target, selector, arguments: parameter to execute the command
 
51
- help: a long description of the command!
 
52
 
 
53
!CommandBuilder methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:31:26'!
 
54
commandMethods
 
55
" Select all the methods defining the menu records  we are interested in"
 
56
        ^ Smalltalk allSelect: [:m | m pragmas anySatisfy: [:p | p key == cmdPragma ]]. 
 
57
 
 
58
! !
 
59
 
 
60
!CommandBuilder methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 23:06:03'!
 
61
model: aModel
 
62
        model _ aModel ! !
 
63
 
 
64
!CommandBuilder methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:19:42'!
 
65
pragma: aSymbol
 
66
        cmdPragma _ aSymbol asSymbol
 
67
! !
 
68
 
 
69
!CommandBuilder methodsFor: 'private' stamp: 'hlsf 7/23/2022 22:31:49'!
 
70
collectCommandRecords
 
71
        commands _ Dictionary new.
 
72
        self commandMethods do: [:method |
 
73
                method methodClass soleInstance 
 
74
                        perform: method methodSymbol 
 
75
                        with: self ].
 
76
        commands valuesDo: [:menuRecords | menuRecords reSort]! !
 
77
 
 
78
!CommandBuilder methodsFor: 'private' stamp: 'hlsf 7/23/2022 23:07:27'!
 
79
modelFor: aCmd
 
80
        ^ aCmd target ifNil: [model]! !
 
81
 
 
82
!CommandBuilder methodsFor: 'private' stamp: 'hlsf 7/23/2022 22:32:13'!
 
83
newCommandRecordCollection
 
84
        ^ SortedCollection sortBlock: [ :menuRec1 :menuRec2 |           menuRec1 order < menuRec2 order]! !
 
85
 
 
86
!CommandBuilder methodsFor: 'command record creation' stamp: 'hlsf 7/23/2022 22:32:32'!
 
87
newEntry: aSymbol
 
88
" Create a new command record in the #root"
 
89
        ^ self newEntry: aSymbol in: #root! !
 
90
 
 
91
!CommandBuilder methodsFor: 'command record creation' stamp: 'hlsf 7/23/2022 22:33:07'!
 
92
newEntry: aSymbol in: parentSymbol
 
93
" Create a new command record in the designated parent command and remember it in the appropriate collection "
 
94
        | commandCollection |
 
95
        commandCollection _ commands at: parentSymbol ifAbsentPut: [self newCommandRecordCollection].
 
96
        ^ commandCollection add: (CommandRecord id: aSymbol)! !
 
97
 
 
98
!CommandBuilder methodsFor: 'menu' stamp: 'hlsf 7/23/2022 23:07:19'!
 
99
buildMenuFrom: menuId
 
100
" Build the menu and return it "
 
101
        | menu |
 
102
        menu _ MenuMorph new.
 
103
        (commands at: menuId) do: [:cmdRec | | menuItem |
 
104
                menuItem _ MenuItemMorph new.
 
105
                menuItem 
 
106
                        contents: cmdRec label;
 
107
                        setIcon: cmdRec icon;
 
108
                        setBalloonText: cmdRec help;
 
109
                        target: (self modelFor: cmdRec) selector: cmdRec selector arguments: cmdRec arguments.
 
110
                menu addMorphBack: menuItem.
 
111
                " is this cmd the parent of a sub group? "
 
112
                (commands       includesKey: cmdRec id) ifTrue: [
 
113
                        " then attach its sub-menu, do it recursively " 
 
114
                        menuItem subMenu: (self buildMenuFrom: cmdRec id) ] ].
 
115
        ^ menu
 
116
        ! !
 
117
 
 
118
!CommandBuilder methodsFor: 'menu' stamp: 'hlsf 7/23/2022 23:02:06'!
 
119
getMenu
 
120
" Build the collected commands as a top level menu with sub-menus if any "
 
121
        self collectCommandRecords.
 
122
        ^ self buildMenuFrom: #root! !
 
123
 
 
124
!CommandBuilder class methodsFor: 'instance creation' stamp: 'hlsf 7/14/2022 11:43:12'!
 
125
on: aPragmaKeyord
 
126
        ^ self new ::
 
127
                pragma: aPragmaKeyord ! !
 
128
 
 
129
!CommandBuilder class methodsFor: 'instance creation' stamp: 'hlsf 7/23/2022 23:05:38'!
 
130
on: aPragmaKeyord with: aModel
 
131
        ^ self new ::
 
132
                pragma: aPragmaKeyord;
 
133
                model: aModel! !
 
134
 
 
135
!CommandBuilder class methodsFor: 'examples' stamp: 'hlsf 8/4/2022 20:53:46'!
 
136
example1_1: menuBuilder
 
137
        <exampleCommand>
 
138
        menuBuilder newEntry: #entry1 ::
 
139
                label: 'Menu entry 1';
 
140
                icon: #worldIcon;
 
141
                target: Workspace; selector: #openWorkspace;
 
142
                order: 500.
 
143
        menuBuilder newEntry: #entry2 ::
 
144
                action: [BrowserWindow openBrowser];
 
145
                label: 'Menu entry 2';
 
146
                help: 'I can have help too';
 
147
                order: 100! !
 
148
 
 
149
!CommandBuilder class methodsFor: 'examples' stamp: 'hlsf 7/23/2022 22:59:15'!
 
150
example1_2: menuBuilder
 
151
        <exampleCommand>
 
152
        menuBuilder newEntry: #entry3           in: #entry1 ::
 
153
                label: 'Menu entry 3';
 
154
                order: 1.
 
155
! !
 
156
 
 
157
!CommandBuilder class methodsFor: 'examples' stamp: 'hlsf 7/23/2022 22:59:21'!
 
158
example1_3: menuBuilder
 
159
        <exampleCommand>
 
160
        menuBuilder newEntry: #entry4 ::
 
161
                label: 'Menu entry 4';
 
162
                order: 1.
 
163
        menuBuilder newEntry: #'Just a drop place' in: #entry1
 
164
! !
 
165
 
 
166
!CommandBuilder class methodsFor: 'examples' stamp: 'hlsf 7/23/2022 22:59:24'!
 
167
example1_4: menuBuilder
 
168
        <exampleCommand>
 
169
        menuBuilder newEntry: #entry5 in: #'Just a drop place'::
 
170
                label: 'Menu entry 5'
 
171
! !
 
172
 
 
173
!CommandRecord methodsFor: 'initialization' stamp: 'hlsf 7/15/2022 16:22:12'!
 
174
initialize
 
175
        super initialize.
 
176
        menutItem _ MenuItemMorph new.
 
177
        order _ 1! !
 
178
 
 
179
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 8/4/2022 20:53:11'!
 
180
action: aBlock
 
181
" An alternate way to execute the command"
 
182
        target _ aBlock.
 
183
        selector _ #value.
 
184
        arguments _ nil! !
 
185
 
 
186
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:48:33'!
 
187
arguments
 
188
        ^ arguments ! !
 
189
 
 
190
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:49:34'!
 
191
arguments: aCollection
 
192
        arguments _ aCollection
 
193
! !
 
194
 
 
195
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:50:18'!
 
196
help
 
197
        ^ help! !
 
198
 
 
199
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:46:08'!
 
200
help: aString
 
201
        help _ aString ! !
 
202
 
 
203
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:47:46'!
 
204
icon
 
205
        ^ icon! !
 
206
 
 
207
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:45:52'!
 
208
icon: aSymbolOrForm
 
209
        icon _ aSymbolOrForm ! !
 
210
 
 
211
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/15/2022 17:31:50'!
 
212
id
 
213
        ^ id! !
 
214
 
 
215
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/14/2022 19:50:47'!
 
216
id: aSymbol
 
217
        id _ aSymbol ! !
 
218
 
 
219
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:47:40'!
 
220
label
 
221
        ^ label! !
 
222
 
 
223
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:45:35'!
 
224
label: aString
 
225
        label _ aString ! !
 
226
 
 
227
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/15/2022 16:21:29'!
 
228
order
 
229
        ^ order! !
 
230
 
 
231
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/14/2022 11:31:35'!
 
232
order: aNumber
 
233
        order _ aNumber ! !
 
234
 
 
235
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:48:26'!
 
236
selector
 
237
        ^ selector ! !
 
238
 
 
239
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:49:10'!
 
240
selector: aSymbol 
 
241
        selector _ aSymbol! !
 
242
 
 
243
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:48:18'!
 
244
target
 
245
        ^ target! !
 
246
 
 
247
!CommandRecord methodsFor: 'accessing' stamp: 'hlsf 7/23/2022 22:48:58'!
 
248
target: anObject
 
249
        target _ anObject! !
 
250
 
 
251
!CommandRecord methodsFor: 'printing' stamp: 'hlsf 7/15/2022 17:26:20'!
 
252
printOn: aStream
 
253
        super printOn: aStream.
 
254
        aStream 
 
255
                nextPut: $(;
 
256
                nextPutAll: id printString ;
 
257
                nextPutAll: ', order=';
 
258
                nextPutAll: order printString;
 
259
                nextPut: $)! !
 
260
 
 
261
!CommandRecord class methodsFor: 'instance creation' stamp: 'hlsf 7/14/2022 19:50:19'!
 
262
id: uniqueIndentifer
 
263
        ^ self new ::
 
264
                id: uniqueIndentifer asSymbol;
 
265
                label: uniqueIndentifer asString;
 
266
                yourself! !