(define-module (zephyr zmk)
  #:use-module (guix build union)
  #:use-module (guix build utils)
  #:use-module (guix build-system trivial)
  #:use-module (guix gexp)
  #:use-module (guix git-download)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:use-module (ice-9 optargs)
  #:use-module (srfi srfi-1)
  #:use-module (zephyr)
  #:use-module (zephyr apps)
  #:use-module (zephyr modules))

(define zmk-config
  (package
    (name "zmk-config")
    (version "0")
    (source #f)
    (build-system trivial-build-system)
    (arguments (list #:builder #~(mkdir #$output)))
    (native-search-paths
     (list
      (search-path-specification
      (variable "ZMK_CONFIG")
      (files '("zmk-config"))
      (separator #f)
      (file-type 'directory)
      (file-pattern "^config$"))))
    (home-page "https://zmk.dev/docs/config#config-file-locations")
    (synopsis "ZMK firmware configuration")
    (description "This ZMK Firmware configuration is a helper to set the
ZMK_CONFIG environment varibale during a ZMK Firmware package build to its
configuration input.  Add a file-like object like a file-union or a package
containing a zmk-config/config folder as build input to a ZMK Firmare packege.")
    (license license:expat)))
    
    
(define*-public (make-zmk board
                          #:key 
                          (shield "") 
                          (extra-inputs '())
                          (extra-name "")
                          (patches '())
                          snippet)
  "Make a ZMK firmware package for a keyboard consisting of an Arm
microcontroller BOARD with a SHIELD PCB using the list of EXTRA-INPUTS.  Add an
EXTRA-NAME with a trailing hyphen to customize the package name.  Use PATCHES or
SNIPPET to modify the ZMK sources."
  (make-zephyr-application-for-arm
   (let* ((revision "1")
          (commit "9d714c0b69fee2098a010d29e534051aeca26386")
          (underscore->hyphen (lambda (name)
                                (string-map (lambda (char)
                                              (if (char=? char #\_) 
                                                  #\- 
                                                  char))
                                             name)))
          (board-name (underscore->hyphen board))
          (shield-name (underscore->hyphen shield))
          (shield (if (string-null? shield) #f shield)))
     (package
       (name (string-append shield-name (if shield "-" "")
                            extra-name board-name "-zmk"))
       (version (git-version "2023.06.12" revision commit))
       (source (origin
                 (method git-fetch)
                 (uri (git-reference
                      (url "https://github.com/zmkfirmware/zmk")
                      (commit commit)))
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
                   "08mihhcdlb9hh1qa0l6limggmvy98qiq6051p9qhnh6zbs8021h7"))
                 (patches patches)
                 (snippet snippet)))
       (build-system #f)
       (arguments
        (list
         #:out-of-source? #t
         #:configure-flags
         #~(append (list "-S../source/app"
                         (string-append "-DBOARD=" #$board))
                   (if #$shield
                       (list (string-append "-DSHIELD=" #$shield))
                       '()))))
       (inputs (append extra-inputs
                       (list zephyr-module-cmsis
                             zephyr-module-lvgl
                             zephyr-module-tinycrypt
                             zmk-config)))
       (home-page "https://zmk.dev")
       (synopsis (if shield (format #f "ZMK Firmware for a ~a keyboard with ~a"
                                       shield-name board-name)
                            (format #f "ZMK Firmware for a ~a keyboard"
                                       board-name)))
       (description "ZMK Firmware is an open source (MIT) keyboard firmware
built on the Zephyr™ Project Real Time Operating System (RTOS).")
       (license license:expat)))
    #:zephyr zephyr-3.2+zmk-fixes
    #:source-prefix "zmk"))

(define*-public (make-nrfmicro-13-zmk shield #:key zmk-config (extra-name ""))
  "Make a ZMK firmware package for a keyboard consisting of the nrfmicro 1.3/1.4
board with a SHIELD PCB.  Use the ZMK-CONFIG directory containing optional 
boards/ or dts/ directories, or .conf, .keypad, .overlay files prefixed with
shield or board names."
  (make-zmk
   "nrfmicro_13"
   #:shield shield
   #:extra-name extra-name
   #:extra-inputs (append (list zephyr-module-hal-nordic-2.11)
                          (if zmk-config (list zmk-config)
                                         '()))
   #:snippet
   #~(begin
       (use-modules (guix build utils))
       (substitute* "app/CMakeLists.txt"
         ;; Move combo.c and behaviour_tap_dance.c above all other behaviors.
         (("^  target_sources\\(app PRIVATE src/combo.c\\)\n") "")
         (("^  target_sources\\(app PRIVATE src/behaviors/behavior_tap_dance.c\\)\n")
          "")
         (("^  target_sources\\(app PRIVATE src/hid.c\\)\n" line)
          (string-append
           line
           "  target_sources(app PRIVATE src/combo.c)\n"
           "  target_sources(app PRIVATE src/behaviors/behavior_tap_dance.c)\n"))))))

(define*-public (make-zmk-union zmk-packages #:key name synopsis)
  "Make a union of several ZMK Firmware packages for left and right hand or
settings-reset firmware files."
  (package
    (inherit (car zmk-packages))
    (name (or name (package-name (car zmk-packages))))
    (source #f)
    (build-system trivial-build-system)
    (arguments
      (list #:modules '((guix build union))
            #:builder
            #~(begin
                (use-modules ((guix build union)))
                (union-build #$output (quote #$zmk-packages)))))
    (synopsis (or synopsis (package-synopsis (car zmk-packages))))))

(define (hid-modifier modifier)
  (define hid-modifier->zmk-macro
    '((⇧ . LS) (⌃ . LC) (⌥ . LA) (⌘ . LG) 
      (R⌘ . RG) (R⌥ . RA) (R⌃ . RC) (R⇧ . RS)))
  (or (assoc-ref hid-modifier->zmk-macro modifier) modifier))

(define-public (special-bindings key-label)
  (define special-bindings->zmk-name
    '(;; A whole in the keyboard matrix without meaning to ZMK.
      (◌ . "")
      ;; No functionality.
      (☒ . &none)
      ;; Fall-through to the next active lower layer.
      (☐ . &trans)
      ;; Keypress on sensor, requires two parameters for up and down keycodes.
      (⟳ . &inc_dec_kp)
      ;; Reset and bootloader, on split keyboards this is side specific.
      (⎊ . &sys_reset) (↯ . &bootloader)
      ;; Bluetooth, requires one or two parameters.
      (⌔ . &bt)
      ;; Backlight, requires one parameter.
      (☼ . &bl)))
  (or (assoc-ref special-bindings->zmk-name key-label) key-label))
    
(define-public (hid key-label)
  (define hid->zmk-name
    '((⎋ . ESC) (⎙ . PSCRN) (⤓ . SLCK) (⎉ . PAUSE_BREAK)
      (^ . GRAVE) (- . MINUS)
      (= . EQUAL) (⌫ . BSPC)
      (⇥ . TAB) (⟦ . LBKT) (⟧ . RBKT) (↲ . RET) (⏎ . RET) (↩ . RET)
      (⇪ . CAPS) (⍮ . SEMI) (⍘ . SQT) (⋕ . NUHS)
      (⇧ . LSHFT) (\ . NUBS)
      (‚ . COMMA) (· . DOT) (/ . SLASH) (R⇧ . RSHFT)
      (⌃ . LCTRL) (⌥ . LALT) (⌘ . LGUI) (␣ . SPC)
      (R⌘ . RGUI) (R⌥ . RALT) (R⌃ . RCTRL) (☰ . K_APP)
      (⌵ . INS) (⇱ . HOME) (↖ . HOME) (⇞ . PG_UP)
      (⌦ . DEL) (⇲ . END) (↘ . END) (⇟ . PG_DN)
      (← . LEFT) (↓ . DOWN) (↑ . UP) (→ . RIGHT)
      (⇠ . LEFT) (⇣ . DOWN) (⇡ . UP) (⇢ . RIGHT)
      (⇭ . KP_NUMLOCK) (NUM . KP_NUMLOCK)
      (⌧ . KP_CLEAR) (⟨ . KP_LPAR) (⟩ . KP_RPAR) (P= . KP_EQUAL)
      (÷ . KP_DIVIDE) (* . KP_MULTIPLY) (− . KP_MINUS) (+ . KP_PLUS)
      (P1 . KP_N1) (P2 . KP_N2) (P3 . KP_N3) (P4 . KP_N4) (P5 . KP_N5)
      (P6 . KP_N6) (P7 . KP_N7) (P8 . KP_N8) (P9 . KP_N9) (P0 . KP_N0)
      (P. . KP_DOT) (P, . KP_COMMA) (⌤ . ENTER)   
      (✄ . C_AC_CUT) (◫ . C_AC_COPY) (⎀ . C_AC_PASTE)
      (↶ . C_AC_UNDO) (↷ . C_AC_REDO)
      (⌨ . C_AL_KEYBOARD_LAYOUT)))
  (special-bindings (or (assoc-ref hid->zmk-name key-label) key-label)))
    
(define-public (de key-label)
  (define de->hid
    '((ß . -) (´ . =)
      (Z . Y) (Ü . ⟦) (+ . ⟧)
      (Ö . ⍮) (Ä . ⍘)
      (< . \) (Y . Z) (- . /)
      (P+ . +) (P, . P.) (P. . P,)))
  (hid (or (assoc-ref de->hid key-label) key-label)))
  
(define-public (neo key-label)
  (define neo->de
   '((T1 . ^)                                                    
               (X . Q) (V . W) (L . E) (C . R) (W . T)
     (M3 . ⇪)  (U . A) (I . S) (A . D) (E . F) (O . G)
     (M4 . <) (Ü . Y) (Ö . X) (Ä . C) (P . V) (Z . B)
                                             (- . ß) (T2 . ´) 
     (K . Z) (H . U) (G . I) (F . O) (Q . P) (ẞ . Ü) (T3 . +)
     (S . H) (N . J) (R . K) (T . L) (D . Ö) (Y . Ä) (RM3 . ⋕)
     (B . N)                         (J . -) (RM4 . R⌥)
     (P⇥ . ⇭)))
  (de (or (assoc-ref neo->de key-label) key-label)))

(define*-public (zmk-keymap #:key (properties '())
                                  (behaviors '())
                                  (combos '())
                                  (conditional_layers '())
                                  (layers '())
                                  (macros '()))
  "Generate the content of a keymap file for ZMK.  Each layer in LAYERS has a
name, a layout and multiple rows, of which each contains the key-bindings.  The
last row contains the bindings for sensors.  The key-bindings use symbols on
LAYOUT.  The BEHAVIORS, COMBOS, MACROS and CONDITIONAL-LAYERS contain lists of
strings to inject own appropiate definitions for ZMK.  PROPERTIES may contain
properties for behaviors or even C macro definitions."
  (define (include file)
    "Return an include statement for file"
    (string-append "#include <" file ">"))
  (define (include-binding file)
    "Return an include statement for file defining bindings."
    (include (string-append "dt-bindings/zmk/" file)))
  (define (includes)
    "Return all include statements offered by ZMK for keymap files."
    (append (map include '("behaviors.dtsi"))
            (map include-binding '("backlight.h" "bt.h" "ext_power.h"
                                   "hid_usage.h" "hid_usage_pages.h" "keys.h"
                                   "kscan_mock.h" "matrix_transform.h"
                                   "modifiers.h" "outputs.h" "reset.h"
                                   "rgb.h"))))

  (define* (keymap-layer name layout rows)
    "Return a string with a keymap layer definition NAME for a ZMK keymap file,
consisting of KEYS with their labels based on LAYOUT."

    (define (zmk-name->string zmk-name)
      "Tansform a ZMK-NAME into a string."
      (cond ((string? zmk-name) zmk-name)
            ((number? zmk-name) (number->string zmk-name))
            (else (symbol->string zmk-name))))

    (define (key-label->zmk key-label)
      "Tansform a key-label based on a keyboard-layout into a ZMK string."
      (zmk-name->string (layout key-label)))

    (define (modified-key->zmk modified-key)
      "Transform a possibly MODIFIED-KEY like '(⇧ ⌥ ⎋) into the \"LS((LA(ESC))\"
respresentation of ZMK."
      (match modified-key
        ((modifier modifier-or-key . rest)
         (string-append (zmk-name->string (hid-modifier modifier))
                        "("
                        (modified-key->zmk (cdr modified-key))
                        ")"))
        ((unmodified-key)
         (modified-key->zmk unmodified-key))
        (key-label
         (key-label->zmk key-label))))
                   
    (define (behavior->zmk behavior strings-of-layers-and-modified-keys)
      "Join a BEHAVIOR symbol like '&mt with STRINGS-OF-LAYERS-AND-MODIFIED-KEYS
as parameters like '(\"LALT\" \"ESC\") into the \"&mt LALT ESC\" respresentation
of ZMK."
      (string-join (cons (key-label->zmk behavior)
                   strings-of-layers-and-modified-keys)))

    (define (&-symbol? symbol)
      "Predicate to identify a symbol as a ZMK behavior prefixed with &."
      (string=? "&" (string-take (key-label->zmk symbol) 1)))

    (define (key-binding->zmk key-binding)
      "Transform the KEY-BINDING, which could be a key-label, a modified key, or
a behavior with layer and modified key parameters, into the representation of a
ZMK behavior for a keymap layer."
      (match key-binding
        (((? &-symbol? behavior) . parameters)
          ;; A list starting with an &-symbol is a behavior with parameters.
          ;; The parameters themselves may be layers or modified keys.
          (behavior->zmk behavior (map modified-key->zmk parameters)))
        (modified-key
          (let ((modified-key (modified-key->zmk modified-key)))
            (if (or (string-null? modified-key)
                    (&-symbol? modified-key))
                ;; There is nothing or a behavior is present, just use it.
                modified-key
                ;; Add a key-press behavior to the modified-key and start over.
                (behavior->zmk '&kp (list modified-key)))))))

    (define (keys->zmk key-bindings)
      "Transform a list of KEY-BINDINGS into ZMK behaviors for a keymap layer."
      (string-join (map (lambda (zmk-behavior)
                          (string-pad-right
                           zmk-behavior
                           (max 12 (string-length zmk-behavior)))) 
                        (map key-binding->zmk key-bindings))))

    (string-append  "    " name "_layer {"
                    "\n      bindings = <"
                    (string-join (map keys->zmk (drop-right rows 1)) 
                                 "\n        " 'prefix)
                    "\n      >;"
                    (if (null? (last rows))
                        ""
                        (string-append
                         "\n      sensor-bindings = <"
                         (string-join (map keys->zmk (last rows))
                                      "\n        " 'prefix)
                         "\n      >;"))
                    "\n    };"))

  (define (layer layer)
    "Return a string for a ZMK keymap file containing a layer definition."
    (match layer
      ((name layout . rows)
       (keymap-layer name layout rows))))

  (string-join (append (includes)
                       properties
                       (list "/ {"
                             "  behaviors {")
                       behaviors
                       (list "  };"
                             "  combos {"
                             "    compatible = \"zmk,combos\";")
                       combos
                       (list "  };"
                             "  conditional_layers {"
                             "    compatible = \"zmk,conditional_layers\";")
                       conditional_layers
                       (list "  };"
                             "  keymap {"
                             "    compatible = \"zmk,keymap\";")
                       (map layer layers)
                       (list "  };"
                             "  macros {")
                       macros
                       (list "  };"
                             "};"))
               "\n"))

;; This is a hold-tap behavior for a key, which momentarily activates a layer,
;; if hold, or switches to that layer, if tapped.
(define-public layer-hold-tap
"    /omit-if-no-ref/ lht: behavior_layer_hold_tap {
      compatible = \"zmk,behavior-hold-tap\";
      label = \"LAYER_HOLD_TAP\";
      #binding-cells = <2>;
      flavor = \"balanced\";
      tapping-term-ms = <200>;
      bindings = <&mo>, <&to>;
    };
")

(define-public (layer-tap-dance n)
  "Give a tap-dance behavior '&ltdN', which counts the taps for the layer number
and momentarily activates that layer on hold, or switches to that layer on tap.
If the parameter N is 0, then taps select the layers 1, 2, 3.  If N is 1, taps
select the layers 0, 2, 3, and so on."
  (let ((first (if (>= n 1) "0 0" "1 1"))
         (second (if (>= n 2) "1 1" "2 2"))
         (third (if (>= n 3) "2 2" "3 3"))
         (n (number->string n)))
    (string-append
"    /omit-if-no-ref/ ltd" n ": behavior_layer_tap_dance" n " {
      compatible = \"zmk,behavior-tap-dance\";
      label = \"LAYER_TAP_DANCE" n "\";
      #binding-cells = <0>;
      tapping-term-ms = <200>;
      bindings = <&lht " first ">, <&lht " second ">, <&lht " third ">;
    };
")))

(define-public settings-reset-nrfmicro-13-zmk
  (package
    (inherit (make-nrfmicro-13-zmk "settings_reset"))
    (synopsis "ZMK settings reset firmware for split-keyboards with nrfmicro
1.3/1.4 boards")
    (description "Pairing issues of ZMK firmware split-keyboard halves can be
resolved by flashing this settings reset firmware to both controllers.")))

(define-public redox-left-nrfmicro-13-zmk
  (make-nrfmicro-13-zmk "redox_left"))

(define-public redox-right-nrfmicro-13-zmk
  (make-nrfmicro-13-zmk "redox_right"))

(define-public redox-nrfmicro-13-zmk
  (make-zmk-union
   (list settings-reset-nrfmicro-13-zmk
         redox-left-nrfmicro-13-zmk
         redox-right-nrfmicro-13-zmk)
   #:name "redox-nrfmicro-13-zmk"
   #:synopsis "ZMK firmware for a Redox shield with nrfmicro-1.3/1.4 board"))

(define-public redox-neo-keymap
  (let* ((M3Y '(&mt RM3 Y))
         (⇧- '(&mt ⇧ -))
         (R⇧ẞ '(&mt R⇧ ẞ))
         (⌥- '(&mt ⌥ -))
         (⌥. '(&mt ⌥ ·))
         (l1␣ '(&lt 1 ␣))
         (to0 '(&to 0)) ; Switch to layer 0.
         (l0 '(&ltd0)) ; Layer dancing for layer 0.
         (l1 '(&ltd1)) ; Layer dancing for layer 1.
         (l2 '(&ltd2)) ; Layer dancing for layer 2.
         (l3 '(&ltd3)) ; Layer dancing for layer 3.
         (⌔1 '(⌔ BT_SEL 0))
         (⌔2 '(⌔ BT_SEL 1))
         (⌔3 '(⌔ BT_SEL 2))
         (⌔4 '(⌔ BT_SEL 3))
         (⌔5 '(⌔ BT_SEL 4))
         (⌔⌧ '(⌔ BT_CLR))
         (⌔→ '(⌔ BT_NXT))
         (⌔← '(⌔ BT_PRV))
         (keymap
          (zmk-keymap
           #:layers
           `(("default" ,neo
              ( ⎋   N1  N2  N3  N4  N5  ◌   ◌   ◌   ◌   N6  N7  N8  N9  N0  ⌫  )         
              ( ⇥   X   V   L   C   W   T2  ◌   ◌   ☰   K   H   G   F   Q   ↲  )    
              ( M3  U   I   A   E   O   T3  ◌   ◌   ⌵   S   N   R   T   D  ,M3Y)
              (,⇧-  Ü   Ö   Ä   P   Z   ⇧   ⌘   R⌘  R⇧  B   M   ‚   ·   J  ,R⇧ẞ)
              ( ⌃   ⌥   T1  ⌦  ,l0  ◌   ⌃   M4  RM4 R⌃  ◌  ,l1␣ ⌦  ,l0 ,⌥-  R⌃ )
              ())
             ("cursor" ,neo
              ( ⎋   F1  F2  F3  F4  F5  ◌   ◌   ◌   ◌   F6  F7  F8  F9  F10 ⌫  )         
              ( ⇥   ⇞   ⌫   ↑   ⌦   ⇟   ⎉   ◌   ◌   ☒   ⇞   ⌫   ↑   ⌦   ⇟   ↲  )    
              ( ☒   ⇱   ←   ↓   →   ⇲   ☒   ◌   ◌   ☒   ⇱   ←   ↓   →   ⇲   ☒  )
              (,⇧-  ⎋   ⇥   ⎀   ↲   ↶   ⇧   ⌘   R⌘  ⇧   ⎋   ⇥   ⎀   ↲   ↶   R⇧ )
              ( ⌃   ⌥   ⎙   ⌦  ,l1  ◌   ⌃   ⌥   ⌥   R⌃  ◌   ␣   ⌦  ,l1 ,⌥-  R⌃ )
              ())
             ("keypad" ,neo
              ( ⎋   F11 F12 F13 F14 F15 ◌   ◌   ◌   ◌   ⎋   P⇥  ÷   *   −   ⌫  )         
              ( ⇥   ⇞   ⌫   ↑   ⌦   ⇟   ☒   ◌   ◌   ⇭   ☒   P7  P8  P9  P+  ↲  )    
              ( M3  ⇱   ←   ↓   →   ⇲   ☒   ◌   ◌   ☒   ☒   P4  P5  P6  P=  M3 )
              (,⇧-  ⎋   ⇥   ⎀   ↲   ↶   ⇧   ⌘   R⌘  R⇧  ␣   P1  P2  P3  ⌤   R⇧ )
              ( ⌃   ⌥   ☒   ⌦  ,l2  ◌   ⌃   M4  RM4 R⌃  ◌   P0  ⌦   P, ,⌥.  R⌃ )
              ())
             ("zmk" ,neo
              ( ⎊  ,⌔1 ,⌔2 ,⌔3 ,⌔4 ,⌔5  ◌   ◌   ◌   ◌   ☒   ☒   ☒   ☒   ☒   ⎊  )         
              ( ↯   ☒   ☒   ☒   ☒   ☒   ☒   ◌   ◌   ☒   ☒   ☒   ☒   ☒   ☒   ↯  )    
              ( ☒   ☒  ,⌔← ,⌔⌧ ,⌔→  ☒   ☒   ◌   ◌   ☒   ☒   ☒   ☒   ☒   ☒   ☒  )
              ( ☒   ☒   ☒   ☒   ☒   ☒   ☒   ☒   ☒   ☒   ☒   ☒   ☒   ☒   ☒   ☒  )
              ( ☒   ☒   ☒   ☒  ,l3  ◌   ☒   ☒   ☒   ☒   ☒   ☒   ☒  ,l3  ☒   ☒  )
              ()))
           #:properties (list "&lt {quick-tap-ms = <200>;};"
                              "&mt {quick-tap-ms = <200>;};")
           #:combos (list "    combo_up {" ; G F ⇒ ↑
                          "      key-positions = <22 23>;"
                          "      bindings = <&kp UP>;"
                          "    };"
                          "    combo_left {" ; N R ⇒ ←
                          "      key-positions = <35 36>;"
                          "      bindings = <&kp LEFT>;"
                          "    };"
                          "    combo_down {" ; R T ⇒ ↓
                          "      key-positions = <36 37>;"
                          "      bindings = <&kp DOWN>;"
                          "    };"
                          "    combo_right {" ; T D ⇒ →
                          "      key-positions = <37 38>;"
                          "      bindings = <&kp RIGHT>;"
                          "    };")
           #:behaviors (list layer-hold-tap
                             (layer-tap-dance 0)
                             (layer-tap-dance 1)
                             (layer-tap-dance 2)
                             (layer-tap-dance 3)))))
    (file-union "redox-config"
                (list (list "zmk-config/config/redox.keymap"
                            (plain-file "redox-neo.keymap" keymap))))))

(define-public redox-left-neo-nrfmicro-13-zmk
  (make-nrfmicro-13-zmk "redox_left"
                        #:zmk-config redox-neo-keymap
                        #:extra-name "neo-"))

(define-public redox-right-neo-nrfmicro-13-zmk
  (make-nrfmicro-13-zmk "redox_right"
                        #:zmk-config redox-neo-keymap
                        #:extra-name "neo-"))

(define-public redox-neo-nrfmicro-13-zmk
  (make-zmk-union
   (list settings-reset-nrfmicro-13-zmk
         redox-left-neo-nrfmicro-13-zmk
         redox-right-neo-nrfmicro-13-zmk)
   #:name "redox-neo-nrfmicro-13-zmk"
   #:synopsis
   "Neo layout ZMK firmware for a Redox shield with nrfmicro-1.3/1.4 board"))