nxhtml/util/new-key-seq-widget.el

   1 ;;; new-key-seq-widget.el --- New key-sequence widget for Emacs
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: Tue Dec 25 23:00:43 2007
   5 ;; Version:
   6 ;; Last-Updated:
   7 ;; URL:
   8 ;; Keywords:
   9 ;; Compatibility:
  10 ;;
  11 ;; Features that might be required by this library:
  12 ;;
  13 ;;   None
  14 ;;
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;;
  17 ;;; Commentary:
  18 ;;
  19 ;;  New version of Kim's Emacs key-sequence widget. For inclusion in
  20 ;;  Emacs I hope.
  21 ;;
  22 ;;  Fix-me: check what was included.
  23 ;;
  24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25 ;;
  26 ;;; Change log:
  27 ;;
  28 ;; I do not know how much I have changed, but I keep it together here
  29 ;; for simplicity.
  30 ;;
  31 ;; Note: I have named made `widget-key-sequence-map' a constant for
  32 ;; the moment.
  33 ;;
  34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35 ;;
  36 ;; This program is free software; you can redistribute it and/or
  37 ;; modify it under the terms of the GNU General Public License as
  38 ;; published by the Free Software Foundation; either version 2, or
  39 ;; (at your option) any later version.
  40 ;;
  41 ;; This program is distributed in the hope that it will be useful,
  42 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  43 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  44 ;; General Public License for more details.
  45 ;;
  46 ;; You should have received a copy of the GNU General Public License
  47 ;; along with this program; see the file COPYING.  If not, write to
  48 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  49 ;; Floor, Boston, MA 02110-1301, USA.
  50 ;;
  51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52 ;;
  53 ;;; Code:
  54
  55 (require 'wid-edit)
  56 (require 'edmacro)
  57
  58 ;;; I'm not sure about what this is good for?  KFS.
  59 ;;
  60 ;;; This should probably be for customize-set-value etc, but it is not
  61 ;;; used. Or for the widget editing, but it is not used there
  62 ;;; either. /Lennart
  63 (defvar widget-key-sequence-prompt-value-history nil
  64   "History of input to `widget-key-sequence-prompt-value'.")
  65
  66 (defvar widget-key-sequence-default-value [ignore]
  67   "Default value for an empty key sequence.")
  68
  69 (defconst widget-key-sequence-map
  70   (let ((map (make-sparse-keymap)))
  71     (set-keymap-parent map widget-field-keymap)
  72     (define-key map [(control ?q)] 'widget-key-sequence-read-event)
  73     (define-key map [(control ?t)] 'widget-key-sequence-toggle-input-format)
  74     map))
  75
  76 (defvar widget-key-sequence-input-formats '(key-description vector))
  77
  78 (defcustom widget-key-sequence-default-input-format 'key-description
  79   "Format used to edit key sequences.
  80 This is the format shown and edited in a key-sequence widget."
  81   :type '(choice (const :tag "Key description" 'key-description)
  82                  (const :tag "Vector" 'vector))
  83   :group 'widgets)
  84
  85 (define-widget 'key-sequence 'restricted-sexp
  86   "A key sequence."
  87   :prompt-value 'widget-field-prompt-value
  88   :prompt-internal 'widget-symbol-prompt-internal
  89 ; :prompt-match 'fboundp   ;; What was this good for?  KFS
  90   :prompt-history 'widget-key-sequence-prompt-value-history
  91   :action 'widget-field-action
  92   :match-alternatives '(stringp vectorp)
  93   :format "%{%t%}: %v"
  94   :validate 'widget-key-sequence-validate
  95   :value-to-internal 'widget-key-sequence-value-to-internal
  96   :value-to-external 'widget-key-sequence-value-to-external
  97   :value widget-key-sequence-default-value
  98   :keymap widget-key-sequence-map
  99   :help-echo "C-q: insert KEY, EVENT, or CODE; C-t: toggle format"
 100   :tag "Key sequence")
 101
 102
 103 ;;; Leave these here for testing:
 104 ;; (edmacro-parse-keys "C-x h" t) => [24 104]
 105 ;; (key-description-to-vector "C-x h" ) => [(control 120) 104]
 106 ;; (key-description (key-description-to-vector "C-x h")) => "C-x h"
 107 ;; (key-description (edmacro-parse-keys "C-x h")) => "C-x h"
 108 ;; (key-description [M-mouse-1]) => <M-mouse-1>
 109 ;; (edmacro-parse-keys "<M-mouse-1>") => [M-mouse-1]
 110
 111 ;; (event-modifiers 'mouse-1) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
 112 ;; (event-modifiers 'M-mouse-1) =>
 113 ;; (event-modifiers '(mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
 114 ;; (event-modifiers '(down-mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
 115 ;; (event-modifiers '(S-down-mouse-1)) => (shift down)
 116 ;; (event-modifiers 'S-down-mouse-1) => (shift down)
 117 ;; (event-modifiers 'down-mouse-1) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
 118 ;; (event-modifiers '(down-mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
 119 ;; (let ((m (make-sparse-keymap))) (define-key m [(down mouse-1)] 'hej))
 120 (defun key-description-to-vector (kd)
 121   "Convert human readable key description KD to vector format.
 122 KD should be in the format returned by `key-description'."
 123   (let ((v
 124          (vconcat
 125           (mapcar (lambda (k)
 126                     ;; Fix-me: temporarily clean the event here:
 127                     (when (symbolp k)
 128                       (let ((esem (get k 'event-symbol-element-mask))) (when esem (lwarn t :warning "kd=%s, k=%s, esem=%s" kd k esem)))
 129                       (put k 'event-symbol-element-mask nil))
 130                     (let ((m (event-modifiers k))
 131                           (b (event-basic-type k)))
 132                       (setq m (delq 'click m))
 133                       (if m
 134                           (nconc m (list b))
 135                         b)))
 136                   ;; fix-me: does not always work for menu and tool
 137                   ;; bar event because they may contains spaces.
 138                   (edmacro-parse-keys kd t))))
 139         (m (make-sparse-keymap))
 140         )
 141     ;; Test before returning it:
 142     (define-key m v 'test)
 143     v))
 144
 145 (defun widget-key-sequence-current-input-format ()
 146   (let ((fmt (or (widget-get (widget-at (point)) :key-sequence-format)
 147                  widget-key-sequence-default-input-format)))
 148     fmt))
 149
 150 (defun widget-key-sequence-toggle-input-format ()
 151   "Toggle key sequence input format."
 152   (interactive)
 153   (let* ((widget (widget-at (point)))
 154          (value (widget-apply widget :value-get))
 155          (first (string-to-char value))
 156          (old-fmt
 157           (let ((fmt (or (widget-get widget :key-sequence-format)
 158                          widget-key-sequence-default-input-format)))
 159             fmt))
 160          (new-fmt
 161           (let ((m (cdr (memq old-fmt widget-key-sequence-input-formats))))
 162             (if m (car m) (car widget-key-sequence-input-formats))))
 163          (new-value
 164           (cond
 165            ((eq new-fmt 'key-description)
 166             (setq value (replace-regexp-in-string "\\` *\\(.*?\\) *\\'" "\\1" value))
 167             (if (string= value "")
 168                 ""
 169               (key-description (read value))))
 170            ((eq new-fmt 'vector)
 171             (format "%S" (key-description-to-vector value)))
 172            (t
 173             (error "Bad key seq format spec: %s" new-fmt))))
 174          (state (widget-get (widget-get widget :parent) :custom-state))
 175          )
 176     (widget-put widget :key-sequence-format new-fmt)
 177     (setq new-value (propertize new-value 'face 'highlight))
 178     (widget-apply widget :value-set new-value)
 179     (widget-setup)
 180     (widget-put (widget-get widget :parent) :custom-state state)
 181     (cond
 182      ((eq new-fmt 'key-description)
 183       (message "Switched to human readable format"))
 184      ((eq new-fmt 'vector)
 185       (message "Switched to vector format"))
 186      (t
 187       (error "Uh? format=%s" new-fmt)))))
 188
 189
 190 (defun widget-key-sequence-read-event (ev)
 191   "Read event or char code and put description in widget.
 192 The events may come from keyboard, mouse, menu or tool bar.
 193
 194 If the event is a mouse event then multiple entries will be
 195 entered. It is not possible to know which one is wanted. Please
 196 remove those not wanted!
 197
 198 If 0-7 is pressed then code for an event is prompted for."
 199   (interactive (list
 200                 (let ((inhibit-quit t) quit-flag)
 201                   (unless (eq 'key-description
 202                               (widget-key-sequence-current-input-format))
 203                     (error "Wrong input format, please do C-t first"))
 204                   (read-event "Insert KEY, EVENT, or CODE: "))))
 205   (lwarn t :warning "=====> ev=%s" ev)
 206   (let ((tr (and (keymapp function-key-map)
 207                  (lookup-key function-key-map (vector ev)))))
 208     (insert (if (= (char-before) ?\s)  "" " "))
 209     ;; Fix-me: change to check for ? instead of 0-7 to allow char
 210     ;; literal input format
 211     (when (and (integerp ev)
 212                (or (and (<= ?0 ev) (< ev (+ ?0 (min 10 read-quoted-char-radix))))
 213                    (and (<= ?a (downcase ev))
 214                         (< (downcase ev) (+ ?a -10 (min 36 read-quoted-char-radix))))))
 215       (setq unread-command-events (cons ev unread-command-events)
 216             ev (read-quoted-char (format "Enter code (radix %d)" read-quoted-char-radix))
 217             tr nil)
 218       (if (and (integerp ev) (not (characterp ev)))
 219           (insert (char-to-string ev))))  ;; throw invalid char error
 220     (setq ev (key-description (list ev)))
 221     (when (arrayp tr)
 222       (setq tr (key-description (list (aref tr 0))))
 223       (when (y-or-n-p (format "Key %s is translated to %s -- use %s? " ev tr tr))
 224         (setq ev tr)
 225         ;;(setq ev2 nil)
 226         ))
 227     (insert ev " ")
 228     (when (or (string-match "mouse-" ev)
 229               (string-match "menu-bar" ev)
 230               (string-match "tool-bar" ev))
 231       (let ((ev2 (read-event nil nil (* 0.001 double-click-time))))
 232         (while ev2
 233           (lwarn t :warning "(stringp ev2)=%s, (sequencp ev2)=%s, (symbolp ev2)=%s, ev2=%S" (stringp ev2) (sequencep ev2) (symbolp ev2) ev2)
 234           (if nil ;(memq 32 (append (symbol-name ev2) nil)) ;; Fix-me: contains space
 235               (insert ?\" (symbol-name ev2) ?\")
 236             (insert (key-description (list ev2))))
 237           (insert " ")
 238           (setq ev2 (read-event nil nil (* 0.001 double-click-time))))))))
 239
 240 (defun widget-key-sequence-validate (widget)
 241   "Validate the internal value of the widget.
 242 Actually there is nothing to validate here.  The internal value
 243 is always valid, but it is however maybe not what the user
 244 expects.  Because of this the internal format is rewritten when
 245 the user gives the value in a way that is not the normal
 246 representation of it. A warning is also shown then."
 247   (condition-case err
 248       (let* ((int-val (widget-apply widget :value-get))
 249              (def-desc (key-description (edmacro-parse-keys int-val)))
 250              (fmt (or (widget-get widget :key-sequence-format)
 251                       widget-key-sequence-default-input-format)))
 252         ;; Normalize and compare with default description
 253         (setq int-val
 254               (replace-regexp-in-string " *" " " int-val t))
 255         (setq int-val
 256               (replace-regexp-in-string "\\` *\\(.*?\\) *\\'" "\\1" int-val t))
 257         (unless (or
 258                  (eq fmt 'vector)
 259                  (string= int-val def-desc))
 260           ;; Replace with the default description if it is different
 261           ;; so the user sees what the value actually means:
 262           (widget-apply widget :value-set def-desc)
 263           (lwarn t :warning
 264                  (concat "Key description %s means the same as %s\n"
 265                          "\tTip: You can type C-q to insert a key or event")
 266                  int-val def-desc)
 267           )
 268         ;; Return nil if there a no problem validating
 269         nil)
 270     (error (widget-put widget :error (error-message-string err))
 271            (lwarn t :warning "invalid %S: %s" widget (error-message-string err))
 272            ;; Return widget if there was an error
 273            widget)))
 274
 275 (defun widget-key-sequence-value-to-internal (widget value)
 276   (if (widget-apply widget :match value)
 277       (if (equal value widget-key-sequence-default-value)
 278           ""
 279         (let ((fmt (or (widget-get widget :key-sequence-format)
 280                        widget-key-sequence-default-input-format)))
 281           (if (eq fmt 'vector)
 282               (format "%S" value)
 283             (key-description value))))
 284     value))
 285
 286 (defun widget-key-sequence-value-to-external (widget value)
 287   (if (stringp value)
 288       (if (string-match "\\`[[:space:]]*\\'" value)
 289           widget-key-sequence-default-value
 290         ;; Give a better error message and a trace back on debug:
 291         (condition-case err
 292             (let* ((fmt (or (widget-get widget :key-sequence-format)
 293                             widget-key-sequence-default-input-format))
 294                    (first (string-to-char value)))
 295               (cond
 296                ((eq fmt 'vector)
 297                 (read value)
 298                 )
 299                (t
 300                 (key-description-to-vector value))))
 301           (error (error "Bad value: %s" (error-message-string err)))))
 302     value))
 303
 304 ;; (customize-option 'new-key-seq-widget-test)
 305 (defcustom new-key-seq-widget-test []
 306   "Testing only!"
 307   :type 'key-sequence
 308   :group 'widgets)
 309
 310  (provide 'new-key-seq-widget)
 311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 312 ;;; new-key-seq-widget.el ends here