(define-module (oni home services xbindkeys)
  #:use-module (gnu services configuration)
  #:use-module (gnu packages xdisorg)
  #:use-module (gnu home services)
  #:use-module (gnu home services shepherd)
  #:use-module (gnu home services utils)
  #:use-module (guix packages)
  #:use-module (guix gexp)

  #:export (home-xbindkeys-service-type
            home-xbindkeys-configuration
            home-xbindkeys-extension))

(define-configuration home-xbindkeys-configuration
  (package
   (package xbindkeys)
   "Package to use for setting xbindkeys")
  (keybindings
   (alist '())
   "Keybindings")
  (no-serialization))

(define-configuration home-xbindkeys-extension
  (keybindings
   (alist '())
   "Keybindings")
  (no-serialization))

(define (serialize-keymap parent keymap)
  (string-join
   (let* ((prefixes (filter (λ (pair) (list? (cdr pair))) keymap))
          (others (filter (λ (pair) (not (list? (cdr pair)))) keymap))
          (names (map (λ (_) (gensym)) prefixes)))
     (append
      (map (λ (key-pair sym)
             (format #f "  (define (~s)\n  (ungrab-all-keys)\n  (remove-all-keys)\n  ~a\n  (xbindkey-function '(control g) (reset-higher-level-binding ~a))\n  (xbindkey-function '(Return) (reset-higher-level-binding ~a))\n  (xbindkey-function '(Escape) (reset-higher-level-binding ~a))\n  (grab-all-keys))\n"
                     sym
                     (serialize-keymap sym (cdr key-pair))
                     parent
                     parent
                     parent))
           prefixes names)
      (map (λ (key-pair)
             (let ((key (car key-pair)))
               (format #f "  (xbindkey ~s ~s)\n  (xbindkey-function '(release ~s) (reset-higher-level-binding ~a))\n"
                       (if (string? key) key `(quote ,key))
                       (cdr key-pair)
                       (car key-pair)
                       parent)))
           others)))
   "\n"))

(define (home-xbindkeys-configuration-file config)
  (apply mixed-text-file
         "xbindkeysrc.scm"
         "(define (reset-higher-level-binding level) (lambda () (ungrab-all-keys) (remove-all-keys) (level) (grab-all-keys)))\n"
         (let* ((prefixes (filter (λ (pair) (list? (cdr pair)))
                                  (home-xbindkeys-configuration-keybindings config)))
                (others (filter (λ (pair) (not (list? (cdr pair))))
                                (home-xbindkeys-configuration-keybindings config)))
                (names (map (λ (_) (gensym)) prefixes)))
           (append
            (map (λ (key-pair sym)
                   (format #f "  (define (~s)\n  (ungrab-all-keys)\n  (remove-all-keys)\n  ~a\n  (xbindkey-function '(control g) (reset-higher-level-binding ~a))\n  (xbindkey-function '(Return) (reset-higher-level-binding ~a))\n  (xbindkey-function '(Escape) (reset-higher-level-binding ~a))\n  (grab-all-keys))\n"
                           sym
                           (serialize-keymap "first-binding" (cdr key-pair))
                           'first-binding
                           'first-binding
                           'first-binding))
                 prefixes names)
            (list "(define (first-binding)\n"
                  "  \"Top-level bindings\"\n")
            (map (λ (key-pair sym)
                   (let ((key (car key-pair)))
                     (format #f "(xbindkey-function ~s ~s)\n" (if (string? key) key `(quote ,key)) sym)))
                 prefixes names)
            (map (λ (key-pair)
                   (format #f "  (xbindkey (quote ~s) ~s) \n" (car key-pair) (cdr key-pair)))
                 others)
            (list "  )\n"
                  "(first-binding)\n")))))

(define (add-xbindkeys-packages config)
  (list (home-xbindkeys-configuration-package config)))

(define (home-xbindkeys-extensions original-config extension-configs)
  (home-xbindkeys-configuration
   (inherit original-config)
   (keybindings
    (apply append (home-xbindkeys-configuration-keybindings original-config)
           (map home-xbindkeys-extension-keybindings extension-configs)))))

(define (home-xbindkeys-shepherd-service config)
  (list
   (shepherd-service
    (documentation "Start xbindkeys")
    (provision '(xbindkeys))
    (auto-start? #t)
    (start
     #~(make-forkexec-constructor
        (list #$(file-append (home-xbindkeys-configuration-package config) "/bin/xbindkeys")
              "--nodaemon"
              "-fg" #$(home-xbindkeys-configuration-file config))
        #:log-file (format #f "~a/.local/var/log/xbindkeys.log" (getenv "HOME"))))
    (stop #~(make-kill-destructor)))))

(define home-xbindkeys-service-type
  (service-type
   (name 'home-xbindkeys)
   (extensions
    (list (service-extension
           home-profile-service-type
           add-xbindkeys-packages)
          (service-extension
           home-shepherd-service-type
           home-xbindkeys-shepherd-service)))
   (compose identity)
   (extend home-xbindkeys-extensions)
   (default-value (home-xbindkeys-configuration))
   (description "Install and configure xbindkeys.")))