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: Arnaud Daby-Seesaram <ds-ac <at> nanein.fr> To: 72714 <at> debbugs.gnu.org Cc: Hilton Chain <hako <at> ultrarare.space>, Ludovic Courtès <ludo <at> gnu.org>, Arnaud Daby-Seesaram <ds-ac <at> nanein.fr>, Florian Pelz <pelzflorian <at> pelzflorian.de> Subject: [bug#72714] [PATCH] home: services: Add 'home-sway-service-type'. Date: Wed, 2 Oct 2024 00:12:58 +0200
* 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 <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 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))))))
+
+
+;;;
+;;; 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'")))
+
+
+;;;
+;;; 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."))
+
+
+;;;
+;;; 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.