1 files changed, 61 insertions, 3 deletions
diff --git a/oni/home/services/xbindkeys.scm b/oni/home/services/xbindkeys.scm
index b8e7cc9..984a163 100644
--- a/oni/home/services/xbindkeys.scm
+++ b/oni/home/services/xbindkeys.scm
@@ -10,10 +10,67 @@
   #:export (home-xbindkeys-service-type
             home-xbindkeys-configuration))
 
-(define-configuration/no-serialization home-xbindkeys-configuration
+(define-configuration home-xbindkeys-configuration
   (package
    (package xbindkeys)
-   "Package to use for setting xbindkeys"))
+   "Package to use for setting xbindkeys")
+  (keybindings
+   (alist '())
+   "Keybindings")
+  (no-serialization))
+
+(define (serialize-keymap parent keymap)
+  (string-join
+   (let* ((prefixes (filter (lambda (pair) (list? (cdr pair))) keymap))
+          (others (filter (lambda (pair) (not (list? (cdr pair)))) keymap))
+          (names (map (lambda (_) (gensym)) prefixes)))
+     (append
+      (map (lambda (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 (lambda (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 (lambda (pair) (list? (cdr pair)))
+                                  (home-xbindkeys-configuration-keybindings config)))
+                (others (filter (lambda (pair) (not (list? (cdr pair))))
+                                (home-xbindkeys-configuration-keybindings config)))
+                (names (map (lambda (_) (gensym)) prefixes)))
+           (append
+            (map (lambda (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 (lambda (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 (lambda (key-pair)
+                   (format #f "  (xbindkey (quote ~s) ~s) \n" (car key-pair) (cdr key-pair)))
+                 others)
+            (list "  )\n")))))
 
 (define (add-xbindkeys-packages config)
   (list (home-xbindkeys-configuration-package config)))
@@ -27,7 +84,8 @@
     (start
      #~(make-forkexec-constructor
         (list #$(file-append (home-xbindkeys-configuration-package config) "/bin/xbindkeys")
-              "--nodaemon")
+              "--nodaemon"
+              "--file-guile" #$(home-xbindkeys-configuration-file config))
         #:log-file (format #f "~a/.local/var/log/xbindkeys.log" (getenv "HOME"))))
     (stop #~(make-kill-destructor)))))