alternative styles to display shortcuts Allow display of menu shortcuts in Windows style, or in traditional TeXmacs style but with Shift key always explicit. Also fix a typo in an existing docstring of base.scm. *** TeXmacs-1.0.0.22-src/TeXmacs-1.0.0.22/progs/boot/base.scm --- TeXmacs-1.0.0.22-src/TeXmacs-1.0.0.22/progs/boot/base.scm *************** (define (exec-unary f l) *** 70,75 **** --- 70,77 ---- ;; Lists ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define (list->symbol l) (string->symbol (list->string l))) + (define (in? x l) "Is there one element of list l which is 'equal?' to x?" (cond ((null? l) #f) *************** (define (split l pred) *** 103,109 **** "(split l pred) -> (l1 l2). Split l into l1 and l2 where pred is true. l1 is the longest head of l2 where the unary predicate pred maps all ! elements to true." (if (null? l) (list l l) (if (pred (car l)) (list '() l) --- 105,111 ---- "(split l pred) -> (l1 l2). Split l into l1 and l2 where pred is true. l1 is the longest head of l2 where the unary predicate pred maps all ! elements to false." (if (null? l) (list l l) (if (pred (car l)) (list '() l) *************** (define (list-sort l comp) *** 128,133 **** --- 130,144 ---- (let ((r (list-sort (cdr l) comp))) (list-sort-insert (car l) r comp)))) + (define (intersperse x l) + "Copy of l with x inserted between each element." + (define (intersperse-sub x il ol) + (cond ((null? il) (reverse ol)) + ((null? (cdr il)) (reverse (cons (car il) ol))) + (else (intersperse-sub x (cdr il) + (cons* x (car il) ol))))) + (intersperse-sub x l (list))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Booleans ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; *************** (define (string-replace s what by) *** 173,178 **** --- 184,193 ---- (define (force-string s) "Return s or \"\" if s in not a string." (if (string? s) s "")) + (define (string-join s l) + "Concatenate strings in l, interspersed with the string s." + (apply string-append (intersperse s l))) + (define (func? x f . opts) "(func? x f [n]) -> boolean. Test car, and optionally length, of list x. *** TeXmacs-1.0.0.22-src/TeXmacs-1.0.0.22/progs/boot/menu.scm --- TeXmacs-1.0.0.22-src/TeXmacs-1.0.0.22/progs/boot/menu.scm *************** (define (make-menu-label p e? . opt) *** 143,148 **** --- 143,223 ---- ((tuple? p 'icon 1) ; (icon "name.xpm") (widget-xpm (cadr p) #t))))) + + (define (parse-shortcut s) + "Parse a shortcut from its internal representation to a list of chords. + + A chord is a list starting with any number of modifiers represented as + symbols and a key represented as a string. + + No shortcut: '' -> () + + Single chord: 'x' -> (('x')) ; 'X' -> ((S 'X')) ; '-' -> (('-')) + 'tab' -> (('tab')) ; 'M-A-x' -> ((M A 'x')) + 'M-A--' -> ((M A '-')) ; 'Mod1-x' -> ((Mod1 'x')) + + Multiple chords: 'C-x C-s' -> ((C 'x') (C 's')) + + Note: because of problems with Emacs, strings are *single* quoted." + + (define (parse-shortcut-chord il ol) + (let ((ll (split il (lambda (c) (char=? c #\-))))) + (cond ((null? il) (reverse ol)) + ((or (null? (car ll)) + (null? (cadr ll))) + (reverse + (cond ((or (not (char-alphabetic? (car il))) + (not (null? (cdr il)))) + (cons (list->string il) ol)) + ((char-upper-case? (car il)) + (cons* (list->string il) 'S ol)) + (else + (cons (char->string (char-upcase (car il))) ol))))) + (else + (parse-shortcut-chord (cdadr ll) + (cons (list->symbol (car ll)) ol)))))) + + (define (parse-shortcut-sub il ol) + (if (null? il) + (reverse ol) + (let ((ll (split il (lambda (c) (char=? c #\space))))) + (parse-shortcut-sub + (if (null? (cadr ll)) (list) (cdadr ll)) + (cons (parse-shortcut-chord (car ll) (list)) ol))))) + + (parse-shortcut-sub (string->list s) (list))) + + (define (shortcut-tm s) s) + + (define (shortcut-win s) + (define (shortcut-chord-win l) + (string-join "+" + (filter (list + (and (in? 'M l) "Meta") + (and (in? 'A l) "Alt") + (and (in? 'C l) "Ctrl") + (and (in? 'S l) "Shift") + (upcase-first (cAr l))) + (lambda (x) x)))) + (string-join " " (map shortcut-chord-win (parse-shortcut s)))) + + (define (shortcut-tm-shift s) + (define (shortcut-chord-tm-shift l) + (string-join "-" + (map + (lambda (x) + (cond ((symbol? x) + (symbol->string x)) + ;; assume x is a string + ((= 1 (string-length x)) + (locase-first x)) + (else (upcase-first x)))) + l))) + (string-join " " (map shortcut-chord-tm-shift (parse-shortcut s)))) + + (define pretty-shortcut shortcut-tm-shift) + + (define (make-menu-item p e?) "<menu-item> :: (<label> [...] [<shortcut>] [<check>] <action>)" *************** (define (make-menu-item p e?) *** 155,164 **** command))) (define (make-shortcut label action opt-key) ! (cond (opt-key opt-key) ! ((pair? label) "") ! (else (get-inverse-binding action)))) ! (define (make-check opt-check action) (or opt-check (and (pair? action) --- 230,239 ---- command))) (define (make-shortcut label action opt-key) ! (pretty-shortcut (cond (opt-key opt-key) ! ((pair? label) "") ! (else (get-inverse-binding action))))) ! (define (make-check opt-check action) (or opt-check (and (pair? action)