Naive implementation of home row mods in pure Hammerspoon

scratch.fnl

(local fennel (require :fennel))
(local pp fennel.view)

;; CAGS
(local mod-map {:a :ctrl :s :alt :d :cmd :f :shift
                :j :rightshift :k :rightcmd :l :rightalt ";" :rightctrl})

(local flags-map {:deviceLeftAlternate :alt
                  :deviceLeftCommand :cmd
                  :deviceLeftControl :ctrl
                  :deviceLeftShift :shift
                  :deviceRightAlternate :rightalt
                  :deviceRightCommand :rightcmd
                  :deviceRightControl :rightctrl
                  :deviceRightShift :rightshift})

(var state (collect [_k v (pairs mod-map) &into {:pending nil}]
             (values v false)))

(fn waiting? []
  "Has a mod or pending?"
  (accumulate [ret state.pending _k v (pairs mod-map)]
    (or ret (. state v))))

;; (fn synthesize [evt]
;;   "Synthesize down and up events with current state of mods"
;;   (local flags (icollect [_k v (ipairs [(when (or state.rightcmd) :cmd)])] v))
;;   (print :Synthesize (pp {:state state :flags flags}))
;;   (let [code (evt:getKeyCode)
;;         new-evts (hs.eventtap.event.newKeyEventSequence flags code)]
;;     (print :Synthesize (pp (icollect [k v (pairs new-evts)]
;;                              {:char (v:getCharacters)
;;                               :code (v:getKeyCode)
;;                               :flags (v:getFlags)})))
;;     new-evts))

(fn synthesize [evt]
  "Synthesize down and up events with current state of mods"
  ;; pairs is needed instead of ipairs because the array contains holes
  (local flags (icollect [_k v (pairs [(when (or state.rightcmd state.cmd) :cmd)
                                       (when (or state.rightalt state.alt) :alt)
                                       (when (or state.rightctrl state.ctrl) :ctrl)
                                       (when (or state.rightshift state.shift) :shift)])]
                 v))
  ;; (print :Synthesize (pp {:state state :flags flags}))
  (let [code (evt:getKeyCode)
        down-evt (hs.eventtap.event.newKeyEvent flags code true)
        up-evt (hs.eventtap.event.newKeyEvent flags code false)
        new-evts [down-evt up-evt]]
    (print :Synthesize (pp (icollect [k v (pairs new-evts)]
                             {:char (v:getCharacters)
                              :code (v:getKeyCode)
                              :flags (v:getFlags)})))
    new-evts))

(fn synthesis? [evt]
  "Is event synthetic?"
  ;; (print "Synthesis?")
  (let [id (evt:getProperty hs.eventtap.event.properties.eventSourceStateID)]
    (not (= id 1))))

(fn pp-evt [msg evt]
  "Pretty print an event"
  (let [props [:eventSourceGroupID
               :eventSourceStateID
               :eventSourceUnixProcessID
               :eventSourceUserData
               :eventSourceUserID
               :eventTargetProcessSerialNumber
               :eventTargetUnixProcessID]]
    (print msg
           (pp (collect [_k v (ipairs props)]
                 (values v (evt:getProperty (. hs.eventtap.event.properties v))))))))

(local down (hs.eventtap.new [hs.eventtap.event.types.keyDown]
                             (fn [evt]
                               "Handle keyDown event"
                               ;; (print "DOWN")
                               (if (synthesis? evt) false
                                   (let [code (evt:getKeyCode)
                                         char (. hs.keycodes.map code)]
                                     ;; (print :Down (pp {:code code :char char :state state}))
                                     ;; (pp-evt :Down evt)
                                     (case (. mod-map char) ;; is char a mod?
                                       mod (do
                                             (if ;; is the mod active? Do nothing
                                              (. state mod)
                                              nil
                                              ;; is the mod pending? Promote it as the mod, un-pending it
                                              (= state.pending code)
                                              (do
                                                (tset state mod true)
                                                (set state.pending nil))
                                              ;; another mod pending? Set it as the mod, pending current code
                                              state.pending
                                              (let [pending-mod (->> (. hs.keycodes.map
                                                                        state.pending)
                                                                     (. mod-map))]
                                                (tset state pending-mod true)
                                                (set state.pending code))
                                              ;; nope. Set it as pending
                                              (set state.pending code))
                                             true)
                                       ;; not a mod, send the event if not in waiting state
                                       _ (waiting?)))))))

(local up
       (hs.eventtap.new [hs.eventtap.event.types.keyUp]
                        (fn [evt]
                          "Handle keyUp event"
                          ;; (print "UP")
                          (if (synthesis? evt) false
                              (let [code (evt:getKeyCode)
                                    char (. hs.keycodes.map code)]
                                ;; (print :Up (pp {:code code :char char :state state}))
                                ;; (pp-evt :Up evt)
                                (case (. mod-map char) ;; is char a mod?
                                  mod (do
                                        (tset state mod false)
                                        (if (= state.pending code)
                                            ;; is the mod pending? Synthesize it as a key
                                            (do
                                              (set state.pending nil)
                                              (values true (synthesize evt)))
                                            ;; nope. Skip the key
                                            true))
                                  ;; not a mod, send the event if not in waiting state, otherwise
                                  _ (when (waiting?)
                                      (let [new-evts []]
                                        ;; two possibilities here
                                        ;; has a pending key? Synthesize it
                                        (when state.pending
                                          (icollect [_k v (ipairs (synthesize (hs.eventtap.event.newKeyEvent
                                                                               []
                                                                               state.pending
                                                                               true))) &into new-evts]
                                            v)
                                          (set state.pending nil))
                                        ;; has a pending key? Promote it as a mod, un pending it
                                        ;; (when state.pending
                                        ;;   (let [pending-mod (->> state.pending
                                        ;;                          (. hs.keycodes.map)
                                        ;;                          (. mod-map))]
                                        ;;     (tset state pending-mod true)
                                        ;;     (set state.pending nil)))
                                        ;; synthesize the current key stroke
                                        (icollect [_k v (ipairs (synthesize evt)) &into new-evts]
                                          v)
                                        (values true new-evts)))))))))

(local change
       (hs.eventtap.new [hs.eventtap.event.types.flagsChanged]
                        (fn [evt]
                          "Handle flagsChanged"
                          (let [flags (evt:rawFlags)]
                            (each [k v (pairs flags-map)]
                              (let [mask (. hs.eventtap.event.rawFlagMasks k)]
                                (tset state v (> (band flags mask) 0))))))))

(down:start)
(up:start)
(change:start)