Package: guix-patches;
Reported by: Arnaud Daby-Seesaram <ds-ac <at> nanein.fr>
Date: Mon, 19 Aug 2024 15:33:02 UTC
Severity: normal
Tags: patch
Done: "pelzflorian (Florian Pelz)" <pelzflorian <at> pelzflorian.de>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: help-debbugs <at> gnu.org (GNU bug Tracking System) To: Arnaud Daby-Seesaram <ds-ac <at> nanein.fr> Subject: bug#72714: closed (Re: [PATCH v8] home: services: Add 'home-sway-service-type'.) Date: Sat, 12 Oct 2024 13:13:02 +0000
[Message part 1 (text/plain, inline)]
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 72714 <at> debbugs.gnu.org. -- 72714: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=72714 GNU Bug Tracking System Contact help-debbugs <at> gnu.org with problems
[Message part 2 (message/rfc822, inline)]
From: "pelzflorian (Florian Pelz)" <pelzflorian <at> pelzflorian.de> To: Arnaud Daby-Seesaram <ds-ac <at> nanein.fr> Cc: Hilton Chain <hako <at> ultrarare.space>, Ludovic Courtès <ludo <at> gnu.org>, 72714-done <at> debbugs.gnu.org Subject: Re: [PATCH v8] home: services: Add 'home-sway-service-type'. Date: Sat, 12 Oct 2024 15:11:56 +0200[Message part 3 (text/plain, inline)]Pushed as b64f7984a5e2aba04df72a92f0044e423efe77c6, Change-Id: I880261570c5afdb795f2ce18bac2b9a5c898677f with tiny changes.[diff (text/plain, inline)]--- 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[Message part 5 (text/plain, inline)]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
[Message part 6 (message/rfc822, inline)]
From: Arnaud Daby-Seesaram <ds-ac <at> nanein.fr> To: guix-patches <at> gnu.org Cc: Arnaud Daby-Seesaram <ds-ac <at> nanein.fr> Subject: [PATCH] home: services: Add 'home-sway-service-type'. Date: Mon, 19 Aug 2024 17:30:42 +0200* 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 <ds-ac <at> 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)) + +;; 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.