diff options
Diffstat (limited to 'emacs.d/nxhtml/util/new-key-seq-widget.el')
| -rw-r--r-- | emacs.d/nxhtml/util/new-key-seq-widget.el | 312 |
1 files changed, 312 insertions, 0 deletions
diff --git a/emacs.d/nxhtml/util/new-key-seq-widget.el b/emacs.d/nxhtml/util/new-key-seq-widget.el new file mode 100644 index 0000000..7ace679 --- /dev/null +++ b/emacs.d/nxhtml/util/new-key-seq-widget.el @@ -0,0 +1,312 @@ +;;; new-key-seq-widget.el --- New key-sequence widget for Emacs +;; +;; Author: Lennart Borgman (lennart O borgman A gmail O com) +;; Created: Tue Dec 25 23:00:43 2007 +;; Version: +;; Last-Updated: +;; URL: +;; Keywords: +;; Compatibility: +;; +;; Features that might be required by this library: +;; +;; None +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; New version of Kim's Emacs key-sequence widget. For inclusion in +;; Emacs I hope. +;; +;; Fix-me: check what was included. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; I do not know how much I have changed, but I keep it together here +;; for simplicity. +;; +;; Note: I have named made `widget-key-sequence-map' a constant for +;; the moment. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; 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 2, 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; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +(require 'wid-edit) +(require 'edmacro) + +;;; I'm not sure about what this is good for? KFS. +;; +;;; This should probably be for customize-set-value etc, but it is not +;;; used. Or for the widget editing, but it is not used there +;;; either. /Lennart +(defvar widget-key-sequence-prompt-value-history nil + "History of input to `widget-key-sequence-prompt-value'.") + +(defvar widget-key-sequence-default-value [ignore] + "Default value for an empty key sequence.") + +(defconst widget-key-sequence-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map widget-field-keymap) + (define-key map [(control ?q)] 'widget-key-sequence-read-event) + (define-key map [(control ?t)] 'widget-key-sequence-toggle-input-format) + map)) + +(defvar widget-key-sequence-input-formats '(key-description vector)) + +(defcustom widget-key-sequence-default-input-format 'key-description + "Format used to edit key sequences. +This is the format shown and edited in a key-sequence widget." + :type '(choice (const :tag "Key description" 'key-description) + (const :tag "Vector" 'vector)) + :group 'widgets) + +(define-widget 'key-sequence 'restricted-sexp + "A key sequence." + :prompt-value 'widget-field-prompt-value + :prompt-internal 'widget-symbol-prompt-internal +; :prompt-match 'fboundp ;; What was this good for? KFS + :prompt-history 'widget-key-sequence-prompt-value-history + :action 'widget-field-action + :match-alternatives '(stringp vectorp) + :format "%{%t%}: %v" + :validate 'widget-key-sequence-validate + :value-to-internal 'widget-key-sequence-value-to-internal + :value-to-external 'widget-key-sequence-value-to-external + :value widget-key-sequence-default-value + :keymap widget-key-sequence-map + :help-echo "C-q: insert KEY, EVENT, or CODE; C-t: toggle format" + :tag "Key sequence") + + +;;; Leave these here for testing: +;; (edmacro-parse-keys "C-x h" t) => [24 104] +;; (key-description-to-vector "C-x h" ) => [(control 120) 104] +;; (key-description (key-description-to-vector "C-x h")) => "C-x h" +;; (key-description (edmacro-parse-keys "C-x h")) => "C-x h" +;; (key-description [M-mouse-1]) => <M-mouse-1> +;; (edmacro-parse-keys "<M-mouse-1>") => [M-mouse-1] + +;; (event-modifiers 'mouse-1) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1) +;; (event-modifiers 'M-mouse-1) => +;; (event-modifiers '(mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1) +;; (event-modifiers '(down-mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1) +;; (event-modifiers '(S-down-mouse-1)) => (shift down) +;; (event-modifiers 'S-down-mouse-1) => (shift down) +;; (event-modifiers 'down-mouse-1) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1) +;; (event-modifiers '(down-mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1) +;; (let ((m (make-sparse-keymap))) (define-key m [(down mouse-1)] 'hej)) +(defun key-description-to-vector (kd) + "Convert human readable key description KD to vector format. +KD should be in the format returned by `key-description'." + (let ((v + (vconcat + (mapcar (lambda (k) + ;; Fix-me: temporarily clean the event here: + (when (symbolp k) + (let ((esem (get k 'event-symbol-element-mask))) (when esem (lwarn t :warning "kd=%s, k=%s, esem=%s" kd k esem))) + (put k 'event-symbol-element-mask nil)) + (let ((m (event-modifiers k)) + (b (event-basic-type k))) + (setq m (delq 'click m)) + (if m + (nconc m (list b)) + b))) + ;; fix-me: does not always work for menu and tool + ;; bar event because they may contains spaces. + (edmacro-parse-keys kd t)))) + (m (make-sparse-keymap)) + ) + ;; Test before returning it: + (define-key m v 'test) + v)) + +(defun widget-key-sequence-current-input-format () + (let ((fmt (or (widget-get (widget-at (point)) :key-sequence-format) + widget-key-sequence-default-input-format))) + fmt)) + +(defun widget-key-sequence-toggle-input-format () + "Toggle key sequence input format." + (interactive) + (let* ((widget (widget-at (point))) + (value (widget-apply widget :value-get)) + (first (string-to-char value)) + (old-fmt + (let ((fmt (or (widget-get widget :key-sequence-format) + widget-key-sequence-default-input-format))) + fmt)) + (new-fmt + (let ((m (cdr (memq old-fmt widget-key-sequence-input-formats)))) + (if m (car m) (car widget-key-sequence-input-formats)))) + (new-value + (cond + ((eq new-fmt 'key-description) + (setq value (replace-regexp-in-string "\\` *\\(.*?\\) *\\'" "\\1" value)) + (if (string= value "") + "" + (key-description (read value)))) + ((eq new-fmt 'vector) + (format "%S" (key-description-to-vector value))) + (t + (error "Bad key seq format spec: %s" new-fmt)))) + (state (widget-get (widget-get widget :parent) :custom-state)) + ) + (widget-put widget :key-sequence-format new-fmt) + (setq new-value (propertize new-value 'face 'highlight)) + (widget-apply widget :value-set new-value) + (widget-setup) + (widget-put (widget-get widget :parent) :custom-state state) + (cond + ((eq new-fmt 'key-description) + (message "Switched to human readable format")) + ((eq new-fmt 'vector) + (message "Switched to vector format")) + (t + (error "Uh? format=%s" new-fmt))))) + + +(defun widget-key-sequence-read-event (ev) + "Read event or char code and put description in widget. +The events may come from keyboard, mouse, menu or tool bar. + +If the event is a mouse event then multiple entries will be +entered. It is not possible to know which one is wanted. Please +remove those not wanted! + +If 0-7 is pressed then code for an event is prompted for." + (interactive (list + (let ((inhibit-quit t) quit-flag) + (unless (eq 'key-description + (widget-key-sequence-current-input-format)) + (error "Wrong input format, please do C-t first")) + (read-event "Insert KEY, EVENT, or CODE: ")))) + (lwarn t :warning "=====> ev=%s" ev) + (let ((tr (and (keymapp function-key-map) + (lookup-key function-key-map (vector ev))))) + (insert (if (= (char-before) ?\s) "" " ")) + ;; Fix-me: change to check for ? instead of 0-7 to allow char + ;; literal input format + (when (and (integerp ev) + (or (and (<= ?0 ev) (< ev (+ ?0 (min 10 read-quoted-char-radix)))) + (and (<= ?a (downcase ev)) + (< (downcase ev) (+ ?a -10 (min 36 read-quoted-char-radix)))))) + (setq unread-command-events (cons ev unread-command-events) + ev (read-quoted-char (format "Enter code (radix %d)" read-quoted-char-radix)) + tr nil) + (if (and (integerp ev) (not (characterp ev))) + (insert (char-to-string ev)))) ;; throw invalid char error + (setq ev (key-description (list ev))) + (when (arrayp tr) + (setq tr (key-description (list (aref tr 0)))) + (when (y-or-n-p (format "Key %s is translated to %s -- use %s? " ev tr tr)) + (setq ev tr) + ;;(setq ev2 nil) + )) + (insert ev " ") + (when (or (string-match "mouse-" ev) + (string-match "menu-bar" ev) + (string-match "tool-bar" ev)) + (let ((ev2 (read-event nil nil (* 0.001 double-click-time)))) + (while ev2 + (lwarn t :warning "(stringp ev2)=%s, (sequencp ev2)=%s, (symbolp ev2)=%s, ev2=%S" (stringp ev2) (sequencep ev2) (symbolp ev2) ev2) + (if nil ;(memq 32 (append (symbol-name ev2) nil)) ;; Fix-me: contains space + (insert ?\" (symbol-name ev2) ?\") + (insert (key-description (list ev2)))) + (insert " ") + (setq ev2 (read-event nil nil (* 0.001 double-click-time)))))))) + +(defun widget-key-sequence-validate (widget) + "Validate the internal value of the widget. +Actually there is nothing to validate here. The internal value +is always valid, but it is however maybe not what the user +expects. Because of this the internal format is rewritten when +the user gives the value in a way that is not the normal +representation of it. A warning is also shown then." + (condition-case err + (let* ((int-val (widget-apply widget :value-get)) + (def-desc (key-description (edmacro-parse-keys int-val))) + (fmt (or (widget-get widget :key-sequence-format) + widget-key-sequence-default-input-format))) + ;; Normalize and compare with default description + (setq int-val + (replace-regexp-in-string " *" " " int-val t)) + (setq int-val + (replace-regexp-in-string "\\` *\\(.*?\\) *\\'" "\\1" int-val t)) + (unless (or + (eq fmt 'vector) + (string= int-val def-desc)) + ;; Replace with the default description if it is different + ;; so the user sees what the value actually means: + (widget-apply widget :value-set def-desc) + (lwarn t :warning + (concat "Key description %s means the same as %s\n" + "\tTip: You can type C-q to insert a key or event") + int-val def-desc) + ) + ;; Return nil if there a no problem validating + nil) + (error (widget-put widget :error (error-message-string err)) + (lwarn t :warning "invalid %S: %s" widget (error-message-string err)) + ;; Return widget if there was an error + widget))) + +(defun widget-key-sequence-value-to-internal (widget value) + (if (widget-apply widget :match value) + (if (equal value widget-key-sequence-default-value) + "" + (let ((fmt (or (widget-get widget :key-sequence-format) + widget-key-sequence-default-input-format))) + (if (eq fmt 'vector) + (format "%S" value) + (key-description value)))) + value)) + +(defun widget-key-sequence-value-to-external (widget value) + (if (stringp value) + (if (string-match "\\`[[:space:]]*\\'" value) + widget-key-sequence-default-value + ;; Give a better error message and a trace back on debug: + (condition-case err + (let* ((fmt (or (widget-get widget :key-sequence-format) + widget-key-sequence-default-input-format)) + (first (string-to-char value))) + (cond + ((eq fmt 'vector) + (read value) + ) + (t + (key-description-to-vector value)))) + (error (error "Bad value: %s" (error-message-string err))))) + value)) + +;; (customize-option 'new-key-seq-widget-test) +(defcustom new-key-seq-widget-test [] + "Testing only!" + :type 'key-sequence + :group 'widgets) + + (provide 'new-key-seq-widget) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; new-key-seq-widget.el ends here |