← Back to branch summary

~registry/texmacs/trunk

« back to all changes in this revision

Viewing changes to src/TeXmacs/progs/kernel/gui/menu-widget.scm

  • Committer: mgubi
  • Date: 2009-06-04 15:13:41 UTC
  • Revision ID: svn-v4:64cb5145-927a-446d-8aed-2fb7b4773692:trunk:2717
Support for X11 TeXmacs.app on Mac

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/TeXmacs/progs/kernel/gui/menu-widget.scm
 
1
 
 
2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
3
;;
 
4
;; MODULE      : menu-widget.scm
 
5
;; DESCRIPTION : routines for generating menus
 
6
;; COPYRIGHT   : (C) 2002  Joris van der Hoeven, David Allouche
 
7
;;
 
8
;; This software falls under the GNU general public license version 3 or later.
 
9
;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
 
10
;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
 
11
;;
 
12
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
13
;; See menu-define.scm for the grammar of menus
 
14
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
15
 
 
16
(texmacs-module (kernel gui menu-widget)
 
17
  (:use (kernel gui menu-define) (kernel gui kbd-define)))
 
18
 
 
19
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
20
;; Menu utilities
 
21
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
22
 
 
23
(define (make-menu-error . args)
 
24
  (apply tm-display-error args)
 
25
  (widget-text "Error" (color "black") #t "english"))
 
26
 
 
27
(define (make-menu-bad-format p e?)
 
28
  (make-menu-error "menu has bad format in " (object->string p)))
 
29
 
 
30
(define (make-menu-empty) (widget-hmenu '()))
 
31
 
 
32
(define (delay-command cmd)
 
33
  (object->command (lambda () (exec-delayed cmd))))
 
34
 
 
35
(define-macro (make-menu-command cmd)
 
36
  `(delay-command (lambda ()
 
37
                    (menu-before-action)
 
38
                    ,cmd
 
39
                    (menu-after-action))))
 
40
 
 
41
(define (kbd-find-shortcut what)
 
42
  (with r (kbd-find-inv-binding what)
 
43
    (if (string-contains? r "accent:")
 
44
        (begin
 
45
          (set! r (string-replace r "accent:deadhat" "^"))
 
46
          (set! r (string-replace r "accent:tilde" "~"))
 
47
          (set! r (string-replace r "accent:acute" "'"))
 
48
          (set! r (string-replace r "accent:grave" "`"))
 
49
          (set! r (string-replace r "accent:umlaut" "\""))
 
50
          (set! r (string-replace r "accent:abovedot" "."))
 
51
          (set! r (string-replace r "accent:breve" "U"))
 
52
          (set! r (string-replace r "accent:check" "C"))))
 
53
    r))
 
54
 
 
55
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
56
;; Menu labels
 
57
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
58
 
 
59
(define (make-menu-label p e? . opt)
 
60
  "Make widget for menu label @p."
 
61
  ;; Possibilities for p:
 
62
  ;;   <label> :: (balloon <label> <string>)
 
63
  ;;     Label with a popup balloon. The <string> is the balloon text.
 
64
  ;;   <label> :: (text <font desc> <string>)
 
65
  ;;     Label <string> drawn in black text of an arbitrary font.
 
66
  ;;     <font desc> :: ([family [class [series [shape [size [dpi]]]]]])
 
67
  ;;     Example default values are: family="roman", class="mr",
 
68
  ;;     series="medium", shape="normal", size=10, dpi=600.
 
69
  ;;   <label> :: <string>
 
70
  ;;     Simple menu label, its display style is controlled by tt? and e?
 
71
  ;;   <label> :: (icon <string>)
 
72
  ;;     Pixmap menu label, the <string> is the name of the pixmap.
 
73
  (let ((tt? (and (nnull? opt) (car opt)))
 
74
        (col (color (if e? "black" "dark grey"))))
 
75
    (cond ((string? p)                  ; "text"
 
76
           (widget-text p col #t "english"))
 
77
          ((tuple? p 'balloon 2)        ; (balloon <label> "balloon text")
 
78
           (make-menu-label (cadr p) e? tt?))
 
79
          ((tuple? p 'text 2)           ; (text <font desc> "text")
 
80
           (widget-box (cadr p) (caddr p) col #t #t))
 
81
          ((tuple? p 'icon 1)           ; (icon "name.xpm")
 
82
           (widget-xpm (cadr p))))))
 
83
 
 
84
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
85
;; Elementary menu items
 
86
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
87
 
 
88
(define (make-menu-hsep)
 
89
  "Make @--- menu item."
 
90
  (widget-separator #f))
 
91
 
 
92
(define (make-menu-vsep)
 
93
  "Make @| menu item."
 
94
  (widget-separator #t))
 
95
 
 
96
(define (make-menu-group s)
 
97
  "Make @(group :string?) menu item."
 
98
  (widget-menu-group s "english"))
 
99
 
 
100
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
101
;; Menu entries
 
102
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
103
 
 
104
(define (make-menu-entry-button e? bar? check label short command)
 
105
  (if bar?
 
106
      (widget-menu-button (make-menu-label label e?) command "" "" e?)
 
107
      (widget-menu-button (make-menu-label label e?) command check short e?)))
 
108
 
 
109
(define (make-menu-entry-shortcut label action opt-key)
 
110
  (cond (opt-key opt-key)
 
111
        ((pair? label) "")
 
112
        (else (with source (promise-source action)
 
113
                (if source (kbd-find-shortcut source) "")))))
 
114
 
 
115
(define (make-menu-entry-check-sub result propose)
 
116
  (cond ((string? result) result)
 
117
        (result propose)
 
118
        (else "")))
 
119
 
 
120
(define (make-menu-entry-check opt-check action)
 
121
  (if opt-check
 
122
      (make-menu-entry-check-sub ((cadr opt-check)) (car opt-check))
 
123
      (with source (promise-source action)
 
124
        (cond ((not (and source (pair? source))) "")
 
125
              (else (with prop (property (car source) :check-mark)
 
126
                      (make-menu-entry-check-sub
 
127
                       (and prop (apply (cadr prop) (cdr source)))
 
128
                       (and prop (car prop)))))))))
 
129
 
 
130
(define (make-menu-entry-dots label action)
 
131
  (with source (promise-source action)
 
132
    (if (and source (pair? source) (property (car source) :interactive))
 
133
        (menu-label-add-dots label)
 
134
        label)))
 
135
 
 
136
(define (make-menu-entry-attrs label action opt-key opt-check)
 
137
  (cond ((match? label '(shortcut :%1 :string?))
 
138
         (make-menu-entry-attrs (cadr label) action (caddr label) opt-check))
 
139
        ((match? label '(check :%1 :string? :%1))
 
140
         (make-menu-entry-attrs (cadr label) action opt-key (cddr label)))
 
141
        (else (values label action opt-key opt-check))))
 
142
 
 
143
(define (make-menu-entry-sub p e? bar?)
 
144
  (receive
 
145
      (label action opt-key opt-check)
 
146
      (make-menu-entry-attrs (car p) (cAr p) #f #f)
 
147
    (make-menu-entry-button
 
148
     e? bar?
 
149
     (make-menu-entry-check opt-check action)
 
150
     (make-menu-entry-dots label action)
 
151
     (make-menu-entry-shortcut label action opt-key)
 
152
     (make-menu-command (if e? (apply action '()))))))
 
153
 
 
154
(define (make-menu-entry p e? bar?)
 
155
  "Make @:menu-wide-item menu item."
 
156
  (let ((but (make-menu-entry-sub p e? bar?))
 
157
        (label (car p)))
 
158
    (if (tuple? label 'balloon 2)
 
159
        (widget-balloon but
 
160
                        (widget-text (caddr label) (color "black")
 
161
                                     #t "english"))
 
162
        but)))
 
163
 
 
164
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
165
;; Symbol fields
 
166
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
167
 
 
168
(define (make-menu-symbol-button e? symstring opt-symobj)
 
169
  (let* ((col (color (if e? "black" "dark grey")))
 
170
         (sym (if opt-symobj opt-symobj symstring)))
 
171
    (widget-menu-button (widget-box '() symstring col #t #f)
 
172
                        (make-menu-command (insert sym)) "" "" e?)))
 
173
 
 
174
(define (make-menu-symbol p e?)
 
175
  "Make @(symbol :string? :*) menu item."
 
176
  ;; Possibilities for p:
 
177
  ;;   <menu-symbol> :: (symbol <symbol-string> [<symbol-object>] [<shortcut>])
 
178
  ;;   <symbol-object> :: (<symbol-type> <symbol-name>)
 
179
  ;;   <symbol-type> :: left | right | mid | big
 
180
  ;;   <symbol-name> :: <string>
 
181
  (with (tag symstring . opt) p
 
182
    (let ((error? #f) (opt-shortcut #f) (opt-symobj #f))
 
183
      (for-each
 
184
       (lambda (x)
 
185
         (cond (error? (noop))
 
186
               ((pair? x) (set! opt-symobj x))
 
187
               ((string? x) (set! opt-shortcut x))
 
188
               (else (set! error? #t))))
 
189
       opt)
 
190
      (if error? (make-menu-error "invalid symbol attribute in " p)
 
191
          (let ((sh (or opt-shortcut (kbd-find-shortcut symstring))))
 
192
            (if (== sh "")
 
193
                (make-menu-symbol-button e? symstring opt-symobj)
 
194
                (widget-balloon
 
195
                 (make-menu-symbol-button e? symstring opt-symobj)
 
196
                 (make-menu-label (string-append "Keyboard equivalent: " sh)
 
197
                                  e?))))))))
 
198
 
 
199
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
200
;; Composite menus and submenus
 
201
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
202
 
 
203
(define (make-menu-horizontal p e?)
 
204
  "Make @(horizontal :menu-item-list) menu item."
 
205
  (widget-hmenu (make-menu-items (cadr p) e? #t)))
 
206
 
 
207
(define (make-menu-vertical p e?)
 
208
  "Make @(vertical :menu-item-list) menu item."
 
209
  (widget-vmenu (make-menu-items (cadr p) e? #f)))
 
210
 
 
211
(define (make-menu-submenu p e?)
 
212
  "Make @((:or -> =>) :menu-label :menu-item-list) menu item."
 
213
  (with (tag label . items) p
 
214
    (let ((button
 
215
           ((cond ((== tag '=>) widget-pulldown-button)
 
216
                  ((== tag '->) widget-pullright-button))
 
217
            (make-menu-label label e?)
 
218
            (object->promise-widget
 
219
             (lambda () (make-menu-widget (list 'vertical items) e?))))))
 
220
      (if (tuple? label 'balloon 2)
 
221
          (widget-balloon button
 
222
                          (widget-text (caddr label) (color "black")
 
223
                                       #t "english"))
 
224
          button))))
 
225
 
 
226
(define (make-menu-tile p e?)
 
227
  "Make @(tile :integer? :menu-item-list) menu item."
 
228
  (with (tag width . items) p
 
229
    (widget-tmenu (make-menu-items items e? #f) width)))
 
230
 
 
231
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
232
;; Dynamic menus
 
233
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
234
 
 
235
(define (make-menu-if p e? bar?)
 
236
  "Make @(if :%1 :menu-item-list) menu items."
 
237
  (with (tag pred? . items) p
 
238
    (if (pred?) (make-menu-items-list items e? bar?) '())))
 
239
 
 
240
(define (make-menu-when p e? bar?)
 
241
  "Make @(when :%1 :menu-item-list) menu items."
 
242
  (with (tag pred? . items) p
 
243
    (make-menu-items-list items (and e? (pred?)) bar?)))
 
244
 
 
245
(define (make-menu-link p e? bar?)
 
246
  "Make @(link :%1) menu items."
 
247
  (with linked ((eval (cadr p)))
 
248
    (if linked (make-menu-items linked e? bar?)
 
249
        (make-menu-error "bad link: " (object->string (cadr p))))))
 
250
 
 
251
(define (make-menu-promise p e? bar?)
 
252
  "Make @(promise :%1) menu items."
 
253
  (with value ((cadr p))
 
254
    (if (match? value ':menu-item) (make-menu-items value e? bar?)
 
255
        (make-menu-error "promise did not yield a menu: " value))))
 
256
 
 
257
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
258
;; Main routines for making menu items
 
259
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
260
 
 
261
(define (make-menu-items-list l e? bar?)
 
262
  "Make menu items for each element in @l and append results."
 
263
  (append-map (lambda (p) (make-menu-items p e? bar?)) l))
 
264
 
 
265
(define (make-menu-items p e? bar?)
 
266
  "Make menu items @p. The items are on a bar if @bar? and greyed if not @e?."
 
267
  (if (pair? p)
 
268
      (cond ((string? (car p)) (list (make-menu-entry p e? bar?)))
 
269
            ((symbol? (car p))
 
270
             (with result (ahash-ref make-menu-items-table (car p))
 
271
               (if (or (not result) (not (match? (cdr p) (car result))))
 
272
                   (make-menu-items-list p e? bar?)
 
273
                   ((cadr result) p e? bar?))))
 
274
            ((match? (car p) ':menu-wide-label)
 
275
             (list (make-menu-entry p e? bar?)))
 
276
            (else (make-menu-items-list p e? bar?)))
 
277
      (cond ((== p '---) (list (make-menu-hsep)))
 
278
            ((== p '|) (list (make-menu-vsep)))
 
279
            ((== p '()) p)
 
280
            (else (list (make-menu-bad-format p e?))))))
 
281
 
 
282
(define-table make-menu-items-table
 
283
  (group (:string?) ,(lambda (p e? bar?) (list (make-menu-group (cadr p)))))
 
284
  (symbol (:string? :*) ,(lambda (p e? bar?) (list (make-menu-symbol p e?))))
 
285
  (link (:%1) ,(lambda (p e? bar?) (make-menu-link p e? bar?)))
 
286
  (horizontal (:*) ,(lambda (p e? bar?) (list (make-menu-horizontal p e?))))
 
287
  (vertical (:*) ,(lambda (p e? bar?) (list (make-menu-vertical p e?))))
 
288
  (-> (:menu-label :*) ,(lambda (p e? bar?) (list (make-menu-submenu p e?))))
 
289
  (=> (:menu-label :*) ,(lambda (p e? bar?) (list (make-menu-submenu p e?))))
 
290
  (tile (:integer? :*) ,(lambda (p e? bar?) (list (make-menu-tile p e?))))
 
291
  (if (:%1 :*) ,(lambda (p e? bar?) (make-menu-if p e? bar?)))
 
292
  (when (:%1 :*) ,(lambda (p e? bar?) (make-menu-when p e? bar?)))
 
293
  (promise (:%1) ,(lambda (p e? bar?) (make-menu-promise p e? bar?))))
 
294
 
 
295
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
296
;; Menu expansion
 
297
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
298
 
 
299
(define (menu-expand-link p)
 
300
  "Expand menu link @p."
 
301
  (with linked ((eval (cadr p)))
 
302
    (if linked (menu-expand linked) p)))
 
303
 
 
304
(define (menu-expand-if p)
 
305
  "Expand conditional menu @p."
 
306
  (with (tag pred? . items) p
 
307
    (if (pred?) (menu-expand-list items) '())))
 
308
 
 
309
(define (menu-expand-promise p)
 
310
  "Expand promised menu @p."
 
311
  (with value ((cadr p))
 
312
    (if (match? value ':menu-item) (menu-expand value) p)))
 
313
 
 
314
(define (menu-expand-list l)
 
315
  "Expand links and conditional menus in list of menus @l."
 
316
  (map menu-expand l))
 
317
 
 
318
(tm-define (menu-expand p)
 
319
  (:type (-> object object))
 
320
  (:synopsis "Expand links and conditional menus in menu @p.")
 
321
  (cond ((npair? p) p)
 
322
        ((string? (car p)) p)
 
323
        ((symbol? (car p))
 
324
         (with result (ahash-ref menu-expand-table (car p))
 
325
           (if result ((car result) p) p)))
 
326
        ((match? (car p) ':menu-wide-label) p)
 
327
        (else (menu-expand-list p))))
 
328
 
 
329
(define-table menu-expand-table
 
330
  (--- ,(lambda (p) `(--- ,@(menu-expand-list (cdr p)))))
 
331
  (| ,(lambda (p) `(| ,@(menu-expand-list (cdr p)))))
 
332
  (group ,(lambda (p) p))
 
333
  (symbol ,(lambda (p) p))
 
334
  (link ,menu-expand-link p)
 
335
  (horizontal ,(lambda (p) `(horizontal ,@(menu-expand-list (cdr p)))))
 
336
  (vertical ,(lambda (p) `(vertical ,@(menu-expand-list (cdr p)))))
 
337
  (-> ,(lambda (p) p))
 
338
  (=> ,(lambda (p) p))
 
339
  (tile ,(lambda (p) p))
 
340
  (if ,menu-expand-if)
 
341
  (when ,(lambda (p) p))
 
342
  (promise ,menu-expand-promise))
 
343
 
 
344
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
345
;; Debugging
 
346
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
347
 
 
348
; (set-trace-level! make-menu-entry-button)
 
349
; (set-trace-level! make-menu-entry-shortcut)
 
350
; (set-trace-level! make-menu-entry-check)
 
351
 
 
352
; (set-trace-point! make-menu-hsep          "case: ---")
 
353
; (set-trace-point! make-menu-vsep          "case: |")
 
354
; (set-trace-point! make-menu-group         "case: group")
 
355
; (set-trace-point! make-menu-items-list    "case: list")
 
356
; (set-trace-point! make-menu-if            "case: if")
 
357
; (set-trace-point! make-menu-when          "case: when")
 
358
; (set-trace-point! make-menu-submenu       "case: =>/->")
 
359
; (set-trace-point! make-menu-tile          "case: tile")
 
360
; (set-trace-point! make-menu-link          "case: link")
 
361
; (set-trace-point! make-menu-promise       "case: promise")
 
362
; (set-trace-point! make-menu-entry         "case: item")
 
363
; (set-trace-point! make-menu-symbol        "case: symbol")
 
364
 
 
365
; (set-trace-level! make-menu-widget)
 
366
; (set-trace-level! make-menu-entry-sub)
 
367
; (set-trace-level! make-menu-items)
 
368
 
 
369
; (set-trace-point! make-menu-horizontal    "case: horizontal")
 
370
; (set-trace-point! make-menu-vertical      "case: vertical")
 
371
; (set-trace-point! make-menu-linked-menu   "case: link")
 
372
; (set-trace-point! make-menu-promised-menu "case: promise")
 
373
 
 
374
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
375
;; Interface
 
376
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
377
 
 
378
(define (make-menu-main p e?)
 
379
  "Transform the menu @p into a widget."
 
380
  (with l (make-menu-items p e? #f)
 
381
    (cond ((null? l) (make-menu-empty))
 
382
          ((and (list? l) (null? (cdr l))) (car l))
 
383
          (else (make-menu-bad-format p e?)))))
 
384
 
 
385
(tm-define (make-menu-widget p e?)
 
386
  (:type (-> object widget))
 
387
  (:synopsis "Transform a menu into a widget.")
 
388
  (:argument p "a scheme object which represents the menu")
 
389
  (:argument e? "greyed menu if @e? is @#f")
 
390
  ((wrap-catch make-menu-main) p e?))