From patchwork Mon Aug 26 10:38:13 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Arnaud Daby-Seesaram X-Patchwork-Id: 30335 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id B436127BBE2; Mon, 26 Aug 2024 11:40:33 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-6.4 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_VALIDITY_CERTIFIED, RCVD_IN_VALIDITY_RPBL,RCVD_IN_VALIDITY_SAFE,SPF_HELO_PASS, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 542E827BBE2 for ; Mon, 26 Aug 2024 11:40:29 +0100 (BST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1siX8w-0006jN-69; Mon, 26 Aug 2024 06:40:14 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1siX8t-0006j8-AF for guix-patches@gnu.org; Mon, 26 Aug 2024 06:40:11 -0400 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1siX8t-00073o-0s for guix-patches@gnu.org; Mon, 26 Aug 2024 06:40:11 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:Date:From:To:In-Reply-To:References:Subject; bh=Y71XP0CT6r3f+GJ2Ii5Bif6ml1SES71wVeuZqCLCdW8=; b=Z7ZRYIKngrbCmED9I0VN9HhFmp1ILnFTmwpn0HZPJ6M1CqJPKKO8wbjvVSb6oByVi4ECLOAJG6or17DUQ3VaFZn8iEjyJhRxjp62kdGn8PPaLPTLanvZqpHz2c07CN09AQLIfPukMVsgAcoyQ9+PhqXxR6Jjh//uke5WtgwXlr1eCNv7j/ORFEEy9mHvmNemqwSJGel6syaVuYpeTVK7b4ZVuHqN4FV/OZfQvxWaQyW17DfvzkJi7SvEml3at1GprmMnd3XJ2BhYBTMgD6XcFNY1KTXfev+WRTx6REe5qdoXF0KRBiZT5ai4YzH0E3ky+j5aTGVpqwSOo0uTW/vywQ==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1siX9h-0000Js-PJ for guix-patches@gnu.org; Mon, 26 Aug 2024 06:41:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#72714] [PATCH v3] home: services: Add 'home-sway-service-type'. References: <1e82e473639f21a2950a0827f156437ef1bc9c48.1724081442.git.ds-ac@nanein.fr> In-Reply-To: <1e82e473639f21a2950a0827f156437ef1bc9c48.1724081442.git.ds-ac@nanein.fr> Resent-From: Arnaud Daby-Seesaram Original-Sender: "Debbugs-submit" Resent-CC: , guix-patches@gnu.org Resent-Date: Mon, 26 Aug 2024 10:41:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 72714 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 72714@debbugs.gnu.org Cc: Arnaud Daby-Seesaram , ( , Andrew Tropin , Florian Pelz , Ludovic =?utf-8?q?Court=C3=A8s?= , Matthew Trzcinski , Maxim Cournoyer , Tanguy Le Carrour X-Debbugs-Original-Xcc: ( , Andrew Tropin , Florian Pelz , Ludovic =?utf-8?q?Court=C3=A8s?= , Matthew Trzcinski , Maxim Cournoyer , Tanguy Le Carrour Received: via spool by 72714-submit@debbugs.gnu.org id=B72714.17246688381180 (code B ref 72714); Mon, 26 Aug 2024 10:41:01 +0000 Received: (at 72714) by debbugs.gnu.org; 26 Aug 2024 10:40:38 +0000 Received: from localhost ([127.0.0.1]:43782 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1siX9J-0000Iw-0H for submit@debbugs.gnu.org; Mon, 26 Aug 2024 06:40:38 -0400 Received: from nanein.fr ([185.230.78.41]:36900) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1siX9F-0000IW-Dv for 72714@debbugs.gnu.org; Mon, 26 Aug 2024 06:40:36 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=nanein.fr; s=mail; t=1724668745; bh=SLmzisil8S9xV+JQBWBsgznliYhQIaCUUh7b0UdGUXw=; h=From:To:Cc:Subject:Date:From; b=AXyJznBY2je4XME4x19e73/CbxF8ooXXzbWRkxBQIyXVlGA9Uw2hThmKWT6RPZORQ WwQHBwWRtS5G0vTE4/QGHPidFbMQAKSZRV7vsrVTZTTRK45gIbB1bo8n75Ek2GHexY 9LpTCB9mCMVwcg0/kiy8kGXhuBIrmJEmViHLXlLjMMJERcSsgHXeflLbpmFBXxVNIW +WPWjh810vXFOtEcDjGFq6ntbFbAwhB3aSvkSBBi8UkPurvkJpCkb9xyN/DN+uoWzP JA/4BVRFIKpkuR/BHR7qsROZQ2i+DrRQiXRoOftqpEMuMUzxu8F0VqdZ65UV/3WeMX cmbBCL6unYB9qY/XkKwVPwslmG2mRVevpRKqy4Fk4P0cfFBATysHl+fWDDjSPM1/41 Vay663z1xUKiR0UsphV8JKkXSRrKTs3REPjs8y6qPhUmL0/QjhSLEY6I/4LcMhuFiB 15Ob5vjbzHENLvLGwg7T1C4HVB0pWqQypUJ6m3iTFpVEwuh4QIcUvvyN/bBe7vgYVW ivrX/0r5SzQlkk+h/Vl3yQAYU2kKraBp6Bj6+HCjRdiCP5u6bkt+RkQVTc0QmmVqNu iy48LYbxKHsZI7+sTis3vf3+Fa2hgisqpPrIvwZRlbeEx9B5n9Zd7u7Pf6HVv0egsQ Ng5iLdyeWgB+tabQ1rs3JkLI= Received: from localhost.localdomain (unknown [IPv6:2a01:e34:ec01:e860:5b27:5fd8:232b:dd64]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (prime256v1) server-digest SHA256) (No client certificate requested) by nanein.fr (Postfix) with ESMTPSA id C4F3E140266; Mon, 26 Aug 2024 12:39:05 +0200 (CEST) Date: Mon, 26 Aug 2024 12:38:13 +0200 Message-ID: <4b0a03801d5879f745e791635f57b9fa591fc0d2.1724668693.git.ds-ac@nanein.fr> X-Mailer: git-send-email 2.45.2 MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Reply-to: Arnaud Daby-Seesaram X-ACL-Warn: , Arnaud Daby-Seesaram via Guix-patches X-Patchwork-Original-From: Arnaud Daby-Seesaram via Guix-patches via From: Arnaud Daby-Seesaram Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * gnu/home/services/sway.scm: New file. (home-sway-service-type): New variable. (sway-configuration->file): New procedure. (sway-configuration): New configuration record. (sway-bar): New configuration record. (sway-output): New configuration record. (sway-input): New configuration record. (point): New configuration record. (sway-color): New configuration record. (sway-border-color): New configuration record. (flatten): New procedure. * gnu/local.mk: Add gnu/home/services/sway.scm. * doc/guix.texi (Sway window manager): New node to document the above changes. Change-Id: Iad4fee02d1c243eb051245277f2e2643523e6d27 --- Minor fix: do not attempt to serialise bar colours if none are specified. doc/guix.texi | 255 +++++++++++++++ gnu/home/services/sway.scm | 632 +++++++++++++++++++++++++++++++++++++ gnu/local.mk | 1 + 3 files changed, 888 insertions(+) create mode 100644 gnu/home/services/sway.scm base-commit: f10cbebd7b6cfeb66e91851616fdc75f9a0bbe69 diff --git a/doc/guix.texi b/doc/guix.texi index fcaf6b3fbb..c69a021a77 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -129,6 +129,7 @@ Copyright @copyright{} 2024 Richard Sent@* Copyright @copyright{} 2024 Dariqq@* Copyright @copyright{} 2024 Denis 'GNUtoo' Carikli@* +Copyright @copyright{} 2024 Arnaud Daby-Seesaram@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -45161,6 +45162,7 @@ Home Services * Messaging: Messaging Home Services. Services for managing messaging. * Media: Media Home Services. Services for managing media. * Networking: Networking Home Services. Networking services. +* Sway: Sway window manager. Setting up the sway configuration. * Miscellaneous: Miscellaneous Home Services. More services. @end menu @c In addition to that Home Services can provide @@ -47074,6 +47076,259 @@ Media Home Services @end table @end deftp +@node Sway window manager +@subsection Sway window manager +@cindex Sway, Home service + +The @code{(gnu home services sway)} module provides +@code{home-sway-service-type}, a home service to configure sway in a +declarative way. + +@quotation Note +This home service only sets up configuration file and profile packages +for sway. It does @i{not} start sway in any way. If you want to do so, +you might be interested in using @code{greetd-wlgreet-sway-session} +instead. + +The function @code{sway-configuration->file} defined below can be used +to provide the value for the @code{sway-configuration} field of +@code{greetd-wlgreet-sway-session}. +@end quotation + +@defvar sway-configuration->file +This function takes a @code{sway-configuration} record (defined below), +and returns a file-like object represented the serialized configuration. +@end defvar + +@defvar home-sway-service-type +This is a home service type to set up Sway. It takes care of: +@itemize +@item +providing a @file{~/.config/sway/config} file, +@item +adding sway-related packages to your profile. +@end itemize + +Here is an example of a service and its configuration that you could add +to the @code{services} field of your @code{home-environment}: + +@lisp +(define bg-file + (computed-file + "background.png" + #~(let* ((insvg (string-append + #$guix-backgrounds + "/share/backgrounds/guix/guix-checkered-16-9.svg")) + (out #$output) + (cmd (string-append + #$librsvg "/bin/rsvg-convert " insvg " -o " out))) + (system cmd)))) + +(service home-sway-service-type + (sway-configuration + (gestures + '((swipe:3:down . "move to scratchpad") + (swipe:3:up . "scratchpad show"))) + (outputs + (list (sway-output + (identifier '*) + (bg bg-file)))))) +@end lisp + +The above example describes a sway configuration in which +@itemize +@item +all monitors use a particular wallpaper whose @file{.svg} is provided by +the @code{guix-background} package; +@item +swiping down (resp.@ up) with three fingers moves the active window to +the scratchpad (resp.@ shows/hides the scratchpad). +@end itemize +@end defvar + + +@deftp {Data Type} sway-configuration +This configuration record describes the sway configuration +(see@ @cite{sway(5)}). Available fields are: + +@table @asis +@item @code{variables} (default: @code{%sway-default-variables}) +The value of this field is an association list in which keys are symbols +and values are strings. + +Example: @code{'(mod . "Mod4")}. + +@item @code{keybindings} (default: @code{%sway-default-keybindings}) +The value of this field is an association list in which keys are symbols +and values are strings or G-expressions (@pxref{G-Expressions}). + +Examples using: +@itemize +@item +a string: @code{'($mod+Return . "exec $term")} +@item +a G-exp: @code{`($mod+t . ,#~(string-append #$st "/bin/st"))} +@end itemize + +@item @code{gestures} (default: @code{%sway-default-gestures}) +This value of this field is an association list, as for keybindings. + +@item @code{packages} (default: @code{%sway-default-packages}) +This field describes a list of packages to add to the user profile. + +@item @code{inputs} (default: @code{(list (sway-input))}) +List of @code{sway-input} configuration records. + +@item @code{outputs} (default: @code{'()}) +List of @code{sway-output} configuration records. + +@item @code{bar} (default: @code{(sway-bar)}) +Bar configuration. + +@item @code{always-execs} (default: @code{'()}) +Programs to execute at startup time @i{and} after every configuration +reload. The value of this field is a list of strings or G-expressions. + +@item @code{execs} (default: @code{'()}) +Programs to execute at startup time. The value of this field is a list +of strings or G-expressions. + +@item @code{extra-content} (default: @code{'()}) +Lines to add to the configuration file. The value of this field is a +list of strings or G-expressions. + +@end table +@end deftp + +@deftp {Data Type} sway-input +@code{sway-input} records describe input blocks +(see@ @cite{sway-input(5)}). Available fields are: + +@table @asis +@item @code{identifier} (default: @code{'*}) +Identifier of the input. The field accepts symbols and strings. If a +string is used, it will be quoted in the generated configuration file. + +@item @code{xkb-layout} (optional) +Keyboard specific option. Comma-separated keyboard layout(s) to use. + +@item @code{xkb-model} (optional) +Keyboard specific option. String providing the keyboard model. + +@item @code{xkb-options} (optional) +Keyboard specific option. Additional xkb options for the keyboard. + +@item @code{xkb-variant} (optional) +Keyboard specific option. String specifying the variant of the layout. + +@item @code{extra-content} (default: @code{'()}) +Lines to add to the input block. The value of this field is a list of +strings or G-expressions. + +@end table + +For example, the following snippet makes all keyboards use a french +layout, in which @kbd{capslock} has been remaped to @kbd{ctrl}: +@lisp +(sway-input (identifier "type:keyboard") + (xkb-layout "fr") + (xkb-options '("ctrl:nocaps"))) +@end lisp +@end deftp + + +@deftp {Data Type} sway-output +@code{sway-output} records describe sway outputs +(see@ @cite{sway-output(5)}). Available fields are: + +@table @asis +@item @code{identifier} (default: @code{'*}) +Identifier of the monitor. If the +@code{identifier} is a symbol, it is inserted as is; if it is a string, +it will be quoted in the configuration file. + +@item @code{resolution} (optional) +This string defines the resolution of the monitor. + +@item @code{position} (optional) +The (optional) value of this field must be a @code{point}. +Example: +@lisp +(position + (point (x 1920) + (y 0))) +@end lisp + +@item @code{bg} (optional) +This field accepts a file-like value representing the wallpaper to use +on this monitor. It will be used with the @code{fill} option. + +@item @code{extra-content} (default: @code{'()}) +Any additional lines to be added to the output configuration block. +Elements of the list must be either strings or G-expressions. + +@end table +@end deftp + + +@deftp {Data Type} sway-border-color + +@table @asis +@item @code{border} Color of the border. +@item @code{background} Color of the background. +@item @code{text} Color of the text. +@end table +@end deftp + + +@deftp {Data Type} sway-color +@table @asis +@item @code{background} +@item @code{statusline} +@item @code{focused-background} +@item @code{focused-statusline} +@item @code{focused-workspace} +@item @code{active-workspace} +@item @code{inactive-workspace} +@item @code{urgent-workspace} +@item @code{binding-mode} +@end table +@end deftp + + +@deftp {Data Type} sway-bar +Describes the Sway bar (see@ @cite{sway-bar(5)}). + +@table @asis +@item @code{identifier} (default: @code{'bar0}) +Identifier of the bar. The value must be a string. + +@item @code{position} (default: @code{'top}) +Specify the position of the bar. Accepted values are @code{'top} or +@code{'bottom}. + +@item @code{hidden-state} (default: @code{'hide}) +Specify the apparence of the bar when it is hidden. Accepted values are +@code{'hide} or @code{show}. + +@item @code{binding-mode-indicator} (default: @code{#t}) +Enable or disable the binding mode indicator. + +@item @code{colors} (optional) +An optional @code{sway-color} configuration record. + +@item @code{status-command} (default: @code{%sway-status-command}) +This field accept executable file-like values. The default value is a +script that prints the battery information (retrieved using +@code{acpi}), date and time every second. + +Each line printed on @code{stdout} by this script will be displayed on +the status area of the bar. + +@end table +@end deftp + + @node Networking Home Services @subsection Networking Home Services diff --git a/gnu/home/services/sway.scm b/gnu/home/services/sway.scm new file mode 100644 index 0000000000..91d01f6eb4 --- /dev/null +++ b/gnu/home/services/sway.scm @@ -0,0 +1,632 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2024 Arnaud Daby-Seesaram +;;; +;;; 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 . + +(define-module (gnu home services sway) + #:use-module (guix monads) + #:use-module (guix modules) + #:use-module (guix gexp) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 popen) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (guix packages) + #:use-module (gnu services configuration) + #:use-module (gnu home services) + #:use-module (gnu packages freedesktop) + #:use-module (gnu packages xdisorg) + #:use-module (gnu packages image) + #:use-module (gnu packages gnome) + #:use-module (gnu packages wm) + #:use-module (gnu packages emacs) + #:use-module (gnu packages linux) + #:use-module (gnu packages base) + #:use-module (gnu packages suckless) + #:use-module (gnu packages glib) + #:export (;; Accessors and predicates do not need to be exported. + sway-configuration + sway-bar + sway-output + sway-input + point + sway-color + sway-border-color + home-sway-service-type + sway-configuration->file + %sway-default-variables + %sway-default-gestures + %sway-default-keybindings + %sway-default-status-command + )) + +;; Helper function. +(define (flatten l) + (let loop ((lst l) (acc '())) + (match lst + (() acc) + ((head . tail) + (loop tail (append acc head)))))) + + +;;; +;;; Default settings. +;;; + +(define %sway-default-variables + `((mod . "Mod4") + (left . "h") + (down . "j") + (up . "k") + (right . "l") + (term . ,#~(string-append #$st "/bin/st")) + (menu . ,#~(string-append #$dmenu "/bin/dmenu_run")))) + +(define %sway-default-gestures + `((swipe:3:right . "workspace next_on_output") + (swipe:3:left . "workspace prev_on_output") + (swipe:3:down . "move to scratchpad") + (swipe:3:up . "scratchpad show") + (pinch:2:clockwise + . "move container to workspace prev_on_output") + (pinch:2:counterclockwise + . "move container to workspace next_on_output") + (swipe:4:left . "exec alacritty") + (swipe:4:right . "exec qutebrowser") + (swipe:4:down . "exec st") + (swipe:4:up + . ,#~(string-append + "exec " #$emacs "/bin/emacsclient -a '" + #$libnotify "/bin/notify-send Oups \"emacs not loaded :/\"' -c")) + (pinch:inward+right . "resize shrink width") + (pinch:inward+left . "resize grow width") + (pinch:inward+down . "resize shrink height") + (pinch:inward+up . "resize grow height") + (pinch:outward+up . "move up") + (pinch:outward+down . "move down") + (pinch:outward+left . "move left") + (pinch:outward+right . "move right"))) + +(define %sway-default-keybindings + `(($mod+Shift+e + . ,#~(string-append + "exec " #$emacs + "/bin/emacsclient -a '" + #$libnotify "/bin/notify-send Oups \"emacs not loaded :/\"' -c")) + ($mod+Return . "exec $term") + ($mod+Shift+c . "kill") + ($mod+p . "exec $menu") + ($mod+Shift+r . "reload") + ($mod+Shift+q + . ,#~(string-append + "exec " #$sway "/bin/swaynag -t warning " + "-m 'You pressed the exit shortcut. Do you really want to exit sway?" + " This will end your Wayland session.'" + " -B 'Yes, exit sway' 'swaymsg exit'")) + ($mod+$left . "focus left") + ($mod+$right . "focus right") + ($mod+$up . "focus up") + ($mod+$down . "focus down") + ($mod+Shift+$left . "move left") + ($mod+Shift+$right . "move right") + ($mod+Shift+$up . "move up") + ($mod+Shift+$down . "move down") + ($mod+ampersand . "workspace number 1") + ($mod+eacute . "workspace number 2") + ($mod+quotedbl . "workspace number 3") + ($mod+apostrophe . "workspace number 4") + ($mod+parenleft . "workspace number 5") + ($mod+minus . "workspace number 6") + ($mod+egrave . "workspace number 7") + ($mod+underscore . "workspace number 8") + ($mod+ccedilla . "workspace number 9") + ($mod+agrave . "workspace number 10") + ($mod+Shift+ampersand . "move container to workspace number 1") + ($mod+Shift+eacute . "move container to workspace number 2") + ($mod+Shift+quotedbl . "move container to workspace number 3") + ($mod+Shift+apostrophe . "move container to workspace number 4") + ($mod+Shift+parenleft . "move container to workspace number 5") + ($mod+Shift+minus . "move container to workspace number 6") + ($mod+Shift+egrave . "move container to workspace number 7") + ($mod+Shift+underscore . "move container to workspace number 8") + ($mod+Shift+ccedilla . "move container to workspace number 9") + ($mod+Shift+agrave . "move container to workspace number 10") + ($mod+b . "splith") + ($mod+v . "splitv") + ($mod+s . "layout stacking") + ($mod+w . "layout tabbed") + ($mod+e . "layout toggle split") + ($mod+f . "fullscreen") + ($mod+Shift+space . "floating toggle") + ($mod+space . "focus mode_toggle") + ($mod+z . "focus parent") + ($mod+Shift+o . "move scratchpad") + ($mod+o . "scratchpad show") + ($mod+r . "mode \"resize\"") + ($mod+Shift+n . "bar mode toggle") + ($mod+Shift+b . "border toggle") + ($mod+tab . "workspace back_and_forth"))) + +(define %sway-default-status-command + (program-file + "sway-bar-status" + (with-imported-modules + (source-module-closure + '((ice-9 textual-ports) (ice-9 regex) (ice-9 popen) (ice-9 format) + (srfi srfi-19))) + #~(begin + (use-modules (ice-9 textual-ports) + (ice-9 format) + (ice-9 popen) + (ice-9 regex) + (srfi srfi-19)) + (let loop () + (let* ((date (date->string (current-date) "~a ~D ~H:~M:~S")) + (batline (let* ((p (open-pipe* + OPEN_READ + #$(file-append acpi "/bin/acpi") "-b")) + (bat (get-line p))) + (close-pipe p) + bat)) + (bat (match:substring (string-match "[0-9]+%" batline)))) + (format #t "~a - ~a~%~!" bat date) + (sleep 1) + (loop))))))) + + +;;; +;;; Definition of configurations. +;;; + +(define (list-of-string-or-gexp? lst) + (every (lambda (elt) + (or (string? elt) + (gexp? elt))) + lst)) + +(define (list-of-packages? lst) + (every package? lst)) + +(define (bar-position? p) + (member p '(top bottom))) + +(define (hidden-state? st) + (member st '(hide show))) + +(define (string-or-symbol? s) + (or (string? s) + (symbol? s))) + +(define (strings? lst) + (every string? lst)) + +(define-maybe string (no-serialization)) +(define-maybe strings (no-serialization)) + +(define-configuration/no-serialization sway-input + (identifier + (string-or-symbol '*) + "Identifier of the input.") + (xkb-layout + maybe-string + "Keyboard layout.") + (xkb-model + maybe-string + "Keyboard model.") + (xkb-options + maybe-strings + "Keyboard options.") + (xkb-variant + maybe-string + "Keyboard layout variant.") + (extra-content + (list-of-string-or-gexp '()) + "Lines to add at the end of the configuration file.")) + +(define (sway-inputs? lst) + (every sway-input? lst)) + +(define-configuration/no-serialization sway-border-color + (border + string + "Border color.") + (background + string + "Background color.") + (text + string + "Text color.")) + +(define-maybe sway-border-color (no-serialization)) + +(define-configuration/no-serialization sway-color + (background + maybe-string + "Background color of the bar.") + (statusline + maybe-string + "Text color of the separator.") + (focused-background + maybe-string + "Background color of the bar on the currently focused monitor.") + (focused-statusline + maybe-string + "Text color of the statusline on the currently focused monitor.") + (focused-workspace + maybe-sway-border-color + "...") + (active-workspace + maybe-sway-border-color + "...") + (inactive-workspace + maybe-sway-border-color + "...") + (urgent-workspace + maybe-sway-border-color + "...") + (binding-mode + maybe-sway-border-color + "...")) + +(define-maybe sway-color (no-serialization)) + +(define-configuration/no-serialization sway-bar + (identifier + (symbol 'bar0) + "Identifier of the bar.") + (position + (bar-position 'top) + "Position of the bar.") + (hidden-state + (hidden-state 'hide) + "Hidden state.") + (binding-mode-indicator + (boolean #t) + "Binding indicator.") + (colors + maybe-sway-color + "Color palette of the bar.") + (status-command + (file-like %sway-default-status-command) + "Status command. It must be file-like.")) + +(define-configuration/no-serialization point + (x integer "X coordinate.") + (y integer "Y coordinate.")) + +(define-maybe point (no-serialization)) +(define-maybe file-like (no-serialization)) + +(define-configuration/no-serialization sway-output + (identifier + (string-or-symbol '*) + "Identifier of the output.") + (resolution + maybe-string + "Mode of the monitor.") + (position + maybe-point + "Position of the monitor.") + (bg + maybe-file-like + "Background image.") + (extra-content + (list-of-string-or-gexp '()) + "Extra lines.")) + +(define (sway-outputs? lst) + (every sway-output? lst)) + +(define-configuration/no-serialization sway-configuration + (keybindings + (alist %sway-default-keybindings) + "Keybindings.") + (gestures + (alist %sway-default-gestures) + "Gestures.") + (packages + (list-of-packages + (list sway swaylock waybar swaybg slurp grim dmenu bemenu + dbus xdg-desktop-portal-wlr xdg-desktop-portal)) + "List of packages to add to the profile.") + (variables + (alist %sway-default-variables) + "Variables declared at the beginning of the file.") + (inputs + (sway-inputs (list (sway-input))) + "Inputs.") + (outputs + (sway-outputs '()) + "Outputs.") + (bar + (sway-bar (sway-bar)) + "Bar configuration.") + (always-execs + (list-of-string-or-gexp '()) + "Programs to execute at startup time.") + (execs + (list-of-string-or-gexp '()) + "Programs to execute at startup time.") + (extra-content + (list-of-string-or-gexp '()) + "Lines to add at the end of the configuration file.")) + + +;;; +;;; Serialization functions. +;;; + +(define (serialize-keybinding var) + (let ((name (symbol->string (car var))) + (value (cdr var))) + #~(string-append "bindsym " #$name " " #$value))) + +(define (serialize-gesture var) + (let ((name (symbol->string (car var))) + (value (cdr var))) + #~(string-append "bindgesture " #$name " " #$value))) + +(define (serialize-variable var) + (let ((name (symbol->string (car var))) + (value (cdr var))) + #~(string-append "set $" #$name " " #$value))) + +(define (serialize-exec b) + (if b + (lambda (exe) + #~(string-append "exec_always " #$exe)) + (lambda (exe) + #~(string-append "exec " #$exe)))) + +(define (serialize-output out) + (let* ((pre-ident (sway-output-identifier out)) + (ident (if (symbol? pre-ident) + (symbol->string pre-ident) + (string-append "\"" pre-ident "\""))) + (bg (sway-output-bg out)) + (resolution (sway-output-resolution out)) + (position (sway-output-position out)) + (extra-content (sway-output-extra-content out))) + (append + (filter + (lambda (elt) (not (eq? elt %unset-value))) + (list + ;; Beginning of the block. + #~(string-append "output " #$ident " {") + ;; Optional elements. + (if (eq? %unset-value bg) + %unset-value + #~(string-append " bg " #$bg " fill")) + (if (eq? %unset-value resolution) + %unset-value + (string-append " resolution " resolution)) + (if (eq? %unset-value position) + %unset-value + (string-append " position " (number->string (point-x position)) + " " (number->string (point-y position)))))) + extra-content + ;; End of the block. + '("}")))) + +(define-inlinable (add-line-if prefix value) + (if (eq? %unset-value value) + %unset-value + (string-append prefix " " value))) + +(define (serialize-input input) + (let* ((pre-ident (sway-input-identifier input)) + (ident (if (symbol? pre-ident) + (symbol->string pre-ident) + (string-append "\"" pre-ident "\""))) + (xkb-layout (sway-input-xkb-layout input)) + (xkb-model (sway-input-xkb-model input)) + (xkb-variant (sway-input-xkb-variant input)) + (xkb-options (sway-input-xkb-options input))) + (append + (filter + (lambda (elt) (not (eq? elt %unset-value))) + (list + (string-append "input " ident " {") + ;; Optional. + (add-line-if " xkb_layout" xkb-layout) + (add-line-if " xkb_model" xkb-model) + (add-line-if " xkb_variant" xkb-variant) + (if (eq? %unset-value xkb-options) + %unset-value + (string-concatenate (cons " xkb_options " xkb-options))))) + (map (lambda (s) + (string-append (string-pad "" 4) s)) + (sway-input-extra-content input)) + '("}")))) + +(define (serialize-colors colors) + (define (add-border-color-if name val) + (if (eq? %unset-value val) + %unset-value + (string-append + name + " " (sway-border-color-border val) + " " (sway-border-color-background val) + " " (sway-border-color-text val)))) + (if (eq? %unset-value colors) + '() + (let ((background (sway-color-background colors)) + (statusline (sway-color-statusline colors)) + (focused-background (sway-color-focused-background colors)) + (focused-statusline (sway-color-focused-statusline colors)) + (focused-workspace (sway-color-focused-workspace colors)) + (active-workspace (sway-color-active-workspace colors)) + (inactive-workspace (sway-color-inactive-workspace colors)) + (urgent-workspace (sway-color-urgent-workspace colors)) + (binding-mode (sway-color-binding-mode colors))) + (filter + (lambda (elt) (not (eq? elt %unset-value))) + (list + (add-line-if "background" background) + (add-line-if "statusline" statusline) + (add-line-if "focused_background" focused-background) + (add-line-if "focused_statusline" focused-statusline) + (add-border-color-if "focused_workspace" focused-workspace) + (add-border-color-if "active_workspace" active-workspace) + (add-border-color-if "inactive_workspace" inactive-workspace) + (add-border-color-if "urgent_workspace" urgent-workspace) + (add-border-color-if "binding_mode" binding-mode)))))) + +(define (sway-configuration->file conf) + (let* ((extra (sway-configuration-extra-content conf)) + (bar (sway-configuration-bar conf))) + + (with-imported-modules + (source-module-closure + '((ice-9 popen) (ice-9 match) (ice-9 format) (guix monads))) + (computed-file + "sway-config" + #~(begin + (use-modules (ice-9 format) (ice-9 popen) (ice-9 match) + (guix monads)) + + (let* ((file #$output) + (port (open-output-file #$output))) + + ;; Helper functions to pretty-print the configuration file. + (define (line s) + (lambda (i) + (format port "~a~a~%" (string-pad "" i) s) + i)) + (define (lines lst) + (lambda (i) + (let loop ((l lst)) + (match l + (() #t) + ((head . tail) + (format port "~a~a~%" (string-pad "" i) + (if (list? head) + (string-concatenate head) + head)) + (loop tail)))) + i)) + (define-syntax line* + (syntax-rules () + ((line* elt ...) + (lines (list elt ...))))) + (define-syntax line2 + (syntax-rules () + ((line2 a b) + (line (string-append a b))))) + (define (indent k) + (lambda (i) + (+ i k))) + (define (begin-block name) + (lambda (i) + (format port "~a~a {~%" (string-pad "" i) name) + (+ i 4))) + (define (end-block) + (lambda (i) + (let ((i (- i 4))) + (format port "~a}~%" (string-pad "" i)) + i))) + + ;; The value that is threaded in the following block is the + ;; indentation level. + (with-monad %identity-monad + (>>= + ;; We start with no indentation at all. + (return 0) + ;; Header of the configuration file. + (line* + "#####################################" + "### Auto-generated configuration. ###" + "#####################################" + "# DO NOT EDIT MANUALLY." "") + (line* + "# Variables." + "# ==========" + #$@(map serialize-variable + (sway-configuration-variables conf)) "") + (line* + "# Outputs." + "# ========" + #$@(flatten + (map serialize-output + (sway-configuration-outputs conf))) "") + (line* + "# Inputs." + "# =======" + #$@(flatten + (map serialize-input + (sway-configuration-inputs conf))) "") + (line* "# Bar configuration." + "# ==================") + (begin-block + (string-append + "bar " #$(symbol->string + (sway-bar-identifier bar)))) + (line2 "position " #$(symbol->string + (sway-bar-position bar))) + (line2 "hidden_state " + #$(symbol->string + (sway-bar-hidden-state bar))) + (line2 "status_command " + #$(sway-bar-status-command bar)) + (line2 "binding_mode_indicator " + #$(if (sway-bar-binding-mode-indicator bar) + "true" "false")) + (begin-block "colors") + (line* + #$@(serialize-colors (sway-bar-colors bar))) + (end-block) ;; colors + (end-block) ;; bar + (line* + "" "# Extra configuration content." + "# ============================" + #$@extra "") + (line* + "# Keybindings." + "# ============" + #$@(map serialize-keybinding + (sway-configuration-keybindings conf)) + "") + (line* + "# Gestures." + "# =========" + #$@(map serialize-gesture + (sway-configuration-gestures conf)) "") + (line* + "# Programs to execute. (at startup & after reloads)" + "# ====================" + #$@(map (serialize-exec #t) + (sway-configuration-always-execs conf))) + (line* + "# Programs to execute. (at startup)" + "# ====================" + #$@(map (serialize-exec #f) + (sway-configuration-execs conf))))))))))) + +(define (sway-configuration->files sway-conf) + `((".config/sway/config" ,(sway-configuration->file sway-conf)))) + +(define home-sway-service-type + (service-type + (name 'home-sway-config) + (extensions + (list (service-extension home-files-service-type + sway-configuration->files) + (service-extension home-profile-service-type + sway-configuration-packages))) + (description "Configure Sway by providing a file +@file{~/.config/sway/config}.") + (default-value (sway-configuration)))) diff --git a/gnu/local.mk b/gnu/local.mk index ad5494fe95..15788b2fb0 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -112,6 +112,7 @@ GNU_SYSTEM_MODULES = \ %D%/home/services/shepherd.scm \ %D%/home/services/sound.scm \ %D%/home/services/ssh.scm \ + %D%/home/services/sway.scm \ %D%/home/services/syncthing.scm \ %D%/home/services/mcron.scm \ %D%/home/services/utils.scm \