104 lines
4.5 KiB
Scheme
104 lines
4.5 KiB
Scheme
(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))
|
|
|
|
(define-configuration home-xbindkeys-configuration
|
|
(package
|
|
(package 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)))
|
|
|
|
(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"
|
|
"--file-guile" #$(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)
|
|
(default-value (home-xbindkeys-configuration))
|
|
(description "Install and configure xbindkeys.")))
|