From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp2.migadu.com ([2001:41d0:303:e16b::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms13.migadu.com with LMTPS id IEB/B5S0BWfkTAEAe85BDQ:P1 (envelope-from ) for ; Tue, 08 Oct 2024 22:39:16 +0000 Received: from aspmx1.migadu.com ([2001:41d0:303:e16b::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp2.migadu.com with LMTPS id IEB/B5S0BWfkTAEAe85BDQ (envelope-from ) for ; Wed, 09 Oct 2024 00:39:16 +0200 X-Envelope-To: larch@yhetil.org Authentication-Results: aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b=LtFC+yS4; dkim=fail ("headers rsa verify failed") header.d=nanein.fr header.s=mail header.b=TfE62y8I; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=pass (policy=none) header.from=gnu.org ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1728427155; h=from:from:sender:sender:reply-to:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-type:content-type: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=S0Lj2sM8iu8nKzTUIhWjmBgepUfvB4nsojfFaq/ryZk=; b=dqhmh7ELoMFp5x2x89smT+86WTHuqYDsk7OFAZVT6G5w6GFu5j33M2VxYZNUNIK2hDL4gG 37qD2Ngshpd38PJ65aYFnRNP5wL1XYUIPnrQijmqNDW46v/PNv/FqZVV5yxYF64YMVTOW4 nHonH034xJzL5wjUedfJ1EqPbRxPZTWAlQWuVklvvQfs5RLYNNgIva/uQNM/XiPbYc/FzO IIWsizmz7OIab/cKC/TssRLVkbxZ+baqQb+BCg+9R6jgt4I90tX7d2lMUpuXDUyM5VOUxo M2jrXdE5jWRtEwhcWgWG4I3nvi3FZi6AKoLDofg0pZP60YP8zREasujcCnOzxA== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1728427155; a=rsa-sha256; cv=none; b=GKBEBV+teD0Jwe6nR1J8+dncTzXLhy6c2VdFAl7WJiNBAmoJYAdccaEvYeBV1Vmd0u3e/Y cJ1wc5B1G54jh4AAE92rIhlHwzHuGHKNTXC8VLFGXwbuZRPpSLQmaFFdolvDfLXtP4XWEf z06EbetDKeBjqqQVpS4oxjkAa0harg8nFtaRAa5sp3WtOAXDKlIrMmec778Rj3824pf5d5 c6Wp1R+0dg6sn8kSj0rLDen7teypzs3s8A07mZC4WdAVjDLFg0NOTvZo+tKDuk6t9sCe5X xZr33GZLFtrxsNALtbx37QB0eWDb84YcBjlAS+fVXPRFhAiM6LWCbdjLJj3Jww== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b=LtFC+yS4; dkim=fail ("headers rsa verify failed") header.d=nanein.fr header.s=mail header.b=TfE62y8I; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=pass (policy=none) header.from=gnu.org Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 259E87DE84 for ; Wed, 09 Oct 2024 00:39:15 +0200 (CEST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1syIr1-0007d3-Ov; Tue, 08 Oct 2024 18:38:55 -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 1syIqz-0007cp-Vm for guix-patches@gnu.org; Tue, 08 Oct 2024 18:38:54 -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 1syIqz-00021e-MJ for guix-patches@gnu.org; Tue, 08 Oct 2024 18:38:53 -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:References:In-Reply-To:Date:From:To:Subject; bh=sv0jOxdvjqYdhYzPu/6UxKra4qoCTq39fDONCoXtbWw=; b=LtFC+yS4vaO+Dj0q3FZWlzypCUsFM3gwWUK0OPieFZk+mQi7S2hIio7Fj9TOrATdmn/X0upisiZ0X9m3DEgTTIFluZfxWMXKPNHzpG8eTDGxMEavCyD0hCm4GRa8ucyUxnmeXfHsklSo9kIsXJcsh+z7d26nKA8k4ONQBPHH++DOgFUVjtv9n45r5V74qpOC4YGvDPGbJVm1CAjvRqdgnF/AQnYpBF5sS6ckwUcRLvWxihW6wyO4a+F2Q9Af9ZR42aID/LSJ8609Jz7KE3tCj55cOB66MzSvuSX6Zn1eWIfwIVzZJTzKGHC79Ul/tePoY2S6lPEx5jcUTZufBbI0LA==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1syIr8-0002zI-Ef for guix-patches@gnu.org; Tue, 08 Oct 2024 18:39:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#72714] [PATCH v8] home: services: Add 'home-sway-service-type'. Resent-From: Arnaud Daby-Seesaram Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 08 Oct 2024 22:39:02 +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: Hilton Chain , Ludovic =?UTF-8?Q?Court=C3=A8s?= , Arnaud Daby-Seesaram , pelzflorian Received: via spool by 72714-submit@debbugs.gnu.org id=B72714.172842708211383 (code B ref 72714); Tue, 08 Oct 2024 22:39:02 +0000 Received: (at 72714) by debbugs.gnu.org; 8 Oct 2024 22:38:02 +0000 Received: from localhost ([127.0.0.1]:54807 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1syIq7-0002xB-QS for submit@debbugs.gnu.org; Tue, 08 Oct 2024 18:38:02 -0400 Received: from nanein.fr ([185.230.78.41]:55388) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1syIq2-0002wp-OX for 72714@debbugs.gnu.org; Tue, 08 Oct 2024 18:37:57 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=nanein.fr; s=mail; t=1728427028; bh=+um8ljdr5JPkK0M6lPX3HEZV2+gSOyYoZtjdNspLbL0=; h=From:To:Cc:Subject:Date:In-Reply-To:References:From; b=TfE62y8I3exMg3Rljx+oJqZFvDbgZyBYZ72NCVszK9msHpG2GbGtsIu1evPuYdGRM 6RRpW3UIvo+7gaVZ/nd8NkBCSAJ1x4tdH8ZgYna324YCWeCbrUp+iGB/vnfJ6qRcx+ cbZxaFl7r1FpSMjszt2Ty+kJktxo4nmZbHgcMM3rUp1XbI5buhkXwaLOK0I0crFSI0 Sid6K4n8OZQ+m6vC3abHwxI2NGGZDOTcqYpsgpIv2qAmsEpZ79iK/TKaKLeKPDLsGr FW/uC/39FP9XkA01Gu2FjVLPgpigwwqviZaNiOr3X6SDftv7nTfrVf3NALCnuuN8TW +z6O3KIuk8H29hQ1tqPH1rz/c0HNZ4hBSo8rEcvo74aVkLCAhAJYUQF5WEVF8D/iL1 G1CFbbeK7jOqFvmmNhnTcbct9fb+Oylku0XPLlC7ibD2ZQeD1bU9Z6hQSvyGL1kvJE u6RvonQuUC9ZSGqHFymhxqfoHHu4ivxX8w82p+kX49n1HTB1Nb4kEFOwz27VTC3bvx RVaVUyyMQNO5TU2bVG52CQqHm1/M/2OMZFbTDHARp88XJaVdSWPMhNDGIxV3OW+8tV I+xVTq8NC3aZ+2lF6uNw6sIi4fXN7EpN57GWqzpy+KIuhwDTZBuIlDUDDrDl0UGd8Y lDM5ADUDn1OQxe6lvpmGFvwg= Received: from cochea.c.hoisthospitality.com (unknown [212.178.179.82]) (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 654E6140266; Wed, 9 Oct 2024 00:37:08 +0200 (CEST) Date: Wed, 9 Oct 2024 00:33:41 +0200 Message-ID: <20241008223645.19674-1-ds-ac@nanein.fr> X-Mailer: git-send-email 2.46.0 In-Reply-To: <87cyka1rda.fsf@pelzflorian.de> References: <87cyka1rda.fsf@pelzflorian.de> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 From: Arnaud Daby-Seesaram via Guix-patches via Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: guix-patches-bounces+larch=yhetil.org@gnu.org X-Migadu-Flow: FLOW_IN X-Migadu-Country: US X-Migadu-Spam-Score: -3.34 X-Spam-Score: -3.34 X-Migadu-Queue-Id: 259E87DE84 X-Migadu-Scanner: mx13.migadu.com X-TUID: ipOLOllTnJoz * 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. (flatmap): New procedure. * gnu/local.mk: Add gnu/home/services/sway.scm. * doc/guix.texi (Sway window manager): New node to document the above changes. --- Hello Florian, Please find below the v8 of the patch. Main changes since the v7 and our last emails : • I no longer call make-string once per line, • I serialize the tap field of input (I forgot it before), • I have added the resize mode of Sway in the default modes, • I have swapped the sections "default values" and "definition of configuration records" in sway.scm so that I could define %sway-default-modes, • I have proof-read the code and documentation, • I have re-tested the code on example configurations (and have hopefully caught all remaining small bugs/oversight). > Please excuse the long delay. No worries; it has only been two days :). > Well, I guess the port must be closed or wmenu does not leave the > while loop. No other way. But perhaps use pipeline from (ice-9 > popen), which is public, unlike open-process. As suggested, I now use `pipeline'. The menu script also makes sure that the output of wmenu is not null before trying to execute it. Best regards, doc/guix.texi | 406 +++++++++++++++++ gnu/home/services/sway.scm | 878 +++++++++++++++++++++++++++++++++++++ gnu/local.mk | 1 + 3 files changed, 1285 insertions(+) create mode 100644 gnu/home/services/sway.scm diff --git a/doc/guix.texi b/doc/guix.texi index 52e36e4354..127219d25f 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,409 @@ 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 '*) + (background (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 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 + +@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-like 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 + +@quotation Note +Default keybindings assume the existence of variables named @code{$mod}, +@code{$left}, @code{$right}, @code{$up} and @code{$down}. If you choose +not to define these variables, make sure to remove keybindings referring +to them. +@end quotation + +@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{%sway-default-modes}) +List of @code{sway-mode} records (described below) to add modes to the +Sway configuration. The default value @code{%sway-default-modes} adds +the ``resize'' mode of the default Sway configuration (as described +below). + +@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{} record) +Keyboard specific option. Field specifying the layout to use for the +input. The value must be a @code{} 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 must a list +whose elements are 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-like object, +@item +a pair. The first argument of this pair must be a string, a +G-expression or a file-like object. The second element describes how +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. +@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 . "exec +$term")))}, left clicks in the status bar open the terminal (assuming +that the variable @code{$term} is bound to a terminal). +@end table +@end deftp + +@deftp {Data Type} sway-mode +Describes a Sway mode (see@ @cite{sway(5)}). For example, the following +snippet defines 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") + (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..9401c80400 --- /dev/null +++ b/gnu/home/services/sway.scm @@ -0,0 +1,878 @@ +;;; 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 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 wm) + #:use-module (gnu packages terminals) + #: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-modes + %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)))))) + + +;;; +;;; Definition of configurations. +;;; + +(define (string-ish? s) + (or (gexp? s) + (file-like? 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-maybe point (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 %sway-default-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.")) + + +;;; +;;; Default settings and useful constants. +;;; + +(define sway-menu + (program-file + "sway-menu.scm" + (with-imported-modules + (source-module-closure '((guix build utils))) + #~(begin + (use-modules (ice-9 popen) + (ice-9 receive) + (ice-9 rdelim) + (ice-9 ftw) + (guix build utils) + (srfi srfi-1)) + + (define (directory->files dir) + (define (executable-file? f) + ;; Cf. `(@ (guix build utils) executable-file?)' for an + ;; explanation of `(zero? ...)'. + (and=> (and (not (eq? (string-ref f 0) #\.)) + (stat f)) + (lambda (s) + (not (or + (zero? (logand (stat:mode s) #o100)) + (eq? (stat:type s) 'directory)))))) + (with-directory-excursion dir + (scandir "." executable-file?))) + + (let ((path (string-append (getenv "HOME") + "/.guix-home/profile/bin")) + (wmenu #$(file-append wmenu "/bin/wmenu")) + (swaymsg #$(file-append sway "/bin/swaymsg"))) + (receive (from to pid) + (pipeline `((,wmenu))) + (for-each + (lambda (c) (format to "~a~%" c)) + (directory->files path)) + (close to) + (let ((choice (read-line from))) + (close from) + (waitpid (first pid)) + (when (string? choice) ;do not attempty to launch if no choice + ;was given (e.g. if Escape is pressed in + ;wmenu). + (execl swaymsg swaymsg "exec" "--" + choice))))))))) + +(define %ev-code-mouse-left 272) +(define %ev-code-mouse-right 273) +(define %ev-code-mouse-scroll-click 274) + +(define %sway-default-modes + (list (sway-mode + (mode-name "resize") + (keybindings + '(($left . "resize shrink width 10px") + ($down . "resize grow height 10px") + ($up . "resize shrink height 10px") + ($right . "resize grow width 10px") + (Left . "resize shrink width 10px") + (Down . "resize grow height 10px") + (Up . "resize shrink height 10px") + (Right . "resize grow width 10px") + (Return . "mode \"default\"") + (Escape . "mode \"default\"")))))) + +(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 . ,sway-menu))) + +(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'"))) + + +;;; +;;; Serialization functions. +;;; + +;; The main serialization code is defined in `sway-configuration->file' below. +;; In this function, the configuration is seen as a list of lines and blocks. +;; +;; The other serialization functions of this files are helpers that will build +;; the above list. Each function either returns a list, or elements that will +;; be put in one. The elements of these lists will either be: +;; - strings, +;; In this case, the string is seen as a line to add to the configuraiton +;; file. +;; - a pair (cons 'begin-block string), +;; In this case, a line "string {" is added to the configuration file, and +;; the indentation level is increased by four. +;; - the symbol 'end-block. +;; In which case the indentation level is decreased by four, and the current +;; configuration block is closed (with the line "}"). + +;; A few 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 ...))))) + +;; Serialization functions: + +(define (box str) + (let* ((len (string-length str)) + (line (make-string (+ 8 len) #\#))) + (list + line + (string-append "### " str " ###") + line))) + +(define (with-heading str lst) + (define (heading str) + (let* ((len (string-length str)) + (line (make-string (+ 2 len) #\#))) + (list + "" ;add an empty line before the configuration section. + (string-append "# " str) + line))) + (if (equal? lst '()) + '() ;if the configuration block is empty, do not add the heading. + (append (heading str) lst))) + +(define-inlinable (serialize-boolean-yn b) + (if b "yes" "no")) +(define-inlinable (serialize-boolean-ed b) + (if b "enable" "disable")) + +(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-y 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))) + + (tap (sway-input-tap input)) + (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-ed) + (add-line-if "dwtp" dwtp + #:serializer serialize-boolean-ed) + (add-line-if "tap" tap + #:serializer serialize-boolean-ed) + ;; 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)) + ;; 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)) + + (call-with-output-file #$output + (lambda (port) + + ;; Add the (indented) line "s" to the output file. + (define (line s) + (lambda (i) + (format port "~a~a~%" i s) + i)) + + ;; Begin a block "name" and adjust the indentation. + (define (begin-block name) + (lambda (i) + (format port "~a~a {~%" i name) + (string-append " " i))) + + ;; Ends an open block and adjust the indentation. + ;; Note: we must currently be in a configuration block. + ;; Otherwise, `string-drop' might fail. + (define (end-block) + (lambda (i) + (let ((i (string-drop i 4))) + (format port "~a}~%" 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 string. This string is prepended to + ;; lines before their serialization. + "" + ;; List of lines or indentation modifiers. + (list + ;; Header. + #$@(box "Auto-generated configuration") + "# DO NOT EDIT MANUALLY." + + ;; Variables. + #$@(with-heading "Variables." + (map serialize-variable + (sway-configuration-variables conf))) + + ;; Outputs. + #$@(with-heading "Outputs." + (flatmap serialize-output + (sway-configuration-outputs conf))) + + ;; Inputs. + #$@(with-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) + '() + (with-heading "Bar configuration." + (serialize-bar bar))) + + ;; Keybindings. + #$@(with-heading "Keybindings." + (map serialize-keybinding + (sway-configuration-keybindings conf))) + ;; Gestures. + #$@(with-heading "Gestures." + (map serialize-gesture + (sway-configuration-gestures conf))) + + ;; Modes. + #$@(with-heading "Modes." + (flatmap serialize-mode + (sway-configuration-modes conf))) + + ;; Startup-Programs. + #$@(with-heading + "Programs to execute (at startup)." + (map (serialize-exec #f) + (sway-configuration-startup-programs conf))) + ;; startup+reload-programs. + #$@(with-heading + "Programs to execute (at startup & after reload)." + (map (serialize-exec #t) + (sway-configuration-startup+reload-programs conf))) + + ;; Extra-content. + #$@(with-heading "Extra-content" extra))))))))) + + +;;; +;;; Definition of th Home Service. +;;; + +(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 2adf196a87..003cda1259 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