unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
blob 639c082da15c7e2fe77a07bcb6e916a8d68e10bd 4780 bytes (raw)
name: lisp/low-level-key.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
 
;;; -*- lexical-binding: t -*-
(require 'cl-lib)

;; User options
(defvar llk-tap-timeout 1000)
(defvar llk-tap-count 2)
(defvar llk-tap-keys
  '(lshift rshift lctrl rctrl lalt ralt shift ctrl alt))
(defvar llk-bindings nil)
(defvar llm-bindings nil)

(defun llk-init ()
  (interactive)
  (define-key special-event-map [low-level-key] 'llk-handle)
  (define-key special-event-map [low-level-modifier] 'llm-handle)

  (setq llk-bindings nil)
  (setq llm-bindings nil)

  ;; (llm-bind 'tap 'shift 'delete-other-windows)
  ;; (llk-bind 'tap 'lctrl 'hyper)
  (setq enable-low-level-key-events t))

;; For example:
;; (llk-add-binding 'tap 'lshift 'delete-other-windows)
;; Can bind to a command, a function or the symbol 'hyper.
(defun llk-bind (action key function)
  (push (list action key function) llk-bindings))

(defun llm-bind (action key function)
  (push (list action key function) llm-bindings))

;; We store the last events here to test for multitap.
(defvar llk-events nil)
(defvar llm-events nil)

;; If positive, return key ('lshift, etc) else return nil.
(defun llk-detect-n-tap (n timeout)
  ;; The physical-key event is like this:
  ;; (physical-key t lshift 90196265 #<frame>)
  ;; The second element is t for a key press, nil for a key release
  ;; The fourth element is the time in milliseconds
  ;; The fifth is the frame, we don't use it yet.

  (let ((key (cl-third last-input-event)))
    (if (not (member key llk-tap-keys))
        ;; Key not in tap list, clear history
        (setq llk-events nil)
      ;; Clear it also if the first element is from a different key
      (and llk-events
           (not (equal (cl-third (car llk-events)) key))
           (setq llk-events nil))
      (push last-input-event llk-events)
      ;; Only care about last 2xN events
      (ntake (* 2 n) llk-events)
      ;; If we have:
      ;; - Exactly 2 * n events.
      ;; - down, up, down, up, ...
      ;; - not two much time between first and last
      (and (eq (* 2 n) (length llk-events))
           (cl-every 'eq
                     (ntake (* 2 n)
                            (list nil t nil t nil t nil t
                                  nil t nil t nil t nil t))
                     (mapcar 'cl-second llk-events))
           (< (- (cl-fourth (cl-first llk-events))
                 (cl-fourth (car (last llk-events))))
              timeout)
           (progn
             (setq llk-events nil)
             key)))))


;; this function is a copy of llk-detect-n-tap, but for llm-events
(defun llm-detect-n-tap (n timeout)
  (let ((key (cl-third last-input-event)))
    (if (not (member key llk-tap-keys))
        (setq llm-events nil)
      (and llm-events
           (not (equal (cl-third (car llm-events)) key))
           (setq llm-events nil))
      (push last-input-event llm-events)
      (ntake (* 2 n) llm-events)
      (and (eq (* 2 n) (length llm-events))
           (cl-every 'eq
                     (ntake (* 2 n)
                            (list nil t nil t nil t nil t
                                  nil t nil t nil t nil t))
                     (mapcar 'cl-second llm-events))
           (< (- (cl-fourth (cl-first llm-events))
                 (cl-fourth (car (last llm-events))))
              timeout)
           (progn
             (setq llm-events nil)
             key)))))

(defun llk-handle ()
  (interactive)

  (let ((tap-key (llk-detect-n-tap
                  llk-tap-count
                  llk-tap-timeout)))
    (when tap-key
      (let ((func (cl-third
                   (seq-find
                    (lambda (b)
                      (and (eq (cl-first b) 'tap)
                           (eq (cl-second b) tap-key)))
                    llk-bindings))))
        (cond
         ((commandp func) (call-interactively func))
         ((functionp func) (funcall func))
         ((eq 'hyper func)
          (message "H-...")
          (let ((r (read-event)))
            (setq unread-command-events
                  (list (event-apply-modifier
                         r 'hyper 24 "H-"))))))))))

(defun llm-handle()
  (interactive)

  (let ((tap-key (llm-detect-n-tap
                  llk-tap-count
                  llk-tap-timeout)))
    (when tap-key
      (let ((func (cl-third
                   (seq-find
                    (lambda (b)
                      (and (eq (cl-first b) 'tap)
                           (eq (cl-second b) tap-key)))
                    llm-bindings))))
        (cond
         ((commandp func) (call-interactively func))
         ((functionp func) (funcall func))
         ((eq 'hyper func)
          (message "H-...")
          (let ((r (read-event)))
            (setq unread-command-events
                  (list (event-apply-modifier
                         r 'hyper 24 "H-"))))))))))

debug log:

solving 639c082da15 ...
found 639c082da15 in https://yhetil.org/emacs-bugs/d5c72818-e907-43f5-853a-89ec01264157@imayhem.com/

applying [1/1] https://yhetil.org/emacs-bugs/d5c72818-e907-43f5-853a-89ec01264157@imayhem.com/
diff --git a/lisp/low-level-key.el b/lisp/low-level-key.el
new file mode 100644
index 00000000000..639c082da15

Checking patch lisp/low-level-key.el...
Applied patch lisp/low-level-key.el cleanly.

index at:
100644 639c082da15c7e2fe77a07bcb6e916a8d68e10bd	lisp/low-level-key.el

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).