src/TeXmacs/progs/kernel/gui/kbd-define.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : kbd-define.scm
   5 ;; DESCRIPTION : Definition of keyboard shortcuts/wildcards
   6 ;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
   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
  14 (texmacs-module (kernel gui kbd-define))
  15
  16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17 ;; Lazy keyboard bindings
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19
  20 (define lazy-keyboard-waiting '())
  21 (define-public lazy-keyboard-done (make-ahash-table))
  22
  23 (define-public (lazy-keyboard-do module mode*)
  24   (with mode (texmacs-mode-mode mode*)
  25     (set! lazy-keyboard-waiting (acons mode module lazy-keyboard-waiting))))
  26
  27 (define-public-macro (lazy-keyboard module . modes)
  28   (for-each (lambda (mode) (lazy-keyboard-do module mode)) modes)
  29   `(delayed
  30      (:idle 250)
  31      (ahash-set! lazy-keyboard-done ',module #t)
  32      (import-from ,module)))
  33
  34 (define (lazy-keyboard-force-do l)
  35   (cond ((null? l) l)
  36         ((ahash-ref lazy-keyboard-done (cdar l))
  37          (lazy-keyboard-force-do (cdr l)))
  38         ((texmacs-in-mode? (caar l))
  39          (module-load (cdar l))
  40          (ahash-set! lazy-keyboard-done (cdar l) #t)
  41          (lazy-keyboard-force-do (cdr l)))
  42         (else (cons (car l) (lazy-keyboard-force-do (cdr l))))))
  43
  44 (define-public (lazy-keyboard-force)
  45   (set! lazy-keyboard-waiting
  46         (reverse (lazy-keyboard-force-do (reverse lazy-keyboard-waiting)))))
  47
  48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49 ;; Definition of keyboard wildcards
  50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51
  52 (define (kbd-wildcards-sub l post)
  53   (if (nnull? l)
  54       (let* ((w (car l))
  55              (key (car w))
  56              (im (cadr w))
  57              (left (if (>= (length w) 3) (caddr w) #f))
  58              (right (if (>= (length w) 4) (cadddr w) #t)))
  59         (insert-kbd-wildcard key im post left right)
  60         (kbd-wildcards-sub (cdr l) post))))
  61
  62 (define-public (kbd-wildcards-body l)
  63   "Helper routine for kbd-wildcards macro"
  64   (cond ((null? l) (noop))
  65         ((== (car l) 'pre) (kbd-wildcards-sub (cdr l) #f))
  66         ((== (car l) 'post) (kbd-wildcards-sub (cdr l) #t))
  67         (else (kbd-wildcards-sub l #t))))
  68
  69 (define-public-macro (kbd-wildcards . l)
  70   "Add entries in @l to the keyboard wildcard table"
  71   `(kbd-wildcards-body ,(list 'quasiquote l)))
  72
  73 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  74 ;; Subroutines for the definition of keyboard shortcuts
  75 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76
  77 (define kbd-map-table (make-ahash-table))
  78 (define kbd-inv-table (make-ahash-table))
  79 (define (kbd-set-map! key im) (ahash-set! kbd-map-table key im))
  80 (define (kbd-set-inv! key im) (ahash-set! kbd-inv-table key im))
  81 (define (kbd-get-map key) (ahash-ref kbd-map-table key))
  82 (define (kbd-get-inv key) (ahash-ref kbd-inv-table key))
  83 (define (kbd-remove-map! key) (ahash-remove! kbd-map-table key))
  84
  85 (define (kbd-source cmd)
  86   (if (procedure? cmd) (promise-source cmd) cmd))
  87
  88 (define (kbd-insert-key-binding conds key im)
  89   ;;(display* "Binding '" key "' when " conds " to " im "\n")
  90   (with com (kbd-source (car im))
  91     (kbd-delete-key-binding2 conds key)
  92     (kbd-set-map! key (ovl-insert (kbd-get-map key) im conds))
  93     (kbd-set-inv! com (ovl-insert (kbd-get-inv com) key conds))
  94     ;;(display* key ": " (kbd-get-map key) "\n")
  95     ;;(display* com "] " (kbd-get-inv com) "\n")
  96     ))
  97
  98 (define-public (kbd-delete-key-binding2 conds key)
  99   ;;(display* "Deleting binding '" key "' when " conds "\n")
 100   (with im (ovl-find (kbd-get-map key) conds)
 101     (if im
 102         (with com (kbd-source (car im))
 103           (kbd-set-map! key (ovl-remove (kbd-get-map key) conds))
 104           (kbd-set-inv! com (ovl-remove (kbd-get-inv com) conds))))))
 105
 106 (define-public (kbd-find-key-binding key)
 107   "Find the command associated to the keystroke @key"
 108   ;;(display* "Find binding '" key "'\n")
 109   (lazy-keyboard-force)
 110   (ovl-resolve (kbd-get-map key) #f))
 111
 112 (define-public (kbd-find-inv-binding com)
 113   "Find keyboard binding for command @com"
 114   ;;(display* "Find inverse binding '" com "'\n")
 115   (lazy-keyboard-force)
 116   (with r (ovl-resolve (kbd-get-inv com) #f)
 117     (if r r "")))
 118
 119 (define (kbd-find-key-binding2 conds key)
 120   ;;(display* "Find binding '" key "' when " conds "\n")
 121   ;; FIXME: we really need an ovl-find which does mode inference
 122   (or (ovl-find (kbd-get-map key) conds)
 123       (ovl-find (kbd-get-map key) '())))
 124
 125 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 126 ;; Yet more subroutines for the definition of keyboard shortcuts
 127 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 128
 129 (define (kbd-append prefix s1)
 130   (let* ((s2 (string-replace s1 " " ""))
 131          (s3 (string-replace s2 "<" "<."))
 132          (s4 (string-replace s3 ">" "<gtr>"))
 133          (s5 (string-replace s4 "<." "<less>")))
 134     (string-append prefix s5)))
 135
 136 (define (kbd-sub-binding conds s prev-end end)
 137   (let* ((this-ss (substring s 0 end))
 138          (this (kbd-find-key-binding2 conds this-ss)))
 139     (if (not this)
 140         (let* ((prev-ss (substring s 0 prev-end))
 141                (prev (kbd-find-key-binding2 conds prev-ss)))
 142           (if (and (list? prev) (= (length prev) 2)) (set! prev (car prev)))
 143           (if (or (not prev) (nstring? prev)) (set! prev prev-ss))
 144           (with im (kbd-append prev (substring s prev-end end))
 145             (kbd-insert-key-binding conds this-ss (list im "")))))))
 146
 147 (define (kbd-sub-bindings-sub conds s prev-end end)
 148   (cond ((== end (string-length s)) (noop))
 149         ((== (string-ref s end) #\space)
 150          (kbd-sub-binding conds s prev-end end)
 151          (kbd-sub-bindings-sub conds s end (+ end 1)))
 152         (else (kbd-sub-bindings-sub conds s prev-end (+ end 1)))))
 153
 154 (define (kbd-sub-bindings conds s)
 155   (kbd-sub-bindings-sub conds s 0 0))
 156
 157 (define-public (kbd-binding conds key2 cmd help)
 158   "Helper routine for kbd-map macro"
 159   ;;(display* conds ", " key2 ", " cmd ", " help "\n")
 160   (with key (kbd-pre-rewrite key2)
 161     (kbd-sub-bindings conds key)
 162     (kbd-insert-key-binding conds key (list cmd help))))
 163
 164 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 165 ;; Definition of keyboard shortcuts
 166 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 167
 168 (define (kbd-add-condition conds opt)
 169   (cond ((== (car opt) :mode) (conditions-insert conds 0 (cadr opt)))
 170         ((== (car opt) :context)
 171          (if (predicate-option? (cadr opt))
 172              (conditions-insert conds 1 (cadr opt))
 173              (with pred `(lambda (t) (match? t ',(cadr opt)))
 174                (conditions-insert conds 1 pred))))
 175         ((== (car opt) :inside)
 176          (with pred `(lambda (t) (and (tm-compound? t)
 177                                       (in? (tm-car t) ',(cdr opt))))
 178            (conditions-insert conds 1 pred)))
 179         (else (texmacs-error "kbd-add-condition"
 180                              "Bad keyboard option ~S" opt))))
 181
 182 (define (kbd-map-one conds l)
 183   (if (not (and (pair? l) (string? (car l)) (pair? (cdr l))))
 184       (texmacs-error "kbd-map-pre-one" "Bad keymap in: ~S" l))
 185   (with (key action . opt) l
 186     (if (string? action)
 187         (with help (if (null? opt) "" (car opt))
 188           `(kbd-binding (list ,@conds) ,key ,action ,help))
 189         `(kbd-binding (list ,@conds) ,key (lambda () ,action ,@opt) ""))))
 190
 191 (define (kbd-map-body conds l)
 192   (cond ((null? l) '())
 193         ((symbol? (car l))
 194          (kbd-map-body (list 0 (car l)) (cdr l)))
 195         ((and (pair? (car l)) (keyword? (caar l)))
 196          (kbd-map-body (kbd-add-condition conds (car l)) (cdr l)))
 197         (else (map (lambda (x) (kbd-map-one conds x)) l))))
 198
 199 (define-public-macro (kbd-map . l)
 200   "Add entries in @l to the keyboard mapping"
 201   `(begin ,@(kbd-map-body '() l)))
 202
 203 (define (kbd-remove-one conds key)
 204   `(kbd-delete-key-binding2 (list ,@conds) ,key))
 205
 206 (define (kbd-remove-body conds l)
 207   (cond ((null? l) '())
 208         ((symbol? (car l))
 209          (kbd-remove-body (list 0 (car l)) (cdr l)))
 210         ((and (pair? (car l)) (keyword? (caar l)))
 211          (kbd-remove-body (kbd-add-condition conds (car l)) (cdr l)))
 212         (else (map (lambda (x) (kbd-remove-one conds x)) l))))
 213
 214 (define-public-macro (kbd-remove . l)
 215   "Remove entries in @l from keyboard mapping"
 216   `(begin ,@(kbd-remove-body '() l)))
 217
 218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 219 ;; Definition of keyboard (backslashed) commands
 220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 221
 222 (define kbd-command-table (make-ahash-table))
 223
 224 (define (kbd-set-command! key im)
 225   (ahash-set! kbd-command-table key im))
 226
 227 (define-public (kbd-get-command key)
 228   (lazy-keyboard-force)
 229   (ahash-ref kbd-command-table key))
 230
 231 (define-public (kbd-command-pre arg)
 232   "Helper routine for kbd-commands macro"
 233   (with (cmd help . action) arg
 234     (list cmd help (list 'unquote `(lambda () ,@action)))))
 235
 236 (define-public (kbd-command arg)
 237   "Helper routine for kbd-commands macro"
 238   (with (cmd help action) arg
 239     (kbd-set-command! cmd (cons help action))))
 240
 241 (define-public-macro (kbd-commands . l)
 242   "Add backslashed commands in @l to keyboard mapping"
 243   `(for-each kbd-command ,(list 'quasiquote (map kbd-command-pre l))))
 244
 245 (define-public-macro (kbd-symbols . l)
 246   "Add symbols in @l to keyboard mapping"
 247   (define (fun s)
 248     (list s (string-append "insert#<" s ">")
 249           (list 'insert (string-append "<" s ">"))))
 250   `(kbd-commands ,@(map fun l)))
 251
 252 (define-public (emulate-keyboard k)
 253   (delayed (raw-emulate-keyboard k)))