home: services: Support options for bindings in sway-service-type.

* gnu/home/services/sway.scm (make-alist-predicate): Add an optional argument.
  (bindings?): Remove procedure.
  (keybinding-options?): New procedures.
  (codebinding-options?): New procedures.
  (gesture-options?): New procedures.
  (mouse-bindings?): Allow to pass options to mouse-bindings.
  (sway-configuration) [keybindings]: Allow to pass options to key-bindings.
  [gestures]: Allow to pass options to gesture-bindings.
  (sway-mode) [keybindings]: Allow to pass options to key-bindings.
  (serialize-binding): Support options.
  (serialize-mouse-binding): Support options.
  (serialize-keybinding): Support options.
  (serialize-gesture): Support options.
  (serialize-variable): Inline previous definition.
* doc/guix.texi (Sway window manager): Document this.

Change-Id: Icf210aca4a9b44adc0baead7430637f6fcda17e5
Signed-off-by: Ludovic Courtès <ludo@gnu.org>

1 files changed, 62 insertions, 22 deletions

diff --git a/gnu/home/services/sway.scm b/gnu/home/services/sway.scm
index eebc65766ea..4e521091900 100644
--- a/gnu/home/services/sway.scm
+++ b/gnu/home/services/sway.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2024 Arnaud Daby-Seesaram <ds-ac@nanein.fr>
+;;; Copyright © 2024, 2025 Arnaud Daby-Seesaram <ds-ac@nanein.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -98,22 +98,54 @@
 (define (extra-content? extra)
   (every string-or-gexp? extra))
 
-(define (make-alist-predicate key? val?)
+(define* (make-alist-predicate key? val? #:optional (options? (lambda _ #f)))
   (lambda (lst)
     (every
      (lambda (item)
        (match item
+         ((k v . o)
+          (and (key? k)
+               (val? v)
+               (options? o)))
          ((k . v)
           (and (key? k)
                (val? v)))
          (_ #f)))
      lst)))
 
-(define bindings?
-  (make-alist-predicate symbol? string-or-gexp?))
+(define (keybinding-options? lst)
+  (every
+   (lambda (e)
+     (or (member e
+                 '("no-warn" "whole-window" "border" "exclude-titlebar"
+                   "release" "locked" "inhibited" "no-repeat"))
+         (string-prefix? "input-device=" e)))
+   lst))
+
+(define (codebinding-options? lst)
+  (every
+   (lambda (e)
+     (or (member e
+                 '("no-warn" "whole-window" "border" "exclude-titlebar"
+                   "release" "locked" "to-code" "inhibited" "no-repeat"))
+         (string-prefix? "input-device=" e)))
+   lst))
+
+(define (gesture-options? lst)
+  (every
+   (lambda (e)
+     (or (member e '("exact" "no-warn"))
+         (string-prefix? "input-device=" e)))
+   lst))
+
+(define key-bindings?
+  (make-alist-predicate symbol? string-or-gexp? keybinding-options?))
+
+(define gestures?
+  (make-alist-predicate symbol? string-or-gexp? gesture-options?))
 
 (define mouse-bindings?
-  (make-alist-predicate integer? string-or-gexp?))
+  (make-alist-predicate integer? string-or-gexp? codebinding-options?))
 
 (define (variables? lst)
   (make-alist-predicate symbol? string-ish?))
@@ -266,7 +298,7 @@
    (string "default")
    "Name of the mode.")
   (keybindings
-   (bindings '())
+   (key-bindings '())
    "Keybindings.")
   (mouse-bindings
    (mouse-bindings '())
@@ -277,10 +309,10 @@
 
 (define-configuration/no-serialization sway-configuration
   (keybindings
-   (bindings %sway-default-keybindings)
+   (key-bindings %sway-default-keybindings)
    "Keybindings.")
   (gestures
-   (bindings %sway-default-gestures)
+   (gestures %sway-default-gestures)
    "Gestures.")
   (packages
    (list-of-packages
@@ -554,29 +586,37 @@
 (define-inlinable (serialize-boolean-ed b)
   (if b "enable" "disable"))
 
-(define-inlinable (serialize-binding binder key value)
-  #~(string-append #$binder #$key " " #$value))
+(define-inlinable (serialize-binding binder key value options)
+  #~(string-append
+     #$binder
+     #$(string-join options " --" 'prefix) " "
+     #$key " " #$value))
 
 (define (serialize-mouse-binding var)
-  (let* ((ev (car var))
-         (ev-code (number->string ev))
-         (command (cdr var)))
-    (serialize-binding "bindcode " ev-code command)))
+  (match var
+    ((ev command . options)
+     (serialize-binding "bindcode" (number->string ev) command options))
+    ((ev . command)
+     (serialize-binding "bindcode" (number->string ev) command '()))))
 
 (define (serialize-keybinding var)
-  (let ((name (symbol->string (car var)))
-        (value (cdr var)))
-    (serialize-binding "bindsym " name value)))
+  (match var
+    ((name value . options)
+     (serialize-binding "bindsym" (symbol->string name) value options))
+    ((name . value)
+     (serialize-binding "bindsym" (symbol->string name) value '()))))
 
 (define (serialize-gesture var)
-  (let ((name (symbol->string (car var)))
-        (value (cdr var)))
-    (serialize-binding "bindgesture " name value)))
+  (match var
+    ((name value . options)
+     (serialize-binding "bindgesture" (symbol->string name) value options))
+    ((name . value)
+     (serialize-binding "bindgesture" (symbol->string name) value '()))))
 
 (define (serialize-variable var)
   (let ((name (symbol->string (car var)))
         (value (cdr var)))
-    (serialize-binding "set $" name value)))
+    #~(string-append "set $" #$name " " #$value)))
 
 (define (serialize-exec b)
   (if b
@@ -743,7 +783,7 @@
     (computed-file
      "sway-config"
      #~(begin
-         (use-modules (ice-9 format) (ice-9 match) 
+         (use-modules (ice-9 format) (ice-9 match)
                       (srfi srfi-1))
 
          (call-with-output-file #$output