[bug#72714] [PATCH v3] home: services: Add 'home-sway-service-type'.

[Arnaud Daby-Seesaram via Guix-patches via <guix-patches@gnu.org>]

* gnu/home/services/sway.scm: New file.
  (home-sway-service-type): New variable.
  (sway-configuration->file): New procedure.
  (sway-configuration): New configuration record.
  (sway-bar): New configuration record.
  (sway-output): New configuration record.
  (sway-input): New configuration record.
  (point): New configuration record.
  (sway-color): New configuration record.
  (sway-border-color): New configuration record.
  (flatten): New procedure.
* gnu/local.mk: Add gnu/home/services/sway.scm.
* doc/guix.texi (Sway window manager): New node to document the above changes.

Change-Id: Iad4fee02d1c243eb051245277f2e2643523e6d27
---
Minor fix: do not attempt to serialise bar colours if none are specified.

 doc/guix.texi              | 255 +++++++++++++++
 gnu/home/services/sway.scm | 632 +++++++++++++++++++++++++++++++++++++
 gnu/local.mk               |   1 +
 3 files changed, 888 insertions(+)
 create mode 100644 gnu/home/services/sway.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index fcaf6b3fbb..c69a021a77 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -129,6 +129,7 @@
 Copyright @copyright{} 2024 Richard Sent@*
 Copyright @copyright{} 2024 Dariqq@*
 Copyright @copyright{} 2024 Denis 'GNUtoo' Carikli@*
+Copyright @copyright{} 2024 Arnaud Daby-Seesaram@*
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -45161,6 +45162,7 @@ Home Services
 * Messaging: Messaging Home Services.  Services for managing messaging.
 * Media: Media Home Services.   Services for managing media.
 * Networking: Networking Home Services.  Networking services.
+* Sway: Sway window manager.    Setting up the sway configuration.
 * Miscellaneous: Miscellaneous Home Services.  More services.
 @end menu
 @c In addition to that Home Services can provide
@@ -47074,6 +47076,259 @@ Media Home Services
 @end table
 @end deftp
 
+@node Sway window manager
+@subsection Sway window manager
+@cindex Sway, Home service
+
+The @code{(gnu home services sway)} module provides
+@code{home-sway-service-type}, a home service to configure sway in a
+declarative way.
+
+@quotation Note
+This home service only sets up configuration file and profile packages
+for sway.  It does @i{not} start sway in any way.  If you want to do so,
+you might be interested in using @code{greetd-wlgreet-sway-session}
+instead.
+
+The function @code{sway-configuration->file} defined below can be used
+to provide the value for the @code{sway-configuration} field of
+@code{greetd-wlgreet-sway-session}.
+@end quotation
+
+@defvar sway-configuration->file
+This function takes a @code{sway-configuration} record (defined below),
+and returns a file-like object represented the serialized configuration.
+@end defvar
+
+@defvar home-sway-service-type
+This is a home service type to set up Sway.  It takes care of:
+@itemize
+@item
+providing a @file{~/.config/sway/config} file,
+@item
+adding sway-related packages to your profile.
+@end itemize
+
+Here is an example of a service and its configuration that you could add
+to the @code{services} field of your @code{home-environment}:
+
+@lisp
+(define bg-file
+  (computed-file
+   "background.png"
+   #~(let* ((insvg (string-append
+                    #$guix-backgrounds
+                    "/share/backgrounds/guix/guix-checkered-16-9.svg"))
+            (out #$output)
+            (cmd (string-append
+                  #$librsvg "/bin/rsvg-convert " insvg " -o " out)))
+       (system cmd))))
+
+(service home-sway-service-type
+         (sway-configuration
+          (gestures
+           '((swipe:3:down . "move to scratchpad")
+             (swipe:3:up   . "scratchpad show")))
+          (outputs
+           (list (sway-output
+                  (identifier '*)
+                  (bg bg-file))))))
+@end lisp
+
+The above example describes a sway configuration in which
+@itemize
+@item
+all monitors use a particular wallpaper whose @file{.svg} is provided by
+the @code{guix-background} package;
+@item
+swiping down (resp.@ up) with three fingers moves the active window to
+the scratchpad (resp.@ shows/hides the scratchpad).
+@end itemize
+@end defvar
+
+
+@deftp {Data Type} sway-configuration
+This configuration record describes the sway configuration
+(see@ @cite{sway(5)}).  Available fields are:
+
+@table @asis
+@item @code{variables} (default: @code{%sway-default-variables})
+The value of this field is an association list in which keys are symbols
+and values are strings.
+
+Example: @code{'(mod . "Mod4")}.
+
+@item @code{keybindings} (default: @code{%sway-default-keybindings})
+The value of this field is an association list in which keys are symbols
+and values are strings or G-expressions (@pxref{G-Expressions}).
+
+Examples using:
+@itemize
+@item
+a string: @code{'($mod+Return . "exec $term")}
+@item
+a G-exp: @code{`($mod+t . ,#~(string-append #$st "/bin/st"))}
+@end itemize
+
+@item @code{gestures} (default: @code{%sway-default-gestures})
+This value of this field is an association list, as for keybindings.
+
+@item @code{packages} (default: @code{%sway-default-packages})
+This field describes a list of packages to add to the user profile.
+
+@item @code{inputs} (default: @code{(list (sway-input))})
+List of @code{sway-input} configuration records.
+
+@item @code{outputs} (default: @code{'()})
+List of @code{sway-output} configuration records.
+
+@item @code{bar} (default: @code{(sway-bar)})
+Bar configuration.
+
+@item @code{always-execs} (default: @code{'()})
+Programs to execute at startup time @i{and} after every configuration
+reload.  The value of this field is a list of strings or G-expressions.
+
+@item @code{execs} (default: @code{'()})
+Programs to execute at startup time.  The value of this field is a list
+of strings or  G-expressions.
+
+@item @code{extra-content} (default: @code{'()})
+Lines to add to the configuration file.  The value of this field is a
+list of strings or G-expressions.
+
+@end table
+@end deftp
+
+@deftp {Data Type} sway-input
+@code{sway-input} records describe input blocks
+(see@ @cite{sway-input(5)}).  Available fields are:
+
+@table @asis
+@item @code{identifier} (default: @code{'*})
+Identifier of the input.  The field accepts symbols and strings.  If a
+string is used, it will be quoted in the generated configuration file.
+
+@item @code{xkb-layout} (optional)
+Keyboard specific option.  Comma-separated keyboard layout(s) to use.
+
+@item @code{xkb-model} (optional)
+Keyboard specific option.  String providing the keyboard model.
+
+@item @code{xkb-options} (optional)
+Keyboard specific option.  Additional xkb options for the keyboard.
+
+@item @code{xkb-variant} (optional)
+Keyboard specific option.  String specifying the variant of the layout.
+
+@item @code{extra-content} (default: @code{'()})
+Lines to add to the input block.  The value of this field is a list of
+strings or G-expressions.
+
+@end table
+
+For example, the following snippet makes all keyboards use a french
+layout, in which @kbd{capslock} has been remaped to @kbd{ctrl}:
+@lisp
+(sway-input (identifier "type:keyboard")
+            (xkb-layout "fr")
+            (xkb-options '("ctrl:nocaps")))
+@end lisp
+@end deftp
+
+
+@deftp {Data Type} sway-output
+@code{sway-output} records describe sway outputs
+(see@ @cite{sway-output(5)}).  Available fields are:
+
+@table @asis
+@item @code{identifier} (default: @code{'*})
+Identifier of the monitor.  If the
+@code{identifier} is a symbol, it is inserted as is; if it is a string,
+it will be quoted in the configuration file.
+
+@item @code{resolution} (optional)
+This string defines the resolution of the monitor.
+
+@item @code{position} (optional)
+The (optional) value of this field must be a @code{point}.
+Example:
+@lisp
+(position
+ (point (x 1920)
+        (y 0)))
+@end lisp
+
+@item @code{bg} (optional)
+This field accepts a file-like value representing the wallpaper to use
+on this monitor.  It will be used with the @code{fill} option.
+
+@item @code{extra-content} (default: @code{'()})
+Any additional lines to be added to the output configuration block.
+Elements of the list must be either strings or G-expressions.
+
+@end table
+@end deftp
+
+
+@deftp {Data Type} sway-border-color
+
+@table @asis
+@item @code{border} Color of the border.
+@item @code{background} Color of the background.
+@item @code{text} Color of the text.
+@end table
+@end deftp
+
+
+@deftp {Data Type} sway-color
+@table @asis
+@item @code{background}
+@item @code{statusline}
+@item @code{focused-background}
+@item @code{focused-statusline}
+@item @code{focused-workspace}
+@item @code{active-workspace}
+@item @code{inactive-workspace}
+@item @code{urgent-workspace}
+@item @code{binding-mode}
+@end table
+@end deftp
+
+
+@deftp {Data Type} sway-bar
+Describes the Sway bar (see@ @cite{sway-bar(5)}).
+
+@table @asis
+@item @code{identifier} (default: @code{'bar0})
+Identifier of the bar.  The value must be a string.
+
+@item @code{position} (default: @code{'top})
+Specify the position of the bar.  Accepted values are @code{'top} or
+@code{'bottom}.
+
+@item @code{hidden-state} (default: @code{'hide})
+Specify the apparence of the bar when it is hidden.  Accepted values are
+@code{'hide} or @code{show}.
+
+@item @code{binding-mode-indicator} (default: @code{#t})
+Enable or disable the binding mode indicator.
+
+@item @code{colors} (optional)
+An optional @code{sway-color} configuration record.
+
+@item @code{status-command} (default: @code{%sway-status-command})
+This field accept executable file-like values.  The default value is a
+script that prints the battery information (retrieved using
+@code{acpi}), date and time every second.
+
+Each line printed on @code{stdout} by this script will be displayed on
+the status area of the bar.
+
+@end table
+@end deftp
+
+
 @node Networking Home Services
 @subsection Networking Home Services
 
diff --git a/gnu/home/services/sway.scm b/gnu/home/services/sway.scm
new file mode 100644
index 0000000000..91d01f6eb4
--- /dev/null
+++ b/gnu/home/services/sway.scm
@@ -0,0 +1,632 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Arnaud Daby-Seesaram <ds-ac@nanein.fr>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu home services sway)
+  #:use-module (guix monads)
+  #:use-module (guix modules)
+  #:use-module (guix gexp)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (guix packages)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu home services)
+  #:use-module (gnu packages freedesktop)
+  #:use-module (gnu packages xdisorg)
+  #:use-module (gnu packages image)
+  #:use-module (gnu packages gnome)
+  #:use-module (gnu packages wm)
+  #:use-module (gnu packages emacs)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages base)
+  #:use-module (gnu packages suckless)
+  #:use-module (gnu packages glib)
+  #:export (;; Accessors and predicates do not need to be exported.
+            sway-configuration
+            sway-bar
+            sway-output
+            sway-input
+            point
+            sway-color
+            sway-border-color
+            home-sway-service-type
+            sway-configuration->file
+            %sway-default-variables
+            %sway-default-gestures
+            %sway-default-keybindings
+            %sway-default-status-command
+            ))
+
+;; Helper function.
+(define (flatten l)
+  (let loop ((lst l) (acc '()))
+    (match lst
+      (() acc)
+      ((head . tail)
+       (loop tail (append acc head))))))
+
+\f
+;;;
+;;; Default settings.
+;;;
+
+(define %sway-default-variables
+  `((mod   . "Mod4")
+    (left  . "h")
+    (down  . "j")
+    (up    . "k")
+    (right . "l")
+    (term  . ,#~(string-append #$st "/bin/st"))
+    (menu  . ,#~(string-append #$dmenu "/bin/dmenu_run"))))
+
+(define %sway-default-gestures
+  `((swipe:3:right . "workspace next_on_output")
+    (swipe:3:left  . "workspace prev_on_output")
+    (swipe:3:down  . "move to scratchpad")
+    (swipe:3:up    . "scratchpad show")
+    (pinch:2:clockwise
+     . "move container to workspace prev_on_output")
+    (pinch:2:counterclockwise
+     . "move container to workspace next_on_output")
+    (swipe:4:left  . "exec alacritty")
+    (swipe:4:right . "exec qutebrowser")
+    (swipe:4:down . "exec st")
+    (swipe:4:up
+     . ,#~(string-append
+           "exec " #$emacs "/bin/emacsclient -a '"
+           #$libnotify "/bin/notify-send Oups \"emacs not loaded :/\"' -c"))
+    (pinch:inward+right . "resize shrink width")
+    (pinch:inward+left . "resize grow width")
+    (pinch:inward+down . "resize shrink height")
+    (pinch:inward+up . "resize grow height")
+    (pinch:outward+up . "move up")
+    (pinch:outward+down . "move down")
+    (pinch:outward+left . "move left")
+    (pinch:outward+right . "move right")))
+
+(define %sway-default-keybindings
+  `(($mod+Shift+e
+     . ,#~(string-append
+           "exec " #$emacs
+           "/bin/emacsclient -a '"
+           #$libnotify "/bin/notify-send Oups \"emacs not loaded :/\"' -c"))
+    ($mod+Return . "exec $term")
+    ($mod+Shift+c . "kill")
+    ($mod+p . "exec $menu")
+    ($mod+Shift+r . "reload")
+    ($mod+Shift+q
+     . ,#~(string-append
+           "exec " #$sway "/bin/swaynag -t warning "
+           "-m 'You pressed the exit shortcut. Do you really want to exit sway?"
+           " This will end your Wayland session.'"
+           " -B 'Yes, exit sway' 'swaymsg exit'"))
+    ($mod+$left . "focus left")
+    ($mod+$right . "focus right")
+    ($mod+$up . "focus up")
+    ($mod+$down . "focus down")
+    ($mod+Shift+$left . "move left")
+    ($mod+Shift+$right . "move right")
+    ($mod+Shift+$up . "move up")
+    ($mod+Shift+$down . "move down")
+    ($mod+ampersand . "workspace number 1")
+    ($mod+eacute . "workspace number 2")
+    ($mod+quotedbl . "workspace number 3")
+    ($mod+apostrophe . "workspace number 4")
+    ($mod+parenleft . "workspace number 5")
+    ($mod+minus . "workspace number 6")
+    ($mod+egrave . "workspace number 7")
+    ($mod+underscore . "workspace number 8")
+    ($mod+ccedilla . "workspace number 9")
+    ($mod+agrave . "workspace number 10")
+    ($mod+Shift+ampersand . "move container to workspace number 1")
+    ($mod+Shift+eacute . "move container to workspace number 2")
+    ($mod+Shift+quotedbl . "move container to workspace number 3")
+    ($mod+Shift+apostrophe . "move container to workspace number 4")
+    ($mod+Shift+parenleft . "move container to workspace number 5")
+    ($mod+Shift+minus . "move container to workspace number 6")
+    ($mod+Shift+egrave . "move container to workspace number 7")
+    ($mod+Shift+underscore . "move container to workspace number 8")
+    ($mod+Shift+ccedilla . "move container to workspace number 9")
+    ($mod+Shift+agrave . "move container to workspace number 10")
+    ($mod+b . "splith")
+    ($mod+v . "splitv")
+    ($mod+s . "layout stacking")
+    ($mod+w . "layout tabbed")
+    ($mod+e . "layout toggle split")
+    ($mod+f . "fullscreen")
+    ($mod+Shift+space . "floating toggle")
+    ($mod+space . "focus mode_toggle")
+    ($mod+z . "focus parent")
+    ($mod+Shift+o . "move scratchpad")
+    ($mod+o . "scratchpad show")
+    ($mod+r . "mode \"resize\"")
+    ($mod+Shift+n . "bar mode toggle")
+    ($mod+Shift+b . "border toggle")
+    ($mod+tab . "workspace back_and_forth")))
+
+(define %sway-default-status-command
+  (program-file
+   "sway-bar-status"
+   (with-imported-modules
+       (source-module-closure
+        '((ice-9 textual-ports) (ice-9 regex) (ice-9 popen) (ice-9 format)
+          (srfi srfi-19)))
+     #~(begin
+         (use-modules (ice-9 textual-ports)
+                      (ice-9 format)
+                      (ice-9 popen)
+                      (ice-9 regex)
+                      (srfi srfi-19))
+         (let loop ()
+           (let* ((date (date->string (current-date) "~a ~D ~H:~M:~S"))
+                  (batline (let* ((p (open-pipe*
+                                      OPEN_READ
+                                      #$(file-append acpi "/bin/acpi") "-b"))
+                                  (bat (get-line p)))
+                             (close-pipe p)
+                             bat))
+                  (bat (match:substring (string-match "[0-9]+%" batline))))
+             (format #t "~a - ~a~%~!" bat date)
+             (sleep 1)
+             (loop)))))))
+
+\f
+;;;
+;;; Definition of configurations.
+;;;
+
+(define (list-of-string-or-gexp? lst)
+  (every (lambda (elt)
+           (or (string? elt)
+               (gexp? elt)))
+         lst))
+
+(define (list-of-packages? lst)
+  (every package? lst))
+
+(define (bar-position? p)
+  (member p '(top bottom)))
+
+(define (hidden-state? st)
+  (member st '(hide show)))
+
+(define (string-or-symbol? s)
+  (or (string? s)
+      (symbol? s)))
+
+(define (strings? lst)
+  (every string? lst))
+
+(define-maybe string (no-serialization))
+(define-maybe strings (no-serialization))
+
+(define-configuration/no-serialization sway-input
+  (identifier
+   (string-or-symbol '*)
+   "Identifier of the input.")
+  (xkb-layout
+   maybe-string
+   "Keyboard layout.")
+  (xkb-model
+   maybe-string
+   "Keyboard model.")
+  (xkb-options
+   maybe-strings
+   "Keyboard options.")
+  (xkb-variant
+   maybe-string
+   "Keyboard layout variant.")
+  (extra-content
+   (list-of-string-or-gexp '())
+   "Lines to add at the end of the configuration file."))
+
+(define (sway-inputs? lst)
+  (every sway-input? lst))
+
+(define-configuration/no-serialization sway-border-color
+  (border
+   string
+   "Border color.")
+  (background
+   string
+   "Background color.")
+  (text
+   string
+   "Text color."))
+
+(define-maybe sway-border-color (no-serialization))
+
+(define-configuration/no-serialization sway-color
+  (background
+   maybe-string
+   "Background color of the bar.")
+  (statusline
+   maybe-string
+   "Text color of the separator.")
+  (focused-background
+   maybe-string
+   "Background color of the bar on the currently focused monitor.")
+  (focused-statusline
+   maybe-string
+   "Text color of the statusline on the currently focused monitor.")
+  (focused-workspace
+   maybe-sway-border-color
+   "...")
+  (active-workspace
+   maybe-sway-border-color
+   "...")
+  (inactive-workspace
+   maybe-sway-border-color
+   "...")
+  (urgent-workspace
+   maybe-sway-border-color
+   "...")
+  (binding-mode
+   maybe-sway-border-color
+   "..."))
+
+(define-maybe sway-color (no-serialization))
+
+(define-configuration/no-serialization sway-bar
+  (identifier
+   (symbol 'bar0)
+   "Identifier of the bar.")
+  (position
+   (bar-position 'top)
+   "Position of the bar.")
+  (hidden-state
+   (hidden-state 'hide)
+   "Hidden state.")
+  (binding-mode-indicator
+   (boolean #t)
+   "Binding indicator.")
+  (colors
+   maybe-sway-color
+   "Color palette of the bar.")
+  (status-command
+   (file-like %sway-default-status-command)
+    "Status command.  It must be file-like."))
+
+(define-configuration/no-serialization point
+  (x integer "X coordinate.")
+  (y integer "Y coordinate."))
+
+(define-maybe point (no-serialization))
+(define-maybe file-like (no-serialization))
+
+(define-configuration/no-serialization sway-output
+  (identifier
+   (string-or-symbol '*)
+   "Identifier of the output.")
+  (resolution
+   maybe-string
+   "Mode of the monitor.")
+  (position
+   maybe-point
+   "Position of the monitor.")
+  (bg
+   maybe-file-like
+   "Background image.")
+  (extra-content
+   (list-of-string-or-gexp '())
+   "Extra lines."))
+
+(define (sway-outputs? lst)
+  (every sway-output? lst))
+
+(define-configuration/no-serialization sway-configuration
+  (keybindings
+   (alist %sway-default-keybindings)
+   "Keybindings.")
+  (gestures
+   (alist %sway-default-gestures)
+   "Gestures.")
+  (packages
+   (list-of-packages
+    (list sway swaylock waybar swaybg slurp grim dmenu bemenu
+          dbus xdg-desktop-portal-wlr xdg-desktop-portal))
+   "List of packages to add to the profile.")
+  (variables
+   (alist %sway-default-variables)
+   "Variables declared at the beginning of the file.")
+  (inputs
+   (sway-inputs (list (sway-input)))
+   "Inputs.")
+  (outputs
+   (sway-outputs '())
+   "Outputs.")
+  (bar
+   (sway-bar (sway-bar))
+   "Bar configuration.")
+  (always-execs
+   (list-of-string-or-gexp '())
+   "Programs to execute at startup time.")
+  (execs
+   (list-of-string-or-gexp '())
+   "Programs to execute at startup time.")
+  (extra-content
+   (list-of-string-or-gexp '())
+   "Lines to add at the end of the configuration file."))
+
+\f
+;;;
+;;; Serialization functions.
+;;;
+
+(define (serialize-keybinding var)
+  (let ((name (symbol->string (car var)))
+        (value (cdr var)))
+    #~(string-append "bindsym " #$name " " #$value)))
+
+(define (serialize-gesture var)
+  (let ((name (symbol->string (car var)))
+        (value (cdr var)))
+    #~(string-append "bindgesture " #$name " " #$value)))
+
+(define (serialize-variable var)
+  (let ((name (symbol->string (car var)))
+        (value (cdr var)))
+    #~(string-append "set $" #$name " " #$value)))
+
+(define (serialize-exec b)
+  (if b
+      (lambda (exe)
+        #~(string-append "exec_always " #$exe))
+      (lambda (exe)
+        #~(string-append "exec " #$exe))))
+
+(define (serialize-output out)
+  (let* ((pre-ident (sway-output-identifier out))
+         (ident (if (symbol? pre-ident)
+                    (symbol->string pre-ident)
+                    (string-append "\"" pre-ident "\"")))
+         (bg (sway-output-bg out))
+         (resolution (sway-output-resolution out))
+         (position (sway-output-position out))
+         (extra-content (sway-output-extra-content out)))
+    (append
+     (filter
+      (lambda (elt) (not (eq? elt %unset-value)))
+      (list
+       ;; Beginning of the block.
+       #~(string-append "output " #$ident " {")
+       ;; Optional elements.
+       (if (eq? %unset-value bg)
+           %unset-value
+           #~(string-append "    bg " #$bg " fill"))
+       (if (eq? %unset-value resolution)
+           %unset-value
+           (string-append "    resolution " resolution))
+       (if (eq? %unset-value position)
+           %unset-value
+           (string-append "    position " (number->string (point-x position))
+                          " " (number->string (point-y position))))))
+       extra-content
+       ;; End of the block.
+       '("}"))))
+
+(define-inlinable (add-line-if prefix value)
+  (if (eq? %unset-value value)
+      %unset-value
+      (string-append prefix " " value)))
+
+(define (serialize-input input)
+  (let* ((pre-ident (sway-input-identifier input))
+         (ident (if (symbol? pre-ident)
+                    (symbol->string pre-ident)
+                    (string-append "\"" pre-ident "\"")))
+         (xkb-layout (sway-input-xkb-layout input))
+         (xkb-model (sway-input-xkb-model input))
+         (xkb-variant (sway-input-xkb-variant input))
+         (xkb-options (sway-input-xkb-options input)))
+    (append
+     (filter
+      (lambda (elt) (not (eq? elt %unset-value)))
+      (list
+       (string-append "input " ident " {")
+       ;; Optional.
+       (add-line-if "    xkb_layout" xkb-layout)
+       (add-line-if "    xkb_model" xkb-model)
+       (add-line-if "    xkb_variant" xkb-variant)
+       (if (eq? %unset-value xkb-options)
+           %unset-value
+           (string-concatenate (cons "    xkb_options " xkb-options)))))
+     (map (lambda (s)
+            (string-append (string-pad "" 4) s))
+          (sway-input-extra-content input))
+     '("}"))))
+
+(define (serialize-colors colors)
+  (define (add-border-color-if name val)
+    (if (eq? %unset-value val)
+        %unset-value
+        (string-append
+         name
+         " " (sway-border-color-border val)
+         " " (sway-border-color-background val)
+         " " (sway-border-color-text val))))
+  (if (eq? %unset-value colors)
+      '()
+      (let ((background (sway-color-background colors))
+            (statusline (sway-color-statusline colors))
+            (focused-background (sway-color-focused-background colors))
+            (focused-statusline (sway-color-focused-statusline colors))
+            (focused-workspace (sway-color-focused-workspace colors))
+            (active-workspace (sway-color-active-workspace colors))
+            (inactive-workspace (sway-color-inactive-workspace colors))
+            (urgent-workspace (sway-color-urgent-workspace colors))
+            (binding-mode (sway-color-binding-mode colors)))
+        (filter
+         (lambda (elt) (not (eq? elt %unset-value)))
+         (list
+          (add-line-if "background" background)
+          (add-line-if "statusline" statusline)
+          (add-line-if "focused_background" focused-background)
+          (add-line-if "focused_statusline" focused-statusline)
+          (add-border-color-if "focused_workspace" focused-workspace)
+          (add-border-color-if "active_workspace" active-workspace)
+          (add-border-color-if "inactive_workspace" inactive-workspace)
+          (add-border-color-if "urgent_workspace" urgent-workspace)
+          (add-border-color-if "binding_mode" binding-mode))))))
+
+(define (sway-configuration->file conf)
+  (let* ((extra (sway-configuration-extra-content conf))
+         (bar (sway-configuration-bar conf)))
+
+    (with-imported-modules
+        (source-module-closure
+         '((ice-9 popen) (ice-9 match) (ice-9 format) (guix monads)))
+      (computed-file
+       "sway-config"
+       #~(begin
+           (use-modules (ice-9 format) (ice-9 popen) (ice-9 match)
+                        (guix monads))
+
+           (let* ((file #$output)
+                  (port (open-output-file #$output)))
+
+             ;; Helper functions to pretty-print the configuration file.
+             (define (line s)
+               (lambda (i)
+                 (format port "~a~a~%" (string-pad "" i) s)
+                 i))
+             (define (lines lst)
+               (lambda (i)
+                 (let loop ((l lst))
+                   (match l
+                     (() #t)
+                     ((head . tail)
+                      (format port "~a~a~%" (string-pad "" i)
+                              (if (list? head)
+                                  (string-concatenate head)
+                                  head))
+                      (loop tail))))
+                 i))
+             (define-syntax line*
+               (syntax-rules ()
+                 ((line* elt ...)
+                  (lines (list elt ...)))))
+             (define-syntax line2
+               (syntax-rules ()
+                 ((line2 a b)
+                  (line (string-append a b)))))
+             (define (indent k)
+               (lambda (i)
+                 (+ i k)))
+             (define (begin-block name)
+               (lambda (i)
+                 (format port "~a~a {~%" (string-pad "" i) name)
+                 (+ i 4)))
+             (define (end-block)
+               (lambda (i)
+                 (let ((i (- i 4)))
+                   (format port "~a}~%" (string-pad "" i))
+                   i)))
+
+             ;; The value that is threaded in the following block is the
+             ;; indentation level.
+             (with-monad %identity-monad
+               (>>=
+                ;; We start with no indentation at all.
+                (return 0)
+                ;; Header of the configuration file.
+                (line*
+                 "#####################################"
+                 "### Auto-generated configuration. ###"
+                 "#####################################"
+                 "# DO NOT EDIT MANUALLY." "")
+                (line*
+                 "# Variables."
+                 "# =========="
+                 #$@(map serialize-variable
+                         (sway-configuration-variables conf)) "")
+                (line*
+                 "# Outputs."
+                 "# ========"
+                 #$@(flatten
+                     (map serialize-output
+                          (sway-configuration-outputs conf))) "")
+                (line*
+                 "# Inputs."
+                 "# ======="
+                 #$@(flatten
+                     (map serialize-input
+                          (sway-configuration-inputs conf))) "")
+                (line* "# Bar configuration."
+                       "# ==================")
+                (begin-block
+                 (string-append
+                  "bar " #$(symbol->string
+                            (sway-bar-identifier bar))))
+                (line2 "position " #$(symbol->string
+                                      (sway-bar-position bar)))
+                (line2 "hidden_state "
+                       #$(symbol->string
+                          (sway-bar-hidden-state bar)))
+                (line2 "status_command "
+                       #$(sway-bar-status-command bar))
+                (line2 "binding_mode_indicator "
+                       #$(if (sway-bar-binding-mode-indicator bar)
+                             "true" "false"))
+                (begin-block "colors")
+                (line*
+                 #$@(serialize-colors (sway-bar-colors bar)))
+                (end-block) ;; colors
+                (end-block) ;; bar
+                (line*
+                 "" "# Extra configuration content."
+                 "# ============================"
+                 #$@extra "")
+                (line*
+                 "# Keybindings."
+                 "# ============"
+                 #$@(map serialize-keybinding
+                         (sway-configuration-keybindings conf))
+                 "")
+                (line*
+                 "# Gestures."
+                 "# ========="
+                 #$@(map serialize-gesture
+                         (sway-configuration-gestures conf)) "")
+                (line*
+                 "# Programs to execute. (at startup & after reloads)"
+                 "# ===================="
+                 #$@(map (serialize-exec #t)
+                         (sway-configuration-always-execs conf)))
+                (line*
+                 "# Programs to execute. (at startup)"
+                 "# ===================="
+                 #$@(map (serialize-exec #f)
+                         (sway-configuration-execs conf)))))))))))
+
+(define (sway-configuration->files sway-conf)
+  `((".config/sway/config" ,(sway-configuration->file sway-conf))))
+
+(define home-sway-service-type
+  (service-type
+   (name 'home-sway-config)
+   (extensions
+    (list (service-extension home-files-service-type
+                             sway-configuration->files)
+          (service-extension home-profile-service-type
+                             sway-configuration-packages)))
+   (description "Configure Sway by providing a file
+@file{~/.config/sway/config}.")
+   (default-value (sway-configuration))))
diff --git a/gnu/local.mk b/gnu/local.mk
index ad5494fe95..15788b2fb0 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -112,6 +112,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/home/services/shepherd.scm		\
   %D%/home/services/sound.scm			\
   %D%/home/services/ssh.scm			\
+  %D%/home/services/sway.scm			\
   %D%/home/services/syncthing.scm		\
   %D%/home/services/mcron.scm			\
   %D%/home/services/utils.scm			\

base-commit: f10cbebd7b6cfeb66e91851616fdc75f9a0bbe69
-- 
2.45.2