forked from emacsmirror/auctex
-
Notifications
You must be signed in to change notification settings - Fork 0
/
toolbar-x.el
1565 lines (1412 loc) · 70.2 KB
/
toolbar-x.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; toolbar-x.el --- fancy toolbar handling in Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2022 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.
;; This program is distributed in the hope that it will be
;; useful, but WITHOUT ANY WARRANTY; without even the implied
;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE. See the GNU General Public License for more details.
;; You should have received a copy of the GNU General Public
;; License along with this program; if not, write to the Free
;; Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
;; MA 02110-1301 USA
;;; Author: Miguel Vinicius Santini Frasson
;;; Commentary:
;; This program implements a common interface to display toolbar
;; buttons. A toolbar should be basically
;; defined by a image and a command to run when the button is pressed,
;; and additional properties could be added. This is the idea of this
;; program. See the documentation of function
;; `toolbarx-install-toolbar' for a description of how to specify
;; toolbars.
;;; Features:
;; * Button properties are given in the toolbar definition (BUTTON
;; paramenter in `toolbarx-install-toolbar') and/or in an alist with
;; associates the symbol with properties (MEANING-ALIST paramenter in
;; `toolbarx-install-toolbar').
;; * Supported properties:
;; - `:insert', `:image', `:command', `:help', `:enable',
;; `:append-command', `:prepend-command',
;; `:visible' and `:button';
;; For the precise value-type for each property, see documentation of
;; the function `toolbarx-install-toolbar'.
;; (ps: properties that are particular to an editor are just ignored
;; the other editor flavour.)
;; * Properties can have value specified by function (with no
;; argument) or variables that evaluate to an object of the correct
;; type for a particular property. The evaluation is done when the
;; roolbar is refresh (a call of `toolbarx-refresh'.)
;; (ps: this is valid only for properties that *not* have \`form\' as
;; value type.)
;; * On `refresh time' (a call `toolbarx-refresh', necessary when the
;; toolbar should change), the `:insert' property (if present) is
;; evaluated to decide if button will be displayed.
;; Properties can be distributed to several buttons, using \`groups\'.
;; Example: (foo (bar baz :enable (mytest)) :help "please")
;; means that `foo', `bar' and `baz' have `:help "please"' and `bar' and
;; `baz' have the property `:enable (mytest)'.
;; * (Part of) the toolbar definition can be stored in a variable,
;; evaluated in `installation time'. See `:eval-group' on the
;; documentation of the function `toolbarx-install-toolbar'.
;; * It is possible to define sets of buttons that appear according to
;; an option selected in a dropdown menu. See `:dropdown-group' on
;; the documentation of the function `toolbarx-install-toolbar'.
;;; Rough description of the implementation
;; There are 2 \`engines\' implemented:
;; == the 1st one (parsing) parses the toolbar definition
;; independently of editor flavour and store the parsed buttons with
;; their properties, in the same order that they appear in the
;; definitions, in a variable `toolbarx-internal-button-switches';
;; == the 2nd one (refresh for Emacs) inserts buttons in the Emacs
;; toolbar in the same order that they appear in the definitions;
;; if a (real) button does not have at least (valid) image
;; and command properties, they are silently ignored;
;;; History:
;; This program was motivated by the intention of implementation of a
;; good toolbar for AUCTeX, that would work in both Emacs and XEmacs.
;; Since toolbars were very different in behaviour and implementation
;; (for instance, in Emacs one can display as many toolbar buttons as
;; wanted, because it becomes mult-line, and in XEmacs, there is one
;; line, but toolbars and all sides of a frame.)
;;; Code:
(eval-when-compile
(require 'cl-lib))
;; Note that this just gives a useful default. Icons are expected to
;; be in subdirectory "images" or "toolbar" relative to the load-path.
;; Packages loading toolbarx are advised to explicitly add their own
;; searchpath with add-to-list here even when they fulfill that
;; criterion: another package might have loaded toolbar-x previously
;; when load-path was not yet correctly set. The default setting
;; really caters only for toolbar-x' stock icons.
(defvar toolbarx-image-path
(nconc
(delq nil (mapcar #'(lambda(x)
(and x
(member
(file-name-nondirectory
(directory-file-name x))
'("toolbar" "images"))
;;(file-directory-p x)
x))
load-path))
(list data-directory))
"List of directories where toolbarx finds its images.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; First engine: Parsing buttons
;; it obtains button information, process it and stores result in
;; `toolbarx-internal-button-switches', which is a list with 1st
;; element the symbol `:switches', the 2nd element as a list of
;; processed buttons, and the 3rd element is used for Emacs to store
;; the keys used in ``constant'' buttons.
;; The 2nd element of `toolbarx-internal-button-switches' is a list
;; where each element is either:
;; * a button-list, that is, a list with elements to define a button.
;; * a list where 1st elem is `:insert' and 2nd is a form, and the
;; following elements are in the same format of the 2nd element of
;; `toolbarx-internal-button-switches'.
(defun toolbarx-make-string-from-symbol (symbol)
"Return a string from the name of a SYMBOL.
Upcase initials and replace dashes by spaces."
(let* ((str (upcase-initials (symbol-name symbol)))
(str2))
(dolist (i (append str nil))
(if (eq i 45) ; if dash, push space
(push 32 str2)
(push i str2))) ; else push identical
(concat (nreverse str2))))
(defun toolbarx-make-symbol-from-string (string)
"Return a (intern) symbol from STRING.
Downcase string and replace spaces by dashes."
(let* ((str1 (append (downcase string) nil))
(str2))
(dolist (i str1)
(if (eq i 32) ; if dash, push space
(push 45 str2)
(push i str2)))
(intern (concat (nreverse str2)))))
(defun toolbarx-good-option-list-p (option-list valid-options)
"Non-nil means the OPTION-LIST is of form (OPT FORM ... OPT FORM).
Each OPT is member of VALID-OPTIONS and OPT are pairwise
different. OPTION-LIST equal to nil is a good option list."
(let ((elt-in-valid t)
(temp-opt-list option-list)
(list-diff)
(n (/ (length option-list) 2)))
(dotimes (i n)
(when (> i 0)
(setq temp-opt-list (cddr temp-opt-list)))
(cl-pushnew (car temp-opt-list) list-diff :test #'equal)
(setq elt-in-valid (and elt-in-valid
(memq (car temp-opt-list)
valid-options))))
(and elt-in-valid ; options are on VALID-OPTOPNS
;; OPTION-LIST has all option different from each other
(eq (length list-diff) n)
;; OPTION-LIST has even number of elements
(eq (% (length option-list) 2) 0))))
(defun toolbarx-separate-options (group-list valid-options &optional check)
"Return a cons cell with non-options and options of GROUP-LIST.
The options-part is the largest tail of the list GROUP-LIST that
has an element of VALID-OPTIONS (the comparation is made with
`memq'.) The non-options-part is the beginning of GROUP-LIST
less its tail. Return a cons cell which `car' is the
non-options-part and the `cdr' is the options-part.
If CHECK is non-nil, the tail is the largest that yield non-nil
when applied to `toolbarx-good-option-list-p'."
(let ((maximal)
(temp))
(dolist (i valid-options)
(setq temp (memq i group-list))
(when (and (> (length temp) (length maximal))
(if check
(toolbarx-good-option-list-p temp valid-options)
t))
(setq maximal (memq i group-list))))
(cons (butlast group-list (length maximal)) maximal)))
(defun toolbarx-merge-props (inner-props outer-props override add)
"Merge property lists INNER-PROPS and OUTER-PROPS.
INNER-PROPS and OUTER-PROPS are two lists in the format
(PROP VAL PROP VAL ... PROP VAL).
Returns a list with properties and values merged.
OVERRIDE and ADD are supposed to be lists of symbols. The value
of a property in OVERRIDE is the one on OUTER-PROPS or
INNER-PROPS, but if the property is in both, the value in
INNER-PROPS is used. The value of a property in ADD will be a
list with first element the symbol `:add-value-list' and the rest
are the properties, inner properties first."
(let* ((merged)
(inner-prop)
(outer-prop))
(dolist (prop override)
(if (memq prop inner-props)
(setq merged (append merged
(list prop (cadr (memq prop inner-props)))))
(when (memq prop outer-props)
(setq merged (append merged
(list prop (cadr (memq prop outer-props))))))))
(dolist (prop add merged)
(setq inner-prop (memq prop inner-props))
(when inner-prop
(if (and (listp (cadr inner-prop))
(eq (car (cadr inner-prop)) :add-value-list))
(setq inner-prop (cdr (cadr inner-prop)))
(setq inner-prop (list (cadr inner-prop)))))
(setq outer-prop (memq prop outer-props))
(when outer-prop
(if (and (listp (cadr outer-prop))
(eq (car (cadr outer-prop)) :add-value-list))
(setq outer-prop (cdr (cadr outer-prop)))
(setq outer-prop (list (cadr outer-prop)))))
(when (append inner-prop outer-prop)
(setq merged (append merged
(list prop (cons :add-value-list
(append inner-prop
outer-prop)))))))))
(defun toolbarx-make-command (comm prep app)
"Return a command made from COMM, PREP and APP.
COMM is a command or a form. PREP and APP are forms. If PREP or
APP are non-nil, they are added to the resulting command at the
beginning and end, respectively. If both are nil and COMM is a
command, COMM is returned."
(let ((comm-is-command (commandp comm)))
(if (and (not prep)
(not app)
comm-is-command)
comm
(lambda () (interactive)
(let (result)
(when prep (setq result (eval prep t)))
(when comm (setq result
(if comm-is-command
(call-interactively comm)
(eval comm t))))
(when app (setq result (eval app t)))
result)))))
(defun toolbarx-emacs-mount-popup-menu
(strings var type &optional title save)
"Return an interactive `lambda'-expression that shows a popup menu.
This function is the action of `toolbarx-mount-popup-menu' if
inside Emacs. See documentation of that function for more."
;; making the menu keymap by adding each menu-item definition
;; see (info "(elisp)Menu keymaps")
(let* ((keymap (make-sparse-keymap title))
(count 1)
(used-symbols '(nil))
(key)
(real-type
(pcase type
((or `toggle `radio) type)
;; Warn if type is not `radio' or `toggle'.
(_ (display-warning 'toolbarx
(format "TYPE should be symbols `radio' or `toggle', but %s found; using `radio'"
type))
;; Use `radio' if incorrect.
'radio)))
(real-save
(pcase save
((or `nil `offer `always) save)
;; Warn if save is not `nil', `offer' or ;; `always'.
(_ (display-warning 'toolbarx
(format "SAVE should be symbols `nil', `offer' or `always', but %s found; using `nil'"
save))
;; Use nil when incorrect.
nil))))
(dolist (i strings)
;; finding a new symbol
(let* ((aux-count 0)
(i-symb (toolbarx-make-symbol-from-string i)))
(setq key i-symb)
(while (memq key used-symbols)
(setq aux-count (1+ aux-count))
(setq key (intern (format "%s-%d" i-symb aux-count))))
(setq used-symbols (cons key used-symbols)))
(define-key-after keymap (vector key)
`(menu-item ,i
,(let ((count count))
(lambda () (interactive)
(set var
(if (eq real-type 'radio)
count
(if (memq count (symbol-value var))
(delete count (symbol-value var))
(sort (cons count (symbol-value var)) #'<))))
(toolbarx-refresh)
(when (eq real-save 'always)
(customize-save-variable var (symbol-value var)))
(symbol-value var)))
:button ,(if (eq real-type 'radio)
`(:radio eq ,var ,count)
`(:toggle memq ,count ,var))))
(setq count (1+ count)))
(when (eq real-save 'offer)
(define-key-after keymap [sep] '(menu-item "--shadow-etched-in-dash"))
(let* ((aux-count 0)
(i-symb 'custom-save))
(setq key i-symb)
(while (memq key used-symbols)
(setq aux-count (1+ aux-count))
(setq key (intern (format "%s-%d" i-symb aux-count))))
(setq used-symbols (cons key used-symbols)))
(define-key-after keymap (vector key)
`(menu-item "Save state of this menu"
(lambda nil (interactive)
(customize-save-variable (quote ,var) ,var)))))
;; returns a `lambda'-expression
(lambda () (interactive) (popup-menu keymap))))
(defun toolbarx-mount-popup-menu (strings var type &optional title save)
"Return a command that show a popup menu.
The return is a `lambda'-expression with a interactive declaration.
STRINGS is a list of strings which will be the itens of the menu.
VAR is a symbol that is set when an item is clicked. TYPE should
be one of the symbols `radio' or `toggle': `radio' means that the
nth item is selected if VAR is `n' and this item sets VAR to `n';
`toggle' means that VAR should be a list of integers and the nth
item is selected if `n' belongs to VAR. The item inserts or
deletes `n' from VAR.
TITLE is a string (the title of the popup menu) or nil for no
title.
SAVE is one of the symbols nil, `offer' or `always'. If value
is nil, do not try to save anything. If it is `offer', a menu
item is added offering the user the possibiity to save state of
that dropdown menu for future sesseions (using `custom'). If it
is `always', state is saved every time that a item is clicked."
(toolbarx-emacs-mount-popup-menu strings var type title save))
(defun toolbarx-option-value (opt)
"If OPT is a vector, return first element, otherwise, return OPT.
If OPT is vector and length is smaller than the necessary, then
nil is returned."
;; FIXME: This is backward compatibility for when we supported XEmacs
;; and entries could take the shape [FOO BAR] where FOO was the
;; value to use for Emacs and BAR the value to use for XEmacs.
;; This is unused since Mar 2021.
(if (vectorp opt)
(when (> (length opt) 0)
(aref opt 0))
opt))
(defun toolbarx-eval-function-or-symbol (object type-test-func)
"Return a cons cell (GOOD-OBJ . VAL).
GOOD-OBJ non-nil means that VAL is a valid value, according to
the car of the result of TYPE-TEST-FUNCTION, that should return a
cons cell in the same format as the return of this function.
If OBJECT applied to TYPE-TEST-FUNC return (GOOD-OBJ . VAL), and
GOOD-OBJ is non-nil, return that. Else, check if OBJECT is a
function. If so, evaluate and test again with TYPE-TEST-FUNC. If
not a function or if GOOD-OBJ is again nil, test if OBJECT is a
bound symbol, evaluate that and return the result of
TYPE-TEST-FUNC."
(let* ((ret (funcall type-test-func object)))
(unless (car ret)
(if (functionp object)
(progn
(setq ret (funcall type-test-func (funcall object)))
(unless (car ret)
(when (and (symbolp object) (boundp object))
(setq ret (funcall type-test-func (symbol-value object))))))
;; ok, obj is not function; try symbol
(when (and (symbolp object) (boundp object))
(setq ret (funcall type-test-func (symbol-value object))))))
ret))
(defun toolbarx-test-image-type (obj)
"Return a cons cell (GOOD-OBJ . VAL).
GOOD-OBJ is non-nil if OBJ yields a valid image object VAL (see
documentation of function `toolbarx-process-symbol')."
(let ((toolbarx-test-image-type-simple
(lambda (img)
(let* ((val (toolbarx-option-value img))
(all-obj-ok t)
(good-obj
(or (stringp val) ; string
(eq (car-safe val) 'image) ; or image descriptor
(and (symbolp val) ; or a symbol bound to a
(boundp val) ; image descriptor
; (defined with `defimage')
(consp (symbol-value val))
(eq (car (symbol-value val)) 'image))
(and (listp val) ; or list with 4 strings or
; image descriptors
(= (length val) 4)
(dolist (i val all-obj-ok)
(setq all-obj-ok
(and all-obj-ok
(or (stringp i)
(eq (car-safe i) 'image)))))))))
(cons good-obj val)))))
(toolbarx-eval-function-or-symbol obj toolbarx-test-image-type-simple)))
(defun toolbarx-test-button-type (obj)
"Return a cons cell (GOOD-OBJ . VAL).
GOOD-OBJ is non-nil if OBJ yields a valid button object VAL (see
documentation of function `toolbarx-process-symbol')."
(let ((toolbarx-test-button-type-simple
(lambda (but)
(let* ((val (toolbarx-option-value but))
(good-obj
(and (consp val)
(memq (car val) '(:toggle :radio)))))
(cons good-obj val)))))
(toolbarx-eval-function-or-symbol obj toolbarx-test-button-type-simple)))
(defun toolbarx-test-any-type (obj)
"Return a cons cell (t . VAL).
If OBJ is vector, return VAL according to editor. Else, return
OBJ, because it is a form anyway."
(cons t (toolbarx-option-value obj)))
(defun toolbarx-test-string-or-nil (obj)
"Return a cons cell (GOOD-OBJ . VAL).
GOOD-OBJ is non-nil if OBJ yields a valid help object VAL (see
documentation of function `toolbarx-process-symbol')."
(let ((toolbarx-test-string-or-nil-simple
(lambda (obj)
(let* ((val (toolbarx-option-value obj))
(good-obj (or (stringp val)
(not val))))
(cons good-obj val)))))
(toolbarx-eval-function-or-symbol obj toolbarx-test-string-or-nil-simple)))
(defun toolbarx-test-toolbar-type (obj)
"Return a cons cell (GOOD-OBJ . VAL).
GOOD-OBJ is non-nil if OBJ yields a valid toolbar property object
VAL (see documentation of function `toolbarx-process-symbol')."
(let ((toolbarx-test-toolbar-type-simple
(lambda (obj)
(let* ((val (toolbarx-option-value obj))
;; (all-but-def-opts '(top bottom left right))
;; (all-opts '(default top bottom left right))
;; (good-obj t)
)
(cons t val)))))
(toolbarx-eval-function-or-symbol obj toolbarx-test-toolbar-type-simple)))
(defun toolbarx-test-dropdown-type (obj)
"Return a cons cell (GOOD-OBJ . VAL).
GOOD-OBJ is non-nil if OBJ yields a valid `:type' property object
VAL of a dropdown group (see documentation of function
`toolbarx-process-dropdown-group'."
(let ((toolbarx-test-dropdown-type-simple
(lambda (obj)
(let* ((val (toolbarx-option-value obj))
(good-obj (memq val '(radio toggle))))
(cons good-obj val)))))
(toolbarx-eval-function-or-symbol obj toolbarx-test-dropdown-type-simple)))
(defun toolbarx-test-symbol (obj)
"Return a cons cell (GOOD-OBJ . VAL).
GOOD-OBJ is non-nil if OBJ yields a valid `:variable' property
object VAL of a dropdown group (see documentation of function
`toolbarx-process-dropdown-group'."
(let ((toolbarx-test-symbol-simple
(lambda (obj)
(let* ((val (toolbarx-option-value obj))
(good-obj (symbolp val)))
(cons good-obj val)))))
(toolbarx-eval-function-or-symbol obj toolbarx-test-symbol-simple)))
(defun toolbarx-test-dropdown-default (obj)
"Return a cons cell (GOOD-OBJ . VAL).
GOOD-OBJ is non-nil if OBJ yields a valid `:default' property
object VAL of a dropdown group (see documentation of function
`toolbarx-process-dropdown-group'."
(let ((toolbarx-test-dropdown-default-simple
(lambda (obj)
(let* ((val (toolbarx-option-value obj))
(good-obj (or (integerp val)
(and (listp val)
(let ((ok t))
(dolist (i val ok)
(setq ok (and ok (integerp i)))))))))
(cons good-obj val)))))
(toolbarx-eval-function-or-symbol obj
toolbarx-test-dropdown-default-simple)))
(defun toolbarx-test-dropdown-save (obj)
"Return a cons cell (GOOD-OBJ . VAL).
GOOD-OBJ is non-nil if OBJ yields a valid `:save' property
object VAL of a dropdown group (see documentation of function
`toolbarx-process-dropdown-group'."
(let ((toolbarx-test-dropdown-save-simple
(lambda (obj)
(let* ((val (toolbarx-option-value obj))
(good-obj (memq val '(nil offer always))))
(cons good-obj val)))))
(toolbarx-eval-function-or-symbol obj toolbarx-test-dropdown-save-simple)))
(defconst toolbarx-button-props
(let* ((props-types-alist
'((:image toolbarx-test-image-type)
(:command toolbarx-test-any-type)
(:enable toolbarx-test-any-type)
(:visible toolbarx-test-any-type)
(:help toolbarx-test-string-or-nil)
(:insert toolbarx-test-any-type . and)
;; (:toolbar toolbarx-test-toolbar-type)
(:button toolbarx-test-button-type)
(:append-command toolbarx-test-any-type . progn)
(:prepend-command toolbarx-test-any-type . progn)))
(possible-props (nreverse (let* ((props ()))
(dolist (p props-types-alist props)
(setq props (cons (car p) props))))))
(props-override (nreverse (let* ((props ()))
(dolist (p props-types-alist props)
(unless (cddr p)
(setq props (cons (car p) props)))))))
(props-add (nreverse (let* ((props ()))
(dolist (p props-types-alist props)
(when (cddr p)
(setq props (cons (car p) props))))))))
(list props-types-alist possible-props props-override props-add))
"List yielding all encarnations of properties of a button.
First element: alist, where each element is of form
(PROP . (TYPE-TEST-FUNCTION . ADD-OR-NIL))
Second is a list with all properties.
Third, a list with properties that override when merging.
Fourth, a list of lists, each in the format (PROP ADD).")
(defconst toolbarx-dropdown-props
;; for naming dropdown properties see `Convention' in the doc string
(let* ((props-types-alist
'((:type toolbarx-test-dropdown-type)
(:variable toolbarx-test-symbol)
(:default toolbarx-test-dropdown-default)
(:save toolbarx-test-dropdown-save)
(:title toolbarx-test-string-or-nil)
(:dropdown-image toolbarx-test-image-type)
(:dropdown-enable toolbarx-test-any-type)
(:dropdown-visible toolbarx-test-any-type)
(:dropdown-insert toolbarx-test-any-type . and)
(:dropdown-help toolbarx-test-string-or-nil)
;; (:dropdown-toolbar toolbarx-test-toolbar-type)
(:dropdown-append-command toolbarx-test-any-type . progn)
(:dropdown-prepend-command toolbarx-test-any-type . progn)))
(possible-props (nreverse (let* ((props ()))
(dolist (p props-types-alist props)
(setq props (cons (car p) props))))))
(props-override (nreverse (let* ((props ()))
(dolist (p props-types-alist props)
(unless (cddr p)
(setq props (cons (car p) props)))))))
(props-add (nreverse (let* ((props ()))
(dolist (p props-types-alist props)
(when (cddr p)
(setq props (cons (car p) props))))))))
(list props-types-alist possible-props props-override props-add))
"List yielding all encarnations of properties of a dropdown group.
First element: alist, where each element is of form
(PROP . (TYPE-TEST-FUNCTION . ADD-OR-NIL))
Second is a list with all properties.
Third, a list with properties that override when merging.
Fourth, a list of lists, each in the format (PROP ADD).
Convention: properties for the dropdown button should be formed
with the strings \":dropdown-\" with the button property name
without `:'. This is used on the implementation.")
(defun toolbarx-process-group-without-insert (group-without-props
merged-props-without-insert
meaning-alist switches)
"Return an updated version of SWITCHES.
GROUP-WITHOUT-PROPS and MERGED-PROPS-WITHOUT-INSERT are
preprocessed variables in `toolbarx-process-group'."
(let ((current-switches switches))
(dolist (i group-without-props current-switches)
(setq i (toolbarx-option-value i))
(if (symbolp i)
(setq current-switches
(toolbarx-process-symbol i meaning-alist
merged-props-without-insert
current-switches))
(when (listp i)
(setq current-switches
(toolbarx-process-group i meaning-alist
merged-props-without-insert
current-switches)))))))
(defun toolbarx-process-group (group meaning-alist props switches)
"Return an updated version of SWITCHES.
Append to already processed buttons (stored in SWITCHES) a
processed version of GROUP. Groups are useful to distribute
properties. External properties are given in PROPS, and merged
with the internal properties that are in the end of GROUP. If
properties (after merge) contain a `:insert' property, return a
list where the first and second elements are `:insert' and its
value, and after that a list in the same format as SWITCHES."
(cond
;; if DROPDOWN group
((eq (car group) :dropdown-group)
(toolbarx-process-dropdown-group group meaning-alist props switches))
;; if EVAL group
((eq (car group) :eval-group)
(let ((current-switches switches))
(dolist (elt (cdr group) current-switches)
(let ((eval-elt (eval elt t)))
(setq current-switches
(toolbarx-process-group (if (listp eval-elt)
eval-elt
(list eval-elt))
meaning-alist props
current-switches))))))
;; if normal group
(t
(let* ((splited-props
(toolbarx-separate-options
group (append (nth 1 toolbarx-button-props)
(nth 1 toolbarx-dropdown-props))))
(intern-props (cdr splited-props))
(group-without-props (car splited-props))
(merged-props
(toolbarx-merge-props intern-props props
(append (nth 2 toolbarx-button-props)
(nth 2 toolbarx-dropdown-props))
(append (nth 3 toolbarx-button-props)
(nth 3 toolbarx-dropdown-props)))))
;; check whether merged props have an `:insert'
(if (memq :insert merged-props)
;; if yes, prepend switches with a (:insert cond elements)
(let* ((memq-ins (memq :insert merged-props))
(ins-val (if (and (listp (cadr memq-ins))
(eq :add-value-list
(car (cadr memq-ins))))
;; if property is add-value property
(let* ((p (assq
:insert
(nth 0 toolbarx-button-props)))
(add-list (list (cddr p)))
(prop-good-val))
(dolist (val (cdr (cadr memq-ins)))
(setq prop-good-val (funcall (cadr p) val))
(when (car prop-good-val)
(setq add-list (cons (cdr prop-good-val)
add-list))))
;; return: (nreverse add-list)
(setq add-list (nreverse add-list))
(if (eq 2 (length add-list))
(cadr add-list) ; just 1 value, no
add-list)) ; add-function
;; if property is not add-value
(cadr memq-ins)))
(merged-props-without-insert
(append (butlast merged-props (length memq-ins))
(cddr memq-ins)))
(group-switches
(toolbarx-process-group-without-insert
group-without-props merged-props-without-insert
meaning-alist nil)))
;; return
(nreverse (cons (append (list :insert ins-val)
group-switches)
(nreverse switches))))
;; if not, just append what is processed to switches
(toolbarx-process-group-without-insert group-without-props
merged-props meaning-alist
switches))))))
(defun toolbarx-process-symbol (symbol meaning-alist props switches)
"Process a button given by SYMBOL in MEANING-ALIST.
The processed button is appended in SWITCHES, which is returned.
Look for a association of SYMBOL in MEANING-ALIST for collecting
properties. Such association is a list that represents either a
normal button (a description of the button) or an alias
group (the symbol is an alias for a group of buttons). PROPS is
a externel list of properties that are merged and then applied to
the button. Scope is given by GLOBAL-FLAG."
;; there are 3 situations: symbol is :new-line, there is an alias group
;; or a normal button
(let ((button-assq (cdr (assq symbol meaning-alist))))
(cond
((eq (car button-assq) :alias)
;; button association is ALIAS GROUP is passed to
;; `toolbarx-process-group' as is but without the car.
;; return: (toolbarx-process-group... returns updates switch
(toolbarx-process-group (cdr button-assq) meaning-alist props switches))
(t
;; NORMAL BUTTON (association is a list of properties)
;;
;; properties need to be processed, that is, merge internal
;; and external (given by PROPS) properties
(let* (;; button properties defined in `toolbarx-button-props'
(props-override (nth 2 toolbarx-button-props))
(props-add (nth 3 toolbarx-button-props))
;; split considering also dropdown-group properties
(button-assq-split
(toolbarx-separate-options
button-assq
(append (nth 1 toolbarx-button-props)
(nth 1 toolbarx-dropdown-props))))
(button-split-no-props (car button-assq-split))
(button-split-props (cdr button-assq-split))
;; if there is no :image or :command in the props,
;; try to get them from no-props part
(button-image-no-prop
(unless (memq :image button-split-props)
(when (> (length button-split-no-props) 0)
(list :image (nth 0 button-split-no-props)))))
(button-command-no-prop
(unless (memq :command button-split-props)
(when (> (length button-split-no-props) 1)
(list :command (nth 1 button-split-no-props)))))
(button-props (append button-split-props
button-image-no-prop
button-command-no-prop))
;; merge props
(merged-props (toolbarx-merge-props button-props props
props-override
props-add)))
;; return:
(nreverse (cons (cons symbol merged-props) (nreverse switches))))))))
(defun toolbarx-process-dropdown-group (dropdown meaning-alist props switches)
"Process buttons that appear according to dropdown menu.
Process a dropdown group DROPDOWN with meaning alist
MEANING-ALIST, external property list PROP and GLOBAL-FLAG
specifying scope. For a complete description, see documentation
of `toolbarx-install-toolbar'. The processed buttons are stored
in the end of SWITCHES, which is returned."
(let* ((dropdown-group (if (eq (car dropdown) :dropdown-group)
(cdr dropdown)
dropdown))
(dropdown-list-splited
(toolbarx-separate-options dropdown-group
(append
(nth 1 toolbarx-button-props)
(nth 1 toolbarx-dropdown-props))))
(dropdown-list (car dropdown-list-splited))
(dropdown-props (cdr dropdown-list-splited))
(merged-props
(toolbarx-merge-props dropdown-props props
(append (nth 2 toolbarx-button-props)
(nth 2 toolbarx-dropdown-props))
(append (nth 3 toolbarx-button-props)
(nth 3 toolbarx-dropdown-props))))
(merged-props-button-only
(let* ((props-button-only)
(prop))
(dolist (p (nth 1 toolbarx-button-props) props-button-only)
(setq prop (memq p merged-props))
(when prop
(setq props-button-only
(append (list p (cadr prop))
props-button-only))))))
(merged-props-dropdown-only
(let* ((props-dropdown-only)
(prop))
(dolist (p (nth 1 toolbarx-dropdown-props) props-dropdown-only)
(setq prop (memq p merged-props))
(when prop
(setq props-dropdown-only
(append (list p (cadr prop))
props-dropdown-only))))))
;; get value for each property and check type ONLY for props that do
;; not concern the dropdown button, like `:type', `:save', etc. The
;; props that concern the button are going to be handled in refresh
;; time.
(filtered-dropdown-group-props-only
(let* ((filtered-props-temp)
(prop-good-val)
(prop))
(save-match-data
(dolist (p (nth 0 toolbarx-dropdown-props) filtered-props-temp)
(unless (string-match "^:dropdown-.*$"
(symbol-name (car p)))
;; property -> (car p)
;; test type function -> (cadr p)
(setq prop (memq (car p) merged-props-dropdown-only))
;; if so, check if value is of correct type
(when prop
(setq prop-good-val (funcall (cadr p) (cadr prop)))
(if (car prop-good-val)
(setq filtered-props-temp
(append filtered-props-temp
(list (car p) (cdr prop-good-val))))
(display-warning
'toolbarx
(format (concat "Wrong type for value in "
"property `%s' in dropdown group")
(car p))))))))))
;; properties for the dropdown button from dropdown merged properties
(dropdown-button-props
(let* ((props))
(save-match-data
(dolist (pr (nth 1 toolbarx-dropdown-props))
(when (and (memq pr merged-props-dropdown-only)
(string-match "^:dropdown-\\(.*\\)$"
(symbol-name pr)))
(let* ((new-pr (intern (concat ":"
(substring (symbol-name pr)
(match-beginning 1)
(match-end 1)))))
(val (cadr (memq pr merged-props-dropdown-only))))
(setq props (append (list new-pr val) props))))))
(unless (memq :image props)
(setq props (append (list :image "dropdown") props)))
props))
(dropdown-button-without-command
(cons 'dropdown dropdown-button-props))
;; `:type' defaults to `radio'
(type (if (memq :type filtered-dropdown-group-props-only)
(cadr (memq :type filtered-dropdown-group-props-only))
'radio))
;; `:default' defaults to 1 or nil depending on `type'
;; if type is toggle and default is not a list, but a
;; integer, set as the list with integer
(default
(let* ((memq-default (memq :default
filtered-dropdown-group-props-only))
(def-temp (cadr memq-default))
(default-temp (if memq-default
def-temp
(if (eq type 'radio) 1 (list 1)))))
default-temp))
;; `:save' defaults to nil and require `:variable'
(save (let* ((save-temp
(when (memq :save filtered-dropdown-group-props-only)
(cadr (memq :save
filtered-dropdown-group-props-only)))))
(if (and save-temp
(not (memq :variable
filtered-dropdown-group-props-only)))
(progn
(display-warning
'toolbarx
(concat "`:save' property with non-nil value should "
"be used only with the `:variable' property; "
"using value nil for `:save'."))
nil)
save-temp)))
;; `:title' defaults to nil
(title (when (memq :title filtered-dropdown-group-props-only)
(cadr (memq :title filtered-dropdown-group-props-only))))
;; the menu variable is buildt from the `:variable' option or
;; make a symbol not used
(variable (if (memq :variable filtered-dropdown-group-props-only)
(cadr (memq :variable
filtered-dropdown-group-props-only))
(let* ((count 0)
(symb (intern (format
"toolbarx-internal-menu-var-%d"
count))))
(while (boundp symb)
(setq count (1+ count))
(setq symb
(intern (format "toolbarx-internal-menu-var-%d"
count))))
symb)))
;; auxiliary variables
(list-strings)
(list-buttons))
;; setting `variable'
(if save
(custom-declare-variable
variable default
"Used as variable of dropdown menu defined with `toolbarx'.")
(when (not (boundp variable))
(set variable default)))
;; now check `variable' content
(set variable
(let ((val (symbol-value variable)))
(if (eq type 'toggle)
(if (listp val)
val
(if (integerp val)
(list val)
(list 1)))
;; then, type is radio
(if (integerp val)
val
(if (and val
(listp val)
(integerp (car val)))
(car val)
1)))))
;; === buiding `list-strings' and `list-buttons' ===
;; if only symbols, build `list-strings' and `list-buttons' from symbols
(if (let ((only-symbols-flag t))
(dolist (i dropdown-list only-symbols-flag)
(setq only-symbols-flag (and only-symbols-flag (symbolp i)))))
(let ((count 0))
(dolist (i dropdown-list)
;; list-strings and list-buttons are built reversed
(setq list-strings (cons (toolbarx-make-string-from-symbol i)
list-strings))
(setq count (1+ count))
(setq list-buttons (cons (list i
:insert
(if (eq type 'radio)
(list 'eq count variable)
(list 'memq count variable)))
list-buttons))))
;; if not, the it must start with string
(unless (stringp (car dropdown-list))
(error "%s %s %s"
"If not all items on dropdown are symbols, then a string"
"must come before each set of buttons; no string found"
"in first position"))
(let ((count 0)
(elem)
(temp-list-buttons))
(while dropdown-list
(setq elem (car dropdown-list))
(setq dropdown-list (cdr dropdown-list))
(if (stringp elem)
;; if string, output `temp-list-buttons' and prepair it again
(progn
;; list-strings and list-buttons are buildt reversed
(setq list-strings (cons elem list-strings))
(when temp-list-buttons
(setq list-buttons (cons (append (nreverse temp-list-buttons)
(list :insert
(if (eq type 'radio)
(list 'eq count
variable)
(list 'memq count
variable))))
list-buttons)))
(setq temp-list-buttons nil)
(setq count (1+ count)))
;; else, if not string, just insert it to `temp-list-buttons'
;; which is also buildt reversed
(setq temp-list-buttons (cons elem temp-list-buttons))))
;; output last temp list, left behind
(when temp-list-buttons
(setq list-buttons (cons (append (nreverse
temp-list-buttons)
(list
:insert (if (eq type 'radio)
(list 'eq count
variable)
(list 'memq count
variable))))
list-buttons)))))
;; lists were made reversed (elements inserted at the beginning)
(setq list-strings (nreverse list-strings))
(setq list-buttons (nreverse list-buttons))
;; now, pass `list-buttons' as a group to `toolbarx-process-group'
(let ((current-switches switches))
(setq current-switches
(toolbarx-process-group list-buttons meaning-alist
merged-props ; pass non-processed props
current-switches))
(setq current-switches
;; outputing dropdown button
(toolbarx-process-group (append dropdown-button-without-command
(list :command
(toolbarx-mount-popup-menu
list-strings variable type
title save)))
meaning-alist merged-props-button-only
switches))
current-switches)))
;; Still functions `toolbarx-install-toolbar' and `toolbarx-refresh'to
;; complete the parsing engine. Since they interface with other engines,
;; they must come in the end.
;;; How a image is made, giving a string as (part of) file name.
;; look at function `image-type-available-p' for Emacs !!!!
(defun toolbarx-find-image (image)
"Return image descriptor or glyph for IMAGE.
IMAGE is string. Usually IMAGE neither contains a directory nor