Subject: bug#72714: closed (Re: [PATCH v8] home: services: Add 'home-sway-service-type'.)

From: [email-masked] (GNU bug Tracking System)
Date: Sat, 12 Oct 2024 13:13:02 +0000

Your bug report

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

which was filed against the guix-patches package, has been closed.

The explanation is attached below, along with your original report.
If you require more details, please reply to [email-masked].

-- 
72714: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=72714
GNU Bug Tracking System
Contact [email-masked] with problems

Subject: Re: [PATCH v8] home: services: Add 'home-sway-service-type'.
From: "pelzflorian (Florian Pelz)" <[email-masked]>
To: Arnaud Daby-Seesaram <[email-masked]>
Cc: Hilton Chain <[email-masked]>, Ludovic Courtès <[email-masked]>, [email-masked]
Date: Sat, 12 Oct 2024 15:11:56 +0200
List-Id: <debbugs-submit.debbugs.gnu.org>

Pushed as b64f7984a5e2aba04df72a92f0044e423efe77c6,
Change-Id: I880261570c5afdb795f2ce18bac2b9a5c898677f
with tiny changes.

---
 doc/guix.texi              | 16 ++++++++--------
 gnu/home/services/sway.scm | 24 ++++++++----------------
 2 files changed, 16 insertions(+), 24 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 0f45ef3b15..ddbff8bc23 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -47170,13 +47170,13 @@ Sway window manager
 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
+The proceedure @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 one argument @code{config}, which must be a
+This procedure takes one argument @code{config}, which must be a
 @code{sway-configuration} record (defined below), and returns a
 file-like object representing the serialized configuration.
 @end deffn
@@ -47263,11 +47263,11 @@ Sway window manager
 @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}).
+file-like 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.
+a list of strings, G-expressions or file-like objects.
 
 The default value, @code{%sway-default-execs}, executes @code{swayidle}
 in order to lock the screen after 5@ minutes of inactivity (displaying a
@@ -47283,7 +47283,7 @@ Sway window manager
 @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
+keyboards use a French layout, in which @kbd{capslock} has been remapped
 to @kbd{ctrl}:
 @lisp
 (sway-input (identifier "type:keyboard")
@@ -47365,8 +47365,8 @@ Sway window manager
 the wallpaper will be displayed.  It must be a symbol among
 @code{stretch}, @code{fill}, @code{fit}, @code{center} and @code{tile}.
 
-If the second element is not specified (@i{i.e.}@: when the value not a
-pair), the @code{fill} mode will be used.
+If the second element is not specified (@i{i.e.}@: when the value is not
+a pair), the @code{fill} mode will be used.
 @end itemize
 
 @quotation Note
@@ -47444,7 +47444,7 @@ Sway window manager
 @item @code{colors} (optional)
 An optional @code{sway-color} configuration record.
 
-@item @code{status-command} (default: @code{%sway-status-command})
+@item @code{status-command} (optional)
 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.
diff --git a/gnu/home/services/sway.scm b/gnu/home/services/sway.scm
index 9401c80400..0e1a2d57b2 100644
--- a/gnu/home/services/sway.scm
+++ b/gnu/home/services/sway.scm
@@ -20,9 +20,6 @@ (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)
@@ -52,7 +49,6 @@ (define-module (gnu home services sway)
             %sway-default-gestures
             %sway-default-modes
             %sway-default-keybindings
-            %sway-default-status-command
             %sway-default-startup-programs
             %sway-default-packages))
 
@@ -221,7 +217,7 @@ (define-configuration/no-serialization sway-bar
    "Color palette of the bar.")
   (status-command
    maybe-status-command
-   "Status command.  It must be file-like.")
+   "Status command.")
   (mouse-bindings
    (mouse-bindings '())
    "Actions triggered by mouse events.")
@@ -275,7 +271,6 @@ (define-configuration/no-serialization sway-mode
   (mouse-bindings
    (mouse-bindings '())
    "Mouse bindings."))
-;; TODO (not necessary for 72714): switch bindings.
 
 (define (sway-modes? lst)
   (every sway-mode? lst))
@@ -327,10 +322,10 @@ (define sway-menu
    (with-imported-modules
        (source-module-closure '((guix build utils)))
      #~(begin
-         (use-modules (ice-9 popen)
+         (use-modules (ice-9 ftw)
+                      (ice-9 popen)
                       (ice-9 receive)
                       (ice-9 rdelim)
-                      (ice-9 ftw)
                       (guix build utils)
                       (srfi srfi-1))
 
@@ -351,7 +346,7 @@ (define sway-menu
                                     "/.guix-home/profile/bin"))
                (wmenu #$(file-append wmenu "/bin/wmenu"))
                (swaymsg #$(file-append sway "/bin/swaymsg")))
-           (receive (from to pid)
+           (receive (from to pids)
                (pipeline `((,wmenu)))
              (for-each
               (lambda (c) (format to "~a~%" c))
@@ -359,8 +354,8 @@ (define sway-menu
              (close to)
              (let ((choice (read-line from)))
                (close from)
-               (waitpid (first pid))
-               (when (string? choice) ;do not attempty to launch if no choice
+               (waitpid (first pids))
+               (when (string? choice) ;do not attempt to launch if no choice
                                       ;was given (e.g. if Escape is pressed in
                                       ;wmenu).
                  (execl swaymsg swaymsg "exec" "--"
@@ -464,9 +459,6 @@ (define %sway-default-keybindings
     ($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
@@ -751,7 +743,7 @@ (define (sway-configuration->file conf)
     (computed-file
      "sway-config"
      #~(begin
-         (use-modules (ice-9 format) (ice-9 popen) (ice-9 match)
+         (use-modules (ice-9 format) (ice-9 match) 
                       (srfi srfi-1))
 
          (call-with-output-file #$output
@@ -859,7 +851,7 @@ (define (sway-configuration->file conf)
 
 
 ;;;
-;;; Definition of th Home Service.
+;;; Definition of the Home Service.
 ;;;
 
 (define (sway-configuration->files sway-conf)

-- 
2.45.2

I also reindented the commit message and put a line break because the
last line did not fit on my terminal.

Thank you greatly!

Regards,
Florian

Subject: [PATCH] home: services: Add 'home-sway-service-type'.
From: Arnaud Daby-Seesaram <[email-masked]>
To: [email-masked]
Cc: Arnaud Daby-Seesaram <[email-masked]>
Date: Mon, 19 Aug 2024 17:30:42 +0200
List-Id: <debbugs-submit.debbugs.gnu.org>

* gnu/home/services/sway.scm (home-sway-service-type): New variable.
  (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.

Change-Id: Ia29a4173ce3a887d5fac3f57ba3819a52f9624d3
---
This patch provides an *experimental* home service to configure sway.

It defines a configuration record that contains fields for common
options of sway (an extra-contents field that can be used for
additional settings).  The service also adds packages to the user
profile (notably sway).

Feedback is welcome !

Please note that (1) I only use Guile for Guix, so my code might be
clumsy and non-idiomatic¹ and (2) the patch is experimental, and will
need polishing before being merged.  For example, I am not sure when I
should allow G-expressions in the configuration.
                              ¹: feel free to share your opinions on
                                 how to improve the code.

I have not written any documentation at the time (even documentation
strings in the configuration records are not well defined).  I am
waiting for the code structure and configuration records to be
stable-ish to take the time to write a documentation.

 gnu/home/services/sway.scm | 622 +++++++++++++++++++++++++++++++++++++
 1 file changed, 622 insertions(+)
 create mode 100644 gnu/home/services/sway.scm

diff --git a/gnu/home/services/sway.scm b/gnu/home/services/sway.scm
new file mode 100644
index 0000000000..3f978d0bf0
--- /dev/null
+++ b/gnu/home/services/sway.scm
@@ -0,0 +1,622 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Arnaud Daby-Seesaram <[email-masked]>
+;;;
+;;; 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))
+
+;; Helper function.
+(define (flatten l)
+  (let loop ((lst l) (acc '()))
+    (match lst
+      (() acc)
+      ((head . tail)
+       (loop tail (append acc head))))))
+
+
+;;;
+;;; 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")))
+
+
+;;;
+;;; 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
+    (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)))))))
+    "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.")
+  (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."))
+
+
+;;;
+;;; 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 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))))
+  (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 (make-sway-config 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))
+           ;; Helper functions to pretty-print the configuration file.
+           (define (line s)
+             (lambda (port)
+               (lambda (i)
+                 (format port "~a~a~%" (string-pad "" i) s)
+                 (values port i))))
+           (define (lines lst)
+             (lambda (port)
+               (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))))
+                 (values port 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 (port)
+               (lambda (i)
+                 (values port (+ i k)))))
+           (define (begin-block name)
+             (lambda (port)
+               (lambda (i)
+                 (format port "~a~a {~%" (string-pad "" i) name)
+                 (values port (+ i 4)))))
+           (define (end-block)
+             (lambda (port)
+               (lambda (i)
+                 (let ((i (- i 4)))
+                   (format port "~a}~%" (string-pad "" i))
+                   (values port i)))))
+
+           (let* ((file #$output)
+                  (port (open-output-file #$output)))
+             ;; The previous iteration of this work computed the content of the
+             ;; configuration file as a string.  The state monad was used to
+             ;; keep track of the state during the computation.
+             ;; However, this first approach was too expensive.  Now that I use
+             ;; `computed-file', the "computed value" is the constant port to
+             ;; which I write.  Thus, using the state monad is overkill here.
+             ;; It can be replaced by the identity monad, where the value being
+             ;; passed around is the pair of `port' and the indentation level.
+             (run-with-state
+                 (with-monad
+                     %state-monad
+                   (>>= (return port)
+                        ;; 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."
+                         "# ===================="
+                         #$@(map serialize-exec
+                                 (sway-configuration-execs conf)))))
+               0)))))))
+
+(define (sway-configuration->file sway-conf)
+  `((".config/sway/config"
+     ,(make-sway-config
+       sway-conf))))
+
+(define home-sway-service-type
+  (service-type
+   (name 'home-sway-config)
+   (extensions
+    (list (service-extension home-files-service-type
+                             sway-configuration->file)
+          (service-extension home-profile-service-type
+                             sway-configuration-packages)))
+   (description "Configure Sway by providing a file
+@file{~/.config/sway/config}.")
+   (default-value (sway-configuration))))

base-commit: d3832de763777759eb1f56e20731cb39da4c7b5b
-- 
2.45.2