[bug#72714] [PATCH] 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.
  (sway-mode): 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.
---
Hi all,

This version takes into account previous reviews (hoping that I did not
forget/break something).  The modifications are mainly:

• fix a typo in the code: in the v6, execs was serialised in place of
  always-execs,
  
• following your advice, I renamed abbreviations:
  - bg → background
  - execs → startup-programs
  - always-execs → startup+reload-programs

• keyboard layouts are now specified with <keyboard-layout> records in
  sway-input, as suggested.  I have added a cross-reference to the
  relevant section in the manual.
  
  Note: (gnu home services sway) does not re-export keyboard-layout.
  
• the background field of sway-output now accepts pairs too, in order to
  describe how the background should be displayed (fill the screen, at
  the center of the screen, etc.)

• the list of default packages is simply (list sway)

• (flatten (map _ _)) with a homemade flatten is replaced by (flatmap _
  _) with a homemade flatmap.

• the default terminal is now set to foot (as in the default config on
  the sway 1.9)

• extra-content no longer allows file-append objects (which did not make
  sense)

• new fields in sway-input

Best regards,

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

diff --git a/doc/guix.texi b/doc/guix.texi
index 52e36e4354..f5911a19c6 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -130,6 +130,7 @@ Copyright @copyright{} 2024 Richard Sent@*
 Copyright @copyright{} 2024 Dariqq@*
 Copyright @copyright{} 2024 Denis 'GNUtoo' Carikli@*
 Copyright @copyright{} 2024 Fabio Natali@*
+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
@@ -460,6 +461,7 @@ Home Services
 * Mail: Mail Home Services.     Services for managing mail.
 * Messaging: Messaging Home Services.  Services for managing messaging.
 * Media: Media Home Services.   Services for managing media.
+* Sway: Sway window manager.    Setting up the Sway configuration.
 * Networking: Networking Home Services.  Networking services.
 * Miscellaneous: Miscellaneous Home Services.  More services.
 
@@ -45196,6 +45198,7 @@ services)}.
 * Mail: Mail Home Services.     Services for managing mail.
 * Messaging: Messaging Home Services.  Services for managing messaging.
 * Media: Media Home Services.   Services for managing media.
+* Sway: Sway window manager.    Setting up the Sway configuration.
 * Networking: Networking Home Services.  Networking services.
 * Miscellaneous: Miscellaneous Home Services.  More services.
 @end menu
@@ -47110,6 +47113,397 @@ kodi} for more information.
 @end table
 @end deftp
 
+@node Sway window manager
+@subsection Sway window manager
+
+@cindex sway, Home Service
+@cindex sway, configuration
+The @code{(gnu home services sway)} module provides
+@code{home-sway-service-type}, a home service to configure the
+@uref{https://github.com/swaywm/sway,Sway window manager for Wayland} in
+a declarative way.
+
+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
+(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 (file-append sway
+                     "\
+/share/backgrounds/sway/Sway_Wallpaper_Blue_1920x1080.png")))))))
+@end lisp
+
+The above example describes a Sway configuration in which
+@itemize
+@item
+all monitors use a particular wallpaper whose @file{.png} is provided by
+the @code{sway} package;
+@item
+swiping down (resp.@: up) with three fingers moves the active window to
+the scratchpad (resp.@: shows/hides the scratchpad).
+@end itemize
+
+@quotation Note
+This home service only sets up the configuration file and profile
+packages for Sway.  It does @emph{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 @emph{optional} @code{sway-configuration}
+field of @code{greetd-wlgreet-sway-session}.
+@end quotation
+
+@deffn {Procedure} sway-configuration->file config
+This function takes a @code{sway-configuration} record (defined below),
+and returns a file-like object representing the serialized
+configuration.
+@end deffn
+
+@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
+@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 either strings, G-expressions or file-append objects
+(@pxref{G-Expressions}).
+
+Example:
+@lisp
+(variables `((mod . "Mod4") ; string
+             (term ; file-append
+              . ,(file-append foot "/bin/foot"))
+             (term ; G-expression
+              . ,#~(string-append #$foot "/bin/foot"))))
+@end lisp
+
+@item @code{keybindings} (default: @code{%sway-default-keybindings})
+This field describes keybindings for the @emph{default} mode.  The value
+is an association list: keys are symbols and values are either strings
+or G-expressions.
+
+The following snippet launches the terminal when pressing @kbd{$mod+t}
+and @kbd{$mod+Shift+t} (assuming that a variable @code{$term} is
+defined):
+@lisp
+`(($mod+t . ,#~(string-append "exec " #$foot "/bin/foot"))
+  ($mod+Shift+t . "exec $term"))
+@end lisp
+
+@item @code{gestures} (default: @code{%sway-default-gestures})
+Similar to the previous field, but for finger-gestures.
+
+The following snippet allows to navigate through workspaces by swiping
+right and left with three fingers:
+@lisp
+'((swipe:3:right . "workspace next_on_output")
+  (swipe:3:left  . "workspace prev_on_output"))
+@end lisp
+
+@item @code{packages} (default: @code{%sway-default-packages})
+This field describes a list of packages to add to the user profile.  At
+the moment, the default value only adds @code{sway} to the profile.
+
+@item @code{inputs} (default: @code{'()})
+List of @code{sway-input} configuration records (described below).
+
+@item @code{outputs} (default: @code{'()})
+List of @code{sway-output} configuration records (described below).
+
+@item @code{bar} (optional @code{sway-bar} record)
+Optional @code{sway-bar} record (described below) to configure a Sway
+bar.
+
+@item @code{modes} (default: @code{'()})
+Optional list of @code{sway-mode} records (described below) to add modes
+to the Sway configuration (@i{e.g.}@: the ``resize'' mode of the default
+Sway configuration).
+
+@item @code{startup+reload-programs} (default: @code{'()})
+Programs to execute at startup time @emph{and} after every configuration
+reload.  The value of this field is a list of strings, G-expressions or
+file-append objects (@pxref{G-Expressions}).
+
+@item @code{startup-programs} (default: @code{%sway-default-execs})
+Programs to execute at startup time.  As above, values of this field are
+a list of strings, G-expressions or file-append objects.
+
+The default value, @code{%sway-default-execs}, executes @code{swayidle}
+in order to lock the screen after 5@ minutes of inactivity (displaying a
+background distributed with Sway) and turn the screen off after 10@
+minutes of inactivity.
+
+@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)}).  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")
+            (layout
+              (keyboard-layout "fr" #:options '("ctrl:nocaps"))))
+@end lisp
+
+Available fields for @code{sway-input} configuration records are:
+
+@table @asis
+@item @code{identifier} (default: @code{'*})
+Identifier of the input.  The field accepts symbols and strings.  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{layout} (optional @code{<keyboard-layout>} record)
+Keyboard specific option.  Field specifying the layout (possibly with
+options) to use for the input.  The value must be a
+@code{<keyboard-layout>} record (@pxref{Keyboard Layout}).
+
+@quotation Note
+@code{(gnu home services sway)} does not re-export the
+@code{keyboard-layout} procedure.
+@end quotation
+
+
+@item @code{disable-while-typing} (optional boolean)
+If @code{#t} (resp.@: @code{#f}) enables (resp.@: disables) the
+``disable while typing'' option for this input.
+
+@item @code{disable-while-trackpointing} (optional boolean)
+If @code{#t} (resp.@: @code{#f}), enables (resp.@: disables) the
+``disable while track-pointing'' option for this input.
+
+@item @code{tap} (optional boolean)
+Enables or disables the ``tap'' option, which allows clicking by tapping
+on a touchpad.
+
+@item @code{extra-content} (default: @code{'()})
+Lines to add to the input block.  The value of this field is a list
+whose elements can be either strings or G-expressions.
+@end table
+@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.  The field accepts symbols and strings.  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 string)
+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{background} (optional)
+The value of this field describes what wallpaper to use on this output.
+The field accepts the following types of values:
+@itemize
+@item
+a string,
+@item
+a G-expression,
+@item
+a file-append object,
+@item
+a pair.  The first argument of this pair must be a string, a
+G-expression or a file-append object.  The second element of the pair
+must be a symbol among @code{stretch}, @code{fill}, @code{fit},
+@code{center} and @code{tile}.
+@end itemize
+
+@quotation Note
+In order to use an SVG file, you must have @code{librsvg} in your
+profile (@i{e.g.}@: by adding it in the @code{packages} field of @code{sway-configuration}).
+@end quotation
+
+@item @code{extra-content} (default: @code{'()})
+List defining additional lines to add 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 @code
+@item border
+Color of the border.
+@item background
+Color of the background.
+@item text
+Color of the text.
+@end table
+@end deftp
+
+@deftp {Data Type} sway-color
+@table @asis
+@item @code{background} (optional string)
+Background color of the bar.
+
+@item @code{statusline} (optional string)
+Text color of the status line.
+
+@item @code{focused-background} (optional string)
+Background color of the bar on the currently focused monitor.
+
+@item @code{focused-statusline} (optional string)
+Text color of the statusline on the currently focused monitor.
+
+@item @code{focused-workspace} (optional @code{sway-border-color})
+Color scheme for focused workspaces.
+
+@item @code{active-workspace} (optional @code{sway-border-color})
+Color scheme for active workspaces.
+
+@item @code{inactive-workspace} (optional @code{sway-border-color})
+Color scheme for inactive workspaces.
+
+@item @code{urgent-workspace} (optional @code{sway-border-color})
+Color scheme for workspaces containing ``urgent'' windows.
+
+@item @code{binding-mode} (optional @code{sway-border-color})
+Color scheme for the binding mode indicator.
+@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 symbol.
+
+@item @code{position} (optional)
+Specify the position of the bar.  Accepted values are @code{'top} or
+@code{'bottom}.
+
+@item @code{hidden-state} (optional)
+Specify the apparence of the bar when it is hidden.  Accepted values are
+@code{'hide} or @code{'show}.
+
+@item @code{binding-mode-indicator} (optional)
+Boolean enabling or disabling 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 strings, G-expressions and executable file-like
+values.  The default value is a command (string) that prints the date
+and time every second.
+
+Each line printed on @code{stdout} by this command (or script) will be
+displayed on the status area of the bar.
+
+Below are a few examples using:
+@itemize
+@item
+a string: @code{"while date +'%Y-%m-%d %X'; do sleep 1; done"},
+@item
+a G-exp:
+@lisp
+#~(string-append "while "
+                 #$coreutils "/bin/date"
+                 " +'%Y-%m-%d %X'; do sleep 1; done")
+@end lisp
+@item
+an executable file:
+@lisp
+(program-file
+ "sway-bar-status"
+ #~(begin
+     (use-modules (ice-9 format)
+                  (srfi srfi-19))
+     (let loop ()
+       (let* ((date (date->string
+                     (current-date)
+                     "~d/~m/~Y (~a)  ~H:~M:~S")))
+         (format #t "~a~%~!" date)
+         (sleep 1)
+         (loop)))))
+@end lisp
+@end itemize
+
+@item @code{mouse-bindings} (default: @code{'()})
+This field accepts an associative list.  Keys are integers describing
+mouse events.  Values can either be strings or G-expressions.
+
+The module @code{(gnu home services sway)} exports constants
+@code{%ev-code-mouse-left}, @code{%ev-code-mouse-right} and
+@code{%ev-code-mouse-scroll-click} whose values are integers
+corresponding to left, right and scroll click respectively.  For
+example, with @code{(mouse-bindings `((,%ev-code-mouse-left
+. ,#~(string-append "exec " #$st "/bin/st"))))}, left clicks in the
+status bar open the @code{st} terminal.
+@end table
+@end deftp
+
+@deftp {Data Type} sway-mode
+Describes a Sway mode (see@ @cite{sway(5)}).  For example, the following
+snippet defines a mockup of the resize mode of the default Sway
+configuration:
+@example
+(sway-mode
+ (mode-name "resize")
+ (keybindings
+  '(($left  . "resize shrink width 10px")
+    ($right . "resize grow   width 10px")
+    ($down  . "resize grow   height 10px")
+    ($up    . "resize shrink height 10px")
+    (Return . "mode \"default\"")
+    (Escape . "mode \"default\""))))
+@end example
+
+@table @asis
+@item @code{mode-name} (default: @code{"default"})
+Name of the mode.  This field accepts strings.
+
+@item  @code{keybindings} (default: @code{'()})
+This field describes keybindings.  The value is an association list:
+keys are symbols and values are either strings or G-expressions, as
+above.
+
+@item @code{mouse-bindings} (default: @code{'()})
+Ditto, but keys are mouse events (integers).  Constants
+@code{%ev-code-mouse-*} described above can be used as helpers to define
+mouse bindings.
+@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..25cae56dae
--- /dev/null
+++ b/gnu/home/services/sway.scm
@@ -0,0 +1,794 @@
+;;; 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 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 system keyboard)
+  #: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 terminals)
+  #:use-module (gnu packages suckless)
+  #:use-module (gnu packages glib)
+  #:export (;; Event codes
+            %ev-code-mouse-left
+            %ev-code-mouse-right
+            %ev-code-mouse-scroll-click
+
+            ;; Configuration records.
+            sway-configuration
+            sway-bar
+            sway-output
+            sway-input
+            point
+            sway-color
+            sway-border-color
+            home-sway-service-type
+            sway-configuration->file
+            sway-mode
+
+            ;; Default values.
+            %sway-default-variables
+            %sway-default-gestures
+            %sway-default-keybindings
+            %sway-default-status-command
+            %sway-default-startup-programs
+            %sway-default-packages))
+
+;; Helper function.
+(define (flatmap f l)
+  (let loop ((lst (reverse l)) (acc '()))
+    (match lst
+      (() acc)
+      ((head . tail)
+       (let* ((h (f head))
+              (acc (append h acc)))
+         (loop tail acc))))))
+
+\f
+;;;
+;;; Default settings and useful constants.
+;;;
+
+(define %ev-code-mouse-left 272)
+(define %ev-code-mouse-right 273)
+(define %ev-code-mouse-scroll-click 274)
+
+(define %sway-default-packages
+  (list sway))
+
+(define %sway-default-variables
+  `((mod   . "Mod4")
+    (left  . "h")
+    (down  . "j")
+    (up    . "k")
+    (right . "l")
+    (term  . ,(file-append foot "/bin/foot"))
+    (menu  . ,#~(string-append
+                 #$dmenu "/bin/dmenu_path | \\\n    "
+                 #$wmenu "/bin/wmenu | \\\n    "
+                 #$findutils "/bin/xargs \\\n    "
+                 #$sway "/bin/swaymsg exec --"))))
+
+(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")))
+
+(define %sway-default-keybindings
+  `(($mod+Return . "exec $term")
+    ($mod+Shift+q . "kill")
+    ($mod+d . "exec $menu")
+    ($mod+Shift+c . "reload")
+    ($mod+Shift+e
+     . ,#~(string-append
+           "exec " #$sway "/bin/swaynag -t warning -m \\\n    "
+           "'You pressed the exit shortcut.  Do you really want to exit sway?"
+           " This will end your Wayland session.' \\\n    "
+           "-B 'Yes, exit sway' \\\n    '"
+           #$sway "/bin/swaymsg exit'"))
+    ($mod+$left . "focus left")
+    ($mod+$down . "focus down")
+    ($mod+$up . "focus up")
+    ($mod+$right . "focus right")
+    ($mod+Left . "focus left")
+    ($mod+Down . "focus down")
+    ($mod+Up . "focus up")
+    ($mod+Right . "focus right")
+    ($mod+Shift+$left . "move left")
+    ($mod+Shift+$down . "move down")
+    ($mod+Shift+$up . "move up")
+    ($mod+Shift+$right . "move right")
+    ($mod+Shift+Left . "move left")
+    ($mod+Shift+Down . "move down")
+    ($mod+Shift+Up . "move up")
+    ($mod+Shift+Right . "move right")
+    ($mod+1 . "workspace number 1")
+    ($mod+2 . "workspace number 2")
+    ($mod+3 . "workspace number 3")
+    ($mod+4 . "workspace number 4")
+    ($mod+5 . "workspace number 5")
+    ($mod+6 . "workspace number 6")
+    ($mod+7 . "workspace number 7")
+    ($mod+8 . "workspace number 8")
+    ($mod+9 . "workspace number 9")
+    ($mod+0 . "workspace number 10")
+    ($mod+Shift+1 . "move container to workspace number 1")
+    ($mod+Shift+2 . "move container to workspace number 2")
+    ($mod+Shift+3 . "move container to workspace number 3")
+    ($mod+Shift+4 . "move container to workspace number 4")
+    ($mod+Shift+5 . "move container to workspace number 5")
+    ($mod+Shift+6 . "move container to workspace number 6")
+    ($mod+Shift+7 . "move container to workspace number 7")
+    ($mod+Shift+8 . "move container to workspace number 8")
+    ($mod+Shift+9 . "move container to workspace number 9")
+    ($mod+Shift+0 . "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+a . "focus parent")
+    ($mod+Shift+minus . "move scratchpad")
+    ($mod+minus . "scratchpad show")
+    ($mod+r . "mode \"resize\"")))
+
+(define %sway-default-status-command
+  "while date +'%Y-%m-%d %X'; do sleep 1; done")
+
+(define %sway-default-startup-programs
+  (list
+   #~(string-append
+      #$swayidle "/bin/swayidle -w \\\n    "
+      ;; 300: lock screen.
+      "timeout 300 '" #$swaylock "/bin/swaylock "
+      "--indicator-radius 75 \\\n    "
+      "-i " #$sway
+      "/share/backgrounds/sway/Sway_Wallpaper_Blue_1920x1080.png \\\n    "
+      "-f -c 000000' \\\n    "
+      ;; 600: lock + screen off.
+      "timeout 600 '" #$sway "/bin/swaymsg \"output * power off\"' \\\n    "
+      ;; Resume + sleep.
+      "resume '" #$sway "/bin/swaymsg \"output * power on\"' \\\n    "
+      "before-sleep '" #$swaylock "/bin/swaylock -f -c 000000'")))
+
+\f
+;;;
+;;; Definition of configurations.
+;;;
+
+(define (string-ish? s)
+  (or (gexp? s)
+      (file-append? s)
+      (string? s)))
+
+(define (string-or-gexp? s)
+  (or (gexp? s)
+      (string? s)))
+
+(define (list-of-string-ish? lst)
+  (every string-ish? 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 (extra-content? extra)
+  (every string-or-gexp? extra))
+
+(define (make-alist-predicate key? val?)
+  (lambda (lst)
+    (every
+     (lambda (item)
+       (match item
+         ((k . v)
+          (and (key? k)
+               (val? v)))
+         (_ #f)))
+     lst)))
+
+(define bindings?
+  (make-alist-predicate symbol? string-or-gexp?))
+
+(define mouse-bindings?
+  (make-alist-predicate integer? string-or-gexp?))
+
+(define (variables? lst)
+  (make-alist-predicate symbol? string-ish?))
+
+(define-maybe string (no-serialization))
+(define-maybe strings (no-serialization))
+(define-maybe boolean (no-serialization))
+(define-maybe keyboard-layout (no-serialization))
+
+(define-configuration/no-serialization sway-input
+  (identifier
+   (string-or-symbol '*)
+   "Identifier of the input.")
+  (layout
+   maybe-keyboard-layout
+   "Keyboard layout of the input.")
+  (disable-while-typing
+   maybe-boolean
+   "If `#t', disable the input while typing; if `#f' do not.")
+  (disable-while-trackpointing
+   maybe-boolean
+   "If `#t', disable the input while using a trackpoint; if `#f' do not.")
+  (tap
+   maybe-boolean
+   "Enable or disable tap.")
+  (extra-content
+   (extra-content '())
+   "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 status line.")
+  (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
+   "Color scheme for focused workspaces.")
+  (active-workspace
+   maybe-sway-border-color
+   "Color scheme for active workspaces.")
+  (inactive-workspace
+   maybe-sway-border-color
+   "Color scheme for inactive workspaces.")
+  (urgent-workspace
+   maybe-sway-border-color
+   "Color scheme for workspaces containing `urgent' windows.")
+  (binding-mode
+   maybe-sway-border-color
+   "Color scheme for the binding mode indicator."))
+
+(define-maybe sway-color (no-serialization))
+
+(define (status-command? c)
+  (or (string? c)
+      (file-like? c)
+      (gexp? c)))
+
+(define-maybe bar-position (no-serialization))
+(define-maybe hidden-state (no-serialization))
+(define-maybe status-command (no-serialization))
+
+(define-configuration/no-serialization sway-bar
+  (identifier
+   (symbol 'bar0)
+   "Identifier of the bar.")
+  (position
+   maybe-bar-position
+   "Position of the bar.")
+  (hidden-state
+   maybe-hidden-state
+   "Hidden state.")
+  (binding-mode-indicator
+   maybe-boolean
+   "Binding indicator.")
+  (colors
+   maybe-sway-color
+   "Color palette of the bar.")
+  (status-command
+   maybe-status-command
+   "Status command.  It must be file-like.")
+  (mouse-bindings
+   (mouse-bindings '())
+   "Actions triggered by mouse events.")
+  (extra-content
+   (extra-content '())
+   "Extra configuration lines."))
+
+(define-maybe sway-bar (no-serialization))
+
+(define-configuration/no-serialization point
+  (x integer "X coordinate.")
+  (y integer "Y coordinate."))
+
+(define (file-like-or-gexp? f)
+  (or (file-like? f)
+      (gexp? f)))
+
+(define-maybe point (no-serialization))
+(define-maybe file-like-or-gexp (no-serialization))
+
+(define (background? bg)
+  (or (string-ish? bg)
+      (and (pair? bg)
+           (string-ish? (car bg))
+           (member (cdr bg) '(stretch fill fit center tile)))))
+
+(define-maybe background (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.")
+  (background
+   maybe-background
+   "Background image.")
+  (extra-content
+   (extra-content '())
+   "Extra lines."))
+
+(define (sway-outputs? lst)
+  (every sway-output? lst))
+
+(define-configuration/no-serialization sway-mode
+  (mode-name
+   (string "default")
+   "Name of the mode.")
+  (keybindings
+   (bindings '())
+   "Keybindings.")
+  (mouse-bindings
+   (mouse-bindings '())
+   "Mouse bindings."))
+;; TODO (not necessary for 72714): switch bindings.
+
+(define (sway-modes? lst)
+  (every sway-mode? lst))
+
+(define-configuration/no-serialization sway-configuration
+  (keybindings
+   (bindings %sway-default-keybindings)
+   "Keybindings.")
+  (gestures
+   (bindings %sway-default-gestures)
+   "Gestures.")
+  (packages
+   (list-of-packages
+    %sway-default-packages)
+   "List of packages to add to the profile.")
+  (variables
+   (variables %sway-default-variables)
+   "Variables declared at the beginning of the file.")
+  (inputs
+   (sway-inputs '())
+   "Inputs.")
+  (outputs
+   (sway-outputs '())
+   "Outputs.")
+  (bar
+   maybe-sway-bar
+   "Bar configuration.")
+  (modes
+   (sway-modes '())
+   "Additional modes.")
+  (startup+reload-programs
+   (list-of-string-ish '())
+   "Programs to execute at startup time.")
+  (startup-programs
+   (list-of-string-ish %sway-default-startup-programs)
+   "Programs to execute at startup time.")
+  (extra-content
+   (extra-content '())
+   "Lines to add at the end of the configuration file."))
+
+\f
+;;;
+;;; Serialization functions.
+;;;
+
+;; Helper functions.
+(define* (add-line-if field value
+                      #:key (serializer %unset-value)
+                      (suffix %unset-value))
+  (if (eq? %unset-value value)
+      %unset-value
+      #~(string-append #$field " "
+                       #$(if (eq? serializer %unset-value)
+                             value
+                             (serializer value))
+                       #$(if (eq? suffix %unset-value)
+                             ""
+                             suffix))))
+
+(define (add-block name content)
+  (let ((content (filter
+                  (lambda (elt) (not (eq? elt %unset-value)))
+                  content)))
+    (if (equal? content '())
+        '()
+        (append
+         (list #~(cons 'begin-block #$name))
+         content
+         (list #~'end-block)))))
+
+(define-syntax add-block*
+  (syntax-rules ()
+    ((add-block* name elt ...)
+     (add-block name (append elt ...)))))
+
+(define (box str)
+  (let* ((len (string-length str))
+         (line (make-string (+ 8 len) #\#)))
+    (list
+     line
+     (string-append "### " str " ###")
+     line)))
+
+(define (heading str)
+  (let* ((len (string-length str))
+         (line (make-string (+ 2 len) #\#)))
+    (list
+     ""
+     (string-append "# " str)
+     line)))
+
+(define-inlinable (serialize-boolean-yn b)
+  (if b "yes" "no"))
+
+(define-inlinable (serialize-binding binder key value)
+  #~(string-append #$binder #$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)))
+
+(define (serialize-keybinding var)
+  (let ((name (symbol->string (car var)))
+        (value (cdr var)))
+    (serialize-binding "bindsym " name value)))
+
+(define (serialize-gesture var)
+  (let ((name (symbol->string (car var)))
+        (value (cdr var)))
+    (serialize-binding "bindgesture " name value)))
+
+(define (serialize-variable var)
+  (let ((name (symbol->string (car var)))
+        (value (cdr var)))
+    (serialize-binding "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 "\"")))
+         (background (let ((bg (sway-output-background out)))
+                       (if (pair? bg)
+                           bg
+                           (cons bg 'fill))))
+         (resolution (sway-output-resolution out))
+         (position (sway-output-position out))
+         (extra-content (sway-output-extra-content out)))
+    (add-block
+     (string-append "output " ident)
+     (cons*
+      ;; Optional elements.
+      (add-line-if "bg" (car background)
+                   #:suffix
+                   (string-append " " (symbol->string (cdr background))))
+      (add-line-if "resolution" resolution)
+      (add-line-if "position" position
+                   #:serializer
+                   (lambda (p)
+                     (string-append (number->string (point-x p))
+                                    " "
+                                    (number->string (point-x p)))))
+      ;; Extra-content: inlined as-is.
+      extra-content))))
+
+(define (serialize-input input)
+  (define-inlinable (fetch-arg layout acc)
+    (if (eq? layout %unset-value)
+        %unset-value
+        (acc layout)))
+
+  (define-inlinable (unfalse f)
+    (lambda (arg)
+      (let ((res (f arg)))
+        (if res res %unset-value))))
+
+  (define-inlinable (unnil f)
+    (lambda (arg)
+      (let ((res (f arg)))
+        (if (nil? res) %unset-value res))))
+
+  (let* ((pre-ident (sway-input-identifier input))
+         (ident (if (symbol? pre-ident)
+                    (symbol->string pre-ident)
+                    (string-append "\"" pre-ident "\"")))
+
+         ;; unpack the `layout' field.
+         (layout (sway-input-layout input))
+         (xkb-layout (fetch-arg layout keyboard-layout-name))
+         (xkb-variant (fetch-arg layout (unfalse keyboard-layout-variant)))
+         (xkb-model (fetch-arg layout (unfalse keyboard-layout-model)))
+         (xkb-options (fetch-arg layout (unnil keyboard-layout-options)))
+
+         (dwt (sway-input-disable-while-typing input))
+         (dwtp (sway-input-disable-while-trackpointing input))
+         (extra-content (sway-input-extra-content input)))
+    (add-block
+     (string-append "input " ident)
+     (cons*
+      ;; Optional.
+      (add-line-if "xkb_layout" xkb-layout)
+      (add-line-if "xkb_model" xkb-model)
+      (add-line-if "xkb_variant" xkb-variant)
+      (add-line-if "xkb_options" xkb-options
+                   #:serializer (lambda (l) (string-join l ",")))
+      (add-line-if "dwt" dwt
+                   #:serializer serialize-boolean-yn)
+      (add-line-if "dwtp" dwtp
+                   #:serializer serialize-boolean-yn)
+      ;; extra-content inlined as-is.
+      extra-content))))
+
+(define (serialize-colors colors)
+  (define (border-serializer val)
+    (string-append (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)))
+        (add-block
+         "colors"
+         (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-line-if "focused_workspace" focused-workspace
+                       #:serializer border-serializer)
+          (add-line-if "active_workspace" active-workspace
+                       #:serializer border-serializer)
+          (add-line-if "inactive_workspace" inactive-workspace
+                       #:serializer border-serializer)
+          (add-line-if "urgent_workspace" urgent-workspace
+                       #:serializer border-serializer)
+          (add-line-if "binding_mode" binding-mode
+                       #:serializer border-serializer))))))
+
+(define (serialize-mode mode)
+  (let ((name (sway-mode-mode-name mode))
+        (keys (sway-mode-keybindings mode))
+        (clicks (sway-mode-mouse-bindings mode)))
+    (add-block*
+     (string-append "mode \"" name "\"")
+     (map serialize-keybinding keys)
+     (map serialize-mouse-binding clicks))))
+
+(define (serialize-bar bar)
+  (define serialize-symbol
+    symbol->string)
+
+  (let ((identifier (symbol->string (sway-bar-identifier bar)))
+        (position (sway-bar-position bar))
+        (hidden-state (sway-bar-hidden-state bar))
+        (status-command (sway-bar-status-command bar))
+        (binding-mode-indicator (sway-bar-binding-mode-indicator bar))
+        (mouse-bindings (sway-bar-mouse-bindings bar))
+        (extra-content (sway-bar-extra-content bar))
+        (colors (sway-bar-colors bar)))
+    (add-block*
+     (string-append "bar " identifier)
+
+     (if (eq? colors %unset-value)
+         '()
+         (serialize-colors colors))
+     (list
+      (add-line-if "position" position
+                   #:serializer serialize-symbol)
+      (add-line-if "hidden_state" hidden-state
+                   #:serializer serialize-symbol)
+      (add-line-if "status_command" status-command)
+      (add-line-if "binding_mode_indicator" binding-mode-indicator
+                   #:serializer serialize-boolean-yn))
+     ;; Key- and mouse-bindings and extra-content
+     (map serialize-mouse-binding mouse-bindings)
+     extra-content)))
+
+(define (sway-configuration->file conf)
+  (let* ((extra (sway-configuration-extra-content conf))
+         (bar (sway-configuration-bar conf)))
+    (computed-file
+     "sway-config"
+     #~(begin
+         (use-modules (ice-9 format) (ice-9 popen) (ice-9 match)
+                      (srfi srfi-1))
+
+         (let* ((file #$output)
+                (port (open-output-file #$output)))
+
+           ;; Add the (indented) line "s" to the output file.
+           (define (line s)
+             (lambda (i)
+               (format port "~a~a~%" (make-string i #\ ) s)
+               i))
+
+           ;; Begin a block "name" and adjust the indentation.
+           (define (begin-block name)
+             (lambda (i)
+               (format port "~a~a {~%" (make-string i #\ ) name)
+               (+ i 4)))
+
+           ;; Ends an open block and adjust the indentation.
+           (define (end-block)
+             (lambda (i)
+               (let ((i (- i 4)))
+                 (format port "~a}~%" (make-string i #\ ))
+                 i)))
+
+           ;; Helper function.  The configuration is represented as a list
+           ;; of actions (alter the indentation level, add a line, ...).
+           ;; This function recognises the action and calls the right
+           ;; function among those defined above.
+           (define (serializer-dispatch-m arg)
+             (match arg
+               ;; Special cases:
+               (('begin-block . str) (begin-block str))
+               ('end-block (end-block))
+               ;; Default case: `arg' is assumed to be a string.
+               (_ (line arg))))
+
+           (define (serializer-dispatch elt i)
+             ((serializer-dispatch-m elt) i))
+
+           (fold
+            ;; Dispatch function: depending on its argument, it will change
+            ;; the indentation level or add a line to the output file.
+            serializer-dispatch
+
+            ;; Initial indentation level
+            0
+
+            ;; List of lines or indentation modifiers.
+            (list
+             ;; Header.
+             #$@(box "Auto-generated configuration")
+             "# DO NOT EDIT MANUALLY."
+
+             ;; Variables.
+             #$@(heading "Variables.")
+             #$@(map serialize-variable (sway-configuration-variables conf))
+
+             ;; Outputs.
+             #$@(heading "Outputs.")
+             #$@(flatmap serialize-output (sway-configuration-outputs conf))
+
+             ;; Inputs.
+             #$@(heading "Inputs.")
+             #$@(flatmap serialize-input (sway-configuration-inputs conf))
+
+             ;; Bar configuration:
+             ;; If the bar is unset, do not include anything.
+             #$@(if (eq? bar %unset-value)
+                    '()
+                    (append
+                     (heading "Bar configuration.")
+                     (serialize-bar bar)))
+
+             ;; Keybindings.
+             #$@(heading "Keybindings.")
+             #$@(map serialize-keybinding
+                     (sway-configuration-keybindings conf))
+             ;; Gestures.
+             #$@(heading "Gestures.")
+             #$@(map serialize-gesture (sway-configuration-gestures conf))
+
+             ;; Modes.
+             #$@(heading "Modes.")
+             #$@(flatmap serialize-mode (sway-configuration-modes conf))
+
+             ;; Startup-Programs.
+             #$@(heading "Programs to execute (at startup).")
+             #$@(map (serialize-exec #f)
+                     (sway-configuration-startup-programs conf))
+             ;; startup+reload-programs.
+             #$@(heading "Programs to execute (at startup & after reload).")
+             #$@(map (serialize-exec #t)
+                     (sway-configuration-startup+reload-programs conf))
+
+             ;; Extra-content.
+             #$@extra)))))))
+
+(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 a8dc6bc746..a4a2b73a36 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -114,6 +114,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			\
-- 
2.46.0