[bug#62101] [PATCH] home: services: Add xmodmap.

[conses <contact@conses.eu>]

---
 gnu/home/services/desktop.scm | 109 ++++++++++++++++++++++++++++++++++
 1 file changed, 109 insertions(+)

diff --git a/gnu/home/services/desktop.scm b/gnu/home/services/desktop.scm
index cb25b03b64..b3c60b017e 100644
--- a/gnu/home/services/desktop.scm
+++ b/gnu/home/services/desktop.scm
@@ -22,10 +22,13 @@ (define-module (gnu home services desktop)
   #:use-module (gnu home services shepherd)
   #:use-module (gnu services configuration)
   #:autoload   (gnu packages glib)    (dbus)
+  #:autoload   (gnu packages xorg) (xmodmap)
   #:autoload   (gnu packages xdisorg) (redshift)
+  #:use-module (guix packages)
   #:use-module (guix records)
   #:use-module (guix gexp)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-43)
   #:use-module (ice-9 match)
   #:export (home-redshift-configuration
             home-redshift-configuration?
@@ -226,3 +229,109 @@ (define home-dbus-service-type
    (default-value (home-dbus-configuration))
    (description
     "Run the session-specific D-Bus inter-process message bus.")))
+
+\f
+;;;
+;;; xmodmap
+;;;
+
+(define-configuration/no-serialization home-xmodmap-configuration
+  (xmodmap
+   (package xmodmap)
+   "The @code{xmodmap} package to use.")
+  (config
+   (alist '())
+   "Association list of key and value pairs for the
+ @code{xmodmap} configuration file.  Its syntax can take something like
+the following:
+
+@example
+'((#(add mod4) . Print)
+    (clear lock)
+    (clear control)
+    (#(keycode 66) . Control_L)
+    (#(add control) . #(Control_L Control_R)))
+@end example"))
+
+(define (home-xmodmap-shepherd-service config)
+  (list
+   (shepherd-service
+    (provision '(xmodmap))
+    (start #~(make-system-constructor
+              (string-join
+               (list #$(file-append
+                        (home-xmodmap-configuration-xmodmap config)
+                        "/bin/xmodmap")
+                     #$(home-xmodmap-file config)))))
+    (one-shot? #t))))
+
+(define (get-xmodmap-configuration field-name val)
+  (define serialize-term
+    (match-lambda
+      ((? vector? e)
+       (string-join
+        (vector-fold
+         (lambda (i acc e)
+           (append
+             acc
+             (list (serialize-term e))))
+         '() e) " "))
+      ((? symbol? e) (symbol->string e))
+      ((? number? e) (number->string e))
+      (e e)))
+
+  (define serialize-field
+    (match-lambda
+      ((? list? e)
+       (string-join
+        (map
+         (lambda (x)
+           (serialize-term x))
+         e)
+        " "))
+      ((key . value)
+       (format #f "~a = ~a"
+               (serialize-term key)
+               (serialize-term value)))
+      (key (string-append (serialize-term key)))))
+
+  #~(string-append
+     #$@(interpose
+         (map serialize-field val)
+         "\n" 'suffix)))
+
+(define (home-xmodmap-files-service config)
+  `(("xmodmap/config"
+     ,(home-xmodmap-file config))))
+
+(define (home-xmodmap-file config)
+  (mixed-text-file
+   "config"
+   (get-xmodmap-configuration
+    #f (home-xmodmap-configuration-config config))))
+
+(define (home-xmodmap-profile-service config)
+  (list (home-xmodmap-configuration-xmodmap config)))
+
+(define home-xmodmap-service-type
+  (service-type
+   (name 'home-xmodmap)
+   (extensions
+    (list
+     (service-extension
+      home-profile-service-type
+      home-xmodmap-profile-service)
+     (service-extension
+      home-xdg-configuration-files-service-type
+      home-xmodmap-files-service)
+     (service-extension
+      home-shepherd-service-type
+      home-xmodmap-shepherd-service)))
+   (description "Configure @code{xmodmap} bindings and rules.")
+   (default-value (home-xmodmap-configuration))))
+
+(define (generate-home-xmodmap-documentation)
+  (generate-documentation
+   `((home-xmodmap-configuration
+      ,home-xmodmap-configuration-fields))
+   'home-xmodmap-configuration))
-- 
2.39.1



-- 
Best regards,
conses