* [bug#72714] [PATCH] home: services: Add 'home-sway-service-type'.
@ 2024-08-19 15:30 Arnaud Daby-Seesaram via Guix-patches via
2024-08-24 15:32 ` [bug#72714] [PATCH v2] " Arnaud Daby-Seesaram via Guix-patches via
` (3 more replies)
0 siblings, 4 replies; 9+ messages in thread
From: Arnaud Daby-Seesaram via Guix-patches via @ 2024-08-19 15:30 UTC (permalink / raw)
To: 72714; +Cc: Arnaud Daby-Seesaram
* gnu/home/services/sway.scm (home-sway-service-type): New variable.
(sway-configuration): New configuration record.
(sway-bar): New configuration record.
(sway-output): New configuration record.
(sway-input): New configuration record.
(point): New configuration record.
(sway-color): New configuration record.
(sway-border-color): New configuration record.
(flatten): New procedure.
Change-Id: Ia29a4173ce3a887d5fac3f57ba3819a52f9624d3
---
This patch provides an *experimental* home service to configure sway.
It defines a configuration record that contains fields for common
options of sway (an extra-contents field that can be used for
additional settings). The service also adds packages to the user
profile (notably sway).
Feedback is welcome !
Please note that (1) I only use Guile for Guix, so my code might be
clumsy and non-idiomatic¹ and (2) the patch is experimental, and will
need polishing before being merged. For example, I am not sure when I
should allow G-expressions in the configuration.
¹: feel free to share your opinions on
how to improve the code.
I have not written any documentation at the time (even documentation
strings in the configuration records are not well defined). I am
waiting for the code structure and configuration records to be
stable-ish to take the time to write a documentation.
gnu/home/services/sway.scm | 622 +++++++++++++++++++++++++++++++++++++
1 file changed, 622 insertions(+)
create mode 100644 gnu/home/services/sway.scm
diff --git a/gnu/home/services/sway.scm b/gnu/home/services/sway.scm
new file mode 100644
index 0000000000..3f978d0bf0
--- /dev/null
+++ b/gnu/home/services/sway.scm
@@ -0,0 +1,622 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Arnaud Daby-Seesaram <ds-ac@nanein.fr>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu home services sway)
+ #:use-module (guix monads)
+ #:use-module (guix modules)
+ #:use-module (guix gexp)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (guix packages)
+ #:use-module (gnu services configuration)
+ #:use-module (gnu home services)
+ #:use-module (gnu packages freedesktop)
+ #:use-module (gnu packages xdisorg)
+ #:use-module (gnu packages image)
+ #:use-module (gnu packages gnome)
+ #:use-module (gnu packages wm)
+ #:use-module (gnu packages emacs)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages suckless)
+ #:use-module (gnu packages glib)
+ #:export (;; Accessors and predicates do not need to be exported.
+ sway-configuration
+ sway-bar
+ sway-output
+ sway-input
+ point
+ sway-color
+ sway-border-color
+ home-sway-service-type))
+
+;; Helper function.
+(define (flatten l)
+ (let loop ((lst l) (acc '()))
+ (match lst
+ (() acc)
+ ((head . tail)
+ (loop tail (append acc head))))))
+
+\f
+;;;
+;;; 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")))
+
+\f
+;;;
+;;; Definition of configurations.
+;;;
+
+(define (list-of-string-or-gexp? lst)
+ (every (lambda (elt)
+ (or (string? elt)
+ (gexp? elt)))
+ lst))
+
+(define (list-of-packages? lst)
+ (every package? lst))
+
+(define (bar-position? p)
+ (member p '(top bottom)))
+
+(define (hidden-state? st)
+ (member st '(hide show)))
+
+(define (string-or-symbol? s)
+ (or (string? s)
+ (symbol? s)))
+
+(define (strings? lst)
+ (every string? lst))
+
+(define-maybe string (no-serialization))
+(define-maybe strings (no-serialization))
+
+(define-configuration/no-serialization sway-input
+ (identifier
+ (string-or-symbol '*)
+ "Identifier of the input.")
+ (xkb-layout
+ maybe-string
+ "Keyboard layout.")
+ (xkb-model
+ maybe-string
+ "Keyboard model.")
+ (xkb-options
+ maybe-strings
+ "Keyboard options.")
+ (xkb-variant
+ maybe-string
+ "Keyboard layout variant.")
+ (extra-content
+ (list-of-string-or-gexp '())
+ "Lines to add at the end of the configuration file."))
+
+(define (sway-inputs? lst)
+ (every sway-input? lst))
+
+(define-configuration/no-serialization sway-border-color
+ (border
+ string
+ "Border color.")
+ (background
+ string
+ "Background color.")
+ (text
+ string
+ "Text color."))
+
+(define-maybe sway-border-color (no-serialization))
+
+(define-configuration/no-serialization sway-color
+ (background
+ maybe-string
+ "Background color of the bar.")
+ (statusline
+ maybe-string
+ "Text color of the separator.")
+ (focused-background
+ maybe-string
+ "Background color of the bar on the currently focused monitor.")
+ (focused-statusline
+ maybe-string
+ "Text color of the statusline on the currently focused monitor.")
+ (focused-workspace
+ maybe-sway-border-color
+ "...")
+ (active-workspace
+ maybe-sway-border-color
+ "...")
+ (inactive-workspace
+ maybe-sway-border-color
+ "...")
+ (urgent-workspace
+ maybe-sway-border-color
+ "...")
+ (binding-mode
+ maybe-sway-border-color
+ "..."))
+
+(define-maybe sway-color (no-serialization))
+
+(define-configuration/no-serialization sway-bar
+ (identifier
+ (symbol 'bar0)
+ "Identifier of the bar.")
+ (position
+ (bar-position 'top)
+ "Position of the bar.")
+ (hidden-state
+ (hidden-state 'hide)
+ "Hidden state.")
+ (binding-mode-indicator
+ (boolean #t)
+ "Binding indicator.")
+ (colors
+ maybe-sway-color
+ "Color palette of the bar.")
+ (status-command
+ (file-like
+ (program-file
+ "sway-bar-status"
+ (with-imported-modules
+ (source-module-closure
+ '((ice-9 textual-ports) (ice-9 regex) (ice-9 popen) (ice-9 format)
+ (srfi srfi-19)))
+ #~(begin
+ (use-modules (ice-9 textual-ports)
+ (ice-9 format)
+ (ice-9 popen)
+ (ice-9 regex)
+ (srfi srfi-19))
+ (let loop ()
+ (let* ((date (date->string (current-date) "~a ~D ~H:~M:~S"))
+ (batline (let* ((p (open-pipe*
+ OPEN_READ
+ #$(file-append acpi "/bin/acpi") "-b"))
+ (bat (get-line p)))
+ (close-pipe p)
+ bat))
+ (bat (match:substring (string-match "[0-9]+%" batline))))
+ (format #t "~a - ~a~%~!" bat date)
+ (sleep 1)
+ (loop)))))))
+ "Status command. It must be file-like."))
+
+(define-configuration/no-serialization point
+ (x integer "X coordinate.")
+ (y integer "Y coordinate."))
+
+(define-maybe point (no-serialization))
+(define-maybe file-like (no-serialization))
+
+(define-configuration/no-serialization sway-output
+ (identifier
+ (string-or-symbol '*)
+ "Identifier of the output.")
+ (resolution
+ maybe-string
+ "Mode of the monitor.")
+ (position
+ maybe-point
+ "Position of the monitor.")
+ (bg
+ maybe-file-like
+ "Background image.")
+ (extra-content
+ (list-of-string-or-gexp '())
+ "Extra lines."))
+
+(define (sway-outputs? lst)
+ (every sway-output? lst))
+
+(define-configuration/no-serialization sway-configuration
+ (keybindings
+ (alist %sway-default-keybindings)
+ "Keybindings.")
+ (gestures
+ (alist %sway-default-gestures)
+ "Gestures.")
+ (packages
+ (list-of-packages
+ (list sway swaylock waybar swaybg slurp grim dmenu bemenu
+ dbus xdg-desktop-portal-wlr xdg-desktop-portal))
+ "List of packages to add to the profile.")
+ (variables
+ (alist %sway-default-variables)
+ "Variables declared at the beginning of the file.")
+ (inputs
+ (sway-inputs (list (sway-input)))
+ "Inputs.")
+ (outputs
+ (sway-outputs '())
+ "Outputs.")
+ (bar
+ (sway-bar (sway-bar))
+ "Bar configuration.")
+ (execs
+ (list-of-string-or-gexp '())
+ "Programs to execute at startup time.")
+ (extra-content
+ (list-of-string-or-gexp '())
+ "Lines to add at the end of the configuration file."))
+
+\f
+;;;
+;;; Serialization functions.
+;;;
+
+(define (serialize-keybinding var)
+ (let ((name (symbol->string (car var)))
+ (value (cdr var)))
+ #~(string-append "bindsym " #$name " " #$value)))
+
+(define (serialize-gesture var)
+ (let ((name (symbol->string (car var)))
+ (value (cdr var)))
+ #~(string-append "bindgesture " #$name " " #$value)))
+
+(define (serialize-variable var)
+ (let ((name (symbol->string (car var)))
+ (value (cdr var)))
+ #~(string-append "set $" #$name " " #$value)))
+
+(define (serialize-exec exe)
+ #~(string-append "exec " #$exe))
+
+(define (serialize-output out)
+ (let* ((pre-ident (sway-output-identifier out))
+ (ident (if (symbol? pre-ident)
+ (symbol->string pre-ident)
+ (string-append "\"" pre-ident "\"")))
+ (bg (sway-output-bg out))
+ (resolution (sway-output-resolution out))
+ (position (sway-output-position out))
+ (extra-content (sway-output-extra-content out)))
+ (append
+ (filter
+ (lambda (elt) (not (eq? elt %unset-value)))
+ (list
+ ;; Beginning of the block.
+ #~(string-append "output " #$ident " {")
+ ;; Optional elements.
+ (if (eq? %unset-value bg)
+ %unset-value
+ #~(string-append " bg " #$bg " fill"))
+ (if (eq? %unset-value resolution)
+ %unset-value
+ (string-append " resolution " resolution))
+ (if (eq? %unset-value position)
+ %unset-value
+ (string-append " position " (number->string (point-x position))
+ " " (number->string (point-y position))))))
+ extra-content
+ ;; End of the block.
+ '("}"))))
+
+(define-inlinable (add-line-if prefix value)
+ (if (eq? %unset-value value)
+ %unset-value
+ (string-append prefix " " value)))
+
+(define (serialize-input input)
+ (let* ((pre-ident (sway-input-identifier input))
+ (ident (if (symbol? pre-ident)
+ (symbol->string pre-ident)
+ (string-append "\"" pre-ident "\"")))
+ (xkb-layout (sway-input-xkb-layout input))
+ (xkb-model (sway-input-xkb-model input))
+ (xkb-variant (sway-input-xkb-variant input))
+ (xkb-options (sway-input-xkb-options input)))
+ (append
+ (filter
+ (lambda (elt) (not (eq? elt %unset-value)))
+ (list
+ (string-append "input " ident " {")
+ ;; Optional.
+ (add-line-if " xkb_layout" xkb-layout)
+ (add-line-if " xkb_model" xkb-model)
+ (add-line-if " xkb_variant" xkb-variant)
+ (if (eq? %unset-value xkb-options)
+ %unset-value
+ (string-concatenate (cons " xkb_options " xkb-options)))))
+ (map (lambda (s)
+ (string-append (string-pad "" 4) s))
+ (sway-input-extra-content input))
+ '("}"))))
+
+(define (serialize-colors colors)
+ (define (add-border-color-if name val)
+ (if (eq? %unset-value val)
+ %unset-value
+ (string-append
+ name
+ " " (sway-border-color-border val)
+ " " (sway-border-color-background val)
+ " " (sway-border-color-text val))))
+ (let ((background (sway-color-background colors))
+ (statusline (sway-color-statusline colors))
+ (focused-background (sway-color-focused-background colors))
+ (focused-statusline (sway-color-focused-statusline colors))
+ (focused-workspace (sway-color-focused-workspace colors))
+ (active-workspace (sway-color-active-workspace colors))
+ (inactive-workspace (sway-color-inactive-workspace colors))
+ (urgent-workspace (sway-color-urgent-workspace colors))
+ (binding-mode (sway-color-binding-mode colors)))
+ (filter
+ (lambda (elt) (not (eq? elt %unset-value)))
+ (list
+ (add-line-if "background" background)
+ (add-line-if "statusline" statusline)
+ (add-line-if "focused_background" focused-background)
+ (add-line-if "focused_statusline" focused-statusline)
+ (add-border-color-if "focused_workspace" focused-workspace)
+ (add-border-color-if "active_workspace" active-workspace)
+ (add-border-color-if "inactive_workspace" inactive-workspace)
+ (add-border-color-if "urgent_workspace" urgent-workspace)
+ (add-border-color-if "binding_mode" binding-mode)))))
+
+(define (make-sway-config conf)
+ (let* ((extra (sway-configuration-extra-content conf))
+ (bar (sway-configuration-bar conf)))
+
+ (with-imported-modules
+ (source-module-closure
+ '((ice-9 popen) (ice-9 match) (ice-9 format) (guix monads)))
+ (computed-file
+ "sway-config"
+ #~(begin
+ (use-modules (ice-9 format) (ice-9 popen) (ice-9 match)
+ (guix monads))
+ ;; Helper functions to pretty-print the configuration file.
+ (define (line s)
+ (lambda (port)
+ (lambda (i)
+ (format port "~a~a~%" (string-pad "" i) s)
+ (values port i))))
+ (define (lines lst)
+ (lambda (port)
+ (lambda (i)
+ (let loop ((l lst))
+ (match l
+ (() #t)
+ ((head . tail)
+ (format port "~a~a~%" (string-pad "" i)
+ (if (list? head)
+ (string-concatenate head)
+ head))
+ (loop tail))))
+ (values port i))))
+ (define-syntax line*
+ (syntax-rules ()
+ ((line* elt ...)
+ (lines (list elt ...)))))
+ (define-syntax line2
+ (syntax-rules ()
+ ((line2 a b)
+ (line (string-append a b)))))
+ (define (indent k)
+ (lambda (port)
+ (lambda (i)
+ (values port (+ i k)))))
+ (define (begin-block name)
+ (lambda (port)
+ (lambda (i)
+ (format port "~a~a {~%" (string-pad "" i) name)
+ (values port (+ i 4)))))
+ (define (end-block)
+ (lambda (port)
+ (lambda (i)
+ (let ((i (- i 4)))
+ (format port "~a}~%" (string-pad "" i))
+ (values port i)))))
+
+ (let* ((file #$output)
+ (port (open-output-file #$output)))
+ ;; The previous iteration of this work computed the content of the
+ ;; configuration file as a string. The state monad was used to
+ ;; keep track of the state during the computation.
+ ;; However, this first approach was too expensive. Now that I use
+ ;; `computed-file', the "computed value" is the constant port to
+ ;; which I write. Thus, using the state monad is overkill here.
+ ;; It can be replaced by the identity monad, where the value being
+ ;; passed around is the pair of `port' and the indentation level.
+ (run-with-state
+ (with-monad
+ %state-monad
+ (>>= (return port)
+ ;; Header of the configuration file.
+ (line*
+ "#####################################"
+ "### Auto-generated configuration. ###"
+ "#####################################"
+ "# DO NOT EDIT MANUALLY." "")
+ (line*
+ "# Variables."
+ "# =========="
+ #$@(map serialize-variable
+ (sway-configuration-variables conf)) "")
+ (line*
+ "# Outputs."
+ "# ========"
+ #$@(flatten
+ (map serialize-output
+ (sway-configuration-outputs conf))) "")
+ (line*
+ "# Inputs."
+ "# ======="
+ #$@(flatten
+ (map serialize-input
+ (sway-configuration-inputs conf))) "")
+ (line* "# Bar configuration."
+ "# ==================")
+ (begin-block
+ (string-append
+ "bar " #$(symbol->string
+ (sway-bar-identifier bar))))
+ (line2 "position " #$(symbol->string
+ (sway-bar-position bar)))
+ (line2 "hidden_state "
+ #$(symbol->string
+ (sway-bar-hidden-state bar)))
+ (line2 "status_command "
+ #$(sway-bar-status-command bar))
+ (line2 "binding_mode_indicator "
+ #$(if (sway-bar-binding-mode-indicator bar)
+ "true" "false"))
+ (begin-block "colors")
+ (line*
+ #$@(serialize-colors (sway-bar-colors bar)))
+ (end-block) ;; colors
+ (end-block) ;; bar
+ (line*
+ "" "# Extra configuration content."
+ "# ============================"
+ #$@extra "")
+ (line*
+ "# Keybindings."
+ "# ============"
+ #$@(map serialize-keybinding
+ (sway-configuration-keybindings conf))
+ "")
+ (line*
+ "# Gestures."
+ "# ========="
+ #$@(map serialize-gesture
+ (sway-configuration-gestures conf)) "")
+ (line*
+ "# Programs to execute."
+ "# ===================="
+ #$@(map serialize-exec
+ (sway-configuration-execs conf)))))
+ 0)))))))
+
+(define (sway-configuration->file sway-conf)
+ `((".config/sway/config"
+ ,(make-sway-config
+ sway-conf))))
+
+(define home-sway-service-type
+ (service-type
+ (name 'home-sway-config)
+ (extensions
+ (list (service-extension home-files-service-type
+ sway-configuration->file)
+ (service-extension home-profile-service-type
+ sway-configuration-packages)))
+ (description "Configure Sway by providing a file
+@file{~/.config/sway/config}.")
+ (default-value (sway-configuration))))
base-commit: d3832de763777759eb1f56e20731cb39da4c7b5b
--
2.45.2
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [bug#72714] [PATCH v2] home: services: Add 'home-sway-service-type'.
2024-08-19 15:30 [bug#72714] [PATCH] home: services: Add 'home-sway-service-type' Arnaud Daby-Seesaram via Guix-patches via
@ 2024-08-24 15:32 ` Arnaud Daby-Seesaram via Guix-patches via
2024-08-26 10:38 ` [bug#72714] [PATCH v3] " Arnaud Daby-Seesaram via Guix-patches via
` (2 subsequent siblings)
3 siblings, 0 replies; 9+ messages in thread
From: Arnaud Daby-Seesaram via Guix-patches via @ 2024-08-24 15:32 UTC (permalink / raw)
To: 72714; +Cc: Arnaud Daby-Seesaram
* 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
---
This V2 slightly improves my code and adds a TeXinfo documentation. (I also
modified local.mk, which I forgot last time).
doc/guix.texi | 255 +++++++++++++++
gnu/home/services/sway.scm | 630 +++++++++++++++++++++++++++++++++++++
gnu/local.mk | 1 +
3 files changed, 886 insertions(+)
create mode 100644 gnu/home/services/sway.scm
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..dc399015ed
--- /dev/null
+++ b/gnu/home/services/sway.scm
@@ -0,0 +1,630 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Arnaud Daby-Seesaram <ds-ac@nanein.fr>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu home services sway)
+ #:use-module (guix monads)
+ #:use-module (guix modules)
+ #:use-module (guix gexp)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (guix packages)
+ #:use-module (gnu services configuration)
+ #:use-module (gnu home services)
+ #:use-module (gnu packages freedesktop)
+ #:use-module (gnu packages xdisorg)
+ #:use-module (gnu packages image)
+ #:use-module (gnu packages gnome)
+ #:use-module (gnu packages wm)
+ #:use-module (gnu packages emacs)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages suckless)
+ #:use-module (gnu packages glib)
+ #:export (;; Accessors and predicates do not need to be exported.
+ sway-configuration
+ sway-bar
+ sway-output
+ sway-input
+ point
+ sway-color
+ sway-border-color
+ home-sway-service-type
+ 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))))))
+
+\f
+;;;
+;;; 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)))))))
+
+\f
+;;;
+;;; 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."))
+
+\f
+;;;
+;;; 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))))
+ (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 \
base-commit: f10cbebd7b6cfeb66e91851616fdc75f9a0bbe69
--
2.45.2
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [bug#72714] [PATCH v3] home: services: Add 'home-sway-service-type'.
2024-08-19 15:30 [bug#72714] [PATCH] home: services: Add 'home-sway-service-type' Arnaud Daby-Seesaram via Guix-patches via
2024-08-24 15:32 ` [bug#72714] [PATCH v2] " Arnaud Daby-Seesaram via Guix-patches via
@ 2024-08-26 10:38 ` Arnaud Daby-Seesaram via Guix-patches via
2024-09-03 7:27 ` [bug#72714] [PATCH v4] " Arnaud Daby-Seesaram via Guix-patches via
2024-09-18 8:15 ` [bug#72714] [PATCH v5] " Arnaud Daby-Seesaram via Guix-patches via
3 siblings, 0 replies; 9+ messages in thread
From: Arnaud Daby-Seesaram via Guix-patches via @ 2024-08-26 10:38 UTC (permalink / raw)
To: 72714; +Cc: Arnaud Daby-Seesaram
* 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
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 <ds-ac@nanein.fr>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu home services sway)
+ #:use-module (guix monads)
+ #:use-module (guix modules)
+ #:use-module (guix gexp)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (guix packages)
+ #:use-module (gnu services configuration)
+ #:use-module (gnu home services)
+ #:use-module (gnu packages freedesktop)
+ #:use-module (gnu packages xdisorg)
+ #:use-module (gnu packages image)
+ #:use-module (gnu packages gnome)
+ #:use-module (gnu packages wm)
+ #:use-module (gnu packages emacs)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages suckless)
+ #:use-module (gnu packages glib)
+ #:export (;; Accessors and predicates do not need to be exported.
+ sway-configuration
+ sway-bar
+ sway-output
+ sway-input
+ point
+ sway-color
+ sway-border-color
+ home-sway-service-type
+ 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))))))
+
+\f
+;;;
+;;; 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)))))))
+
+\f
+;;;
+;;; 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."))
+
+\f
+;;;
+;;; 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 \
base-commit: f10cbebd7b6cfeb66e91851616fdc75f9a0bbe69
--
2.45.2
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [bug#72714] [PATCH v4] home: services: Add 'home-sway-service-type'.
2024-08-19 15:30 [bug#72714] [PATCH] home: services: Add 'home-sway-service-type' Arnaud Daby-Seesaram via Guix-patches via
2024-08-24 15:32 ` [bug#72714] [PATCH v2] " Arnaud Daby-Seesaram via Guix-patches via
2024-08-26 10:38 ` [bug#72714] [PATCH v3] " Arnaud Daby-Seesaram via Guix-patches via
@ 2024-09-03 7:27 ` Arnaud Daby-Seesaram via Guix-patches via
2024-09-14 13:28 ` pelzflorian (Florian Pelz)
2024-09-18 8:15 ` [bug#72714] [PATCH v5] " Arnaud Daby-Seesaram via Guix-patches via
3 siblings, 1 reply; 9+ messages in thread
From: Arnaud Daby-Seesaram via Guix-patches via @ 2024-09-03 7:27 UTC (permalink / raw)
To: 72714; +Cc: Arnaud Daby-Seesaram
* 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.
---
This version is rebased on master and brings default values closer to those of
the default sway configuration (e.g. the status command).
doc/guix.texi | 271 ++++++++++++++
gnu/home/services/sway.scm | 703 +++++++++++++++++++++++++++++++++++++
gnu/local.mk | 1 +
3 files changed, 975 insertions(+)
create mode 100644 gnu/home/services/sway.scm
diff --git a/doc/guix.texi b/doc/guix.texi
index 144adf327e..8e17643b7f 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.
@@ -45175,6 +45177,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
@@ -47089,6 +47092,274 @@ kodi} for more information.
@end table
@end deftp
+@node Sway window manager
+@subsection Sway window manager
+
+@cindex sway, configuration
+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 or G-expressions (@pxref{G-Expressions}).
+
+Example: @code{'(mod . "Mod4")}.
+
+@item @code{keybindings} (default: @code{%sway-default-keybindings})
+This field describes keybindings for the @emph{default} mode. As above,
+the value is an association list: keys are symbols and values are either
+strings or G-expressions.
+
+@c @example
+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
+@c @end example
+
+@item @code{gestures} (default: @code{%sway-default-gestures})
+Similar to the previous field, but for finger-gestures.
+
+@c @example
+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
+@c @end example
+
+@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{%sway-default-execs})
+Programs to execute at startup time. The value of this field is a list
+of strings or G-expressions.
+
+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 of the screen 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)}). 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 strings and executable file-like values. The default
+value is a script that prints the 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..bfec0fcdcf
--- /dev/null
+++ b/gnu/home/services/sway.scm
@@ -0,0 +1,703 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Arnaud Daby-Seesaram <ds-ac@nanein.fr>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu home services sway)
+ #:use-module (guix monads)
+ #:use-module (guix modules)
+ #:use-module (guix gexp)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (guix packages)
+ #:use-module (gnu services configuration)
+ #:use-module (gnu home services)
+ #:use-module (gnu packages freedesktop)
+ #:use-module (gnu packages xdisorg)
+ #:use-module (gnu packages image)
+ #:use-module (gnu packages gnome)
+ #:use-module (gnu packages wm)
+ #:use-module (gnu packages emacs)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages suckless)
+ #:use-module (gnu packages glib)
+ #:export (;; 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-execs))
+
+;; Helper function.
+(define (flatten l)
+ (let loop ((lst (reverse l)) (acc '()))
+ (match lst
+ (() acc)
+ ((head . tail)
+ (loop tail (append head acc))))))
+
+\f
+;;;
+;;; 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-variables
+ `((mod . "Mod4")
+ (left . "h")
+ (down . "j")
+ (up . "k")
+ (right . "l")
+ (term . ,#~(string-append #$st "/bin/st"))
+ (menu . ,#~(string-append
+ #$dmenu "/bin/dmenu_path | "
+ #$wmenu "/bin/wmenu | "
+ #$findutils "/bin/xargs "
+ #$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 'You pressed the exit "
+ "shortcut. Do you really want to exit sway? This will end your "
+ "Wayland session.' -B 'Yes, exit sway' '"
+ #$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-execs
+ (list
+ #~(string-append
+ #$swayidle "/bin/swayidle -w \\\n"
+ ;; 300: lock screen.
+ " timeout 300 '" #$swaylock "/bin/swaylock "
+ "--indicator-radius 75 "
+ "-i " #$sway "/share/backgrounds/sway/Sway_Wallpaper_Blue_1920x1080.png"
+ " -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'")))
+
+\f
+;;;
+;;; 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 (make-alist-predicate key? val?)
+ (lambda (lst)
+ (every
+ (lambda (item)
+ (match item
+ ((k . v)
+ (and (key? k)
+ (val? v)))
+ (_ #f)))
+ lst)))
+
+(define (string-or-gexp? s)
+ (or (string? s)
+ (gexp? s)))
+
+(define bindings?
+ (make-alist-predicate symbol? string-or-gexp?))
+(define mouse-bindings?
+ (make-alist-predicate integer? string-or-gexp?))
+
+(define (file-like-or-string? f)
+ (or (file-like? f)
+ (string? f)))
+
+(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-or-string %sway-default-status-command)
+ "Status command. It must be file-like.")
+ (keybindings
+ (bindings '())
+ "Keybindings.")
+ (mouse-bindings
+ (mouse-bindings '())
+ "Actions triggered by mouse events.")
+ (extra-content
+ (list-of-string-or-gexp '())
+ "Extra configuration lines."))
+
+(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-mode
+ (mode-name
+ (string "default")
+ "Name of the mode.")
+ (keybindings
+ (bindings '())
+ "Keybindings.")
+ (mouse-bindings
+ (mouse-bindings '())
+ "Mouse bindings."))
+;; TODO: 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
+ (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.")
+ (modes
+ (sway-modes '())
+ "Additional modes.")
+ (always-execs
+ (list-of-string-or-gexp '())
+ "Programs to execute at startup time.")
+ (execs
+ (list-of-string-or-gexp %sway-default-execs)
+ "Programs to execute at startup time.")
+ (extra-content
+ (list-of-string-or-gexp '())
+ "Lines to add at the end of the configuration file."))
+
+\f
+;;;
+;;; Serialization functions.
+;;;
+
+(define (serialize-mouse-binding var)
+ (let ((ev-code (number->string (car var)))
+ (command (cdr var)))
+ #~(string-append "bindcode " #$ev-code " " #$command)))
+
+(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 (serialize-sway-mode mode)
+ (let ((name (sway-mode-mode-name mode))
+ (keys (sway-mode-keybindings mode))
+ (clicks (sway-mode-mouse-bindings mode))
+ (serialize-keybinding
+ (lambda (kbd)
+ #~(string-append " " #$(serialize-keybinding kbd))))
+ (serialize-mouse-binding
+ (lambda (kbd)
+ #~(string-append " " #$(serialize-mouse-binding kbd)))))
+ (append
+ (list (string-append "mode \"" name "\" {"))
+ (map serialize-keybinding keys)
+ (map serialize-mouse-binding clicks)
+ '("}"))))
+
+(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
+ (line*
+ #$@(map serialize-keybinding (sway-bar-keybindings bar)))
+ (line*
+ #$@(map serialize-mouse-binding (sway-bar-mouse-bindings bar)))
+ (line*
+ #$@(sway-bar-extra-content bar))
+ (end-block) ;; bar
+ (line*
+ "" "# Modes." "# ======"
+ #$@(flatten
+ (map serialize-sway-mode
+ (sway-configuration-modes conf))))
+ (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 0c4ab96bf3..225e2d5502 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.45.2
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [bug#72714] [PATCH v4] home: services: Add 'home-sway-service-type'.
2024-09-03 7:27 ` [bug#72714] [PATCH v4] " Arnaud Daby-Seesaram via Guix-patches via
@ 2024-09-14 13:28 ` pelzflorian (Florian Pelz)
2024-09-14 14:06 ` pelzflorian (Florian Pelz)
2024-09-17 6:52 ` Arnaud Daby-Seesaram via Guix-patches via
0 siblings, 2 replies; 9+ messages in thread
From: pelzflorian (Florian Pelz) @ 2024-09-14 13:28 UTC (permalink / raw)
To: Arnaud Daby-Seesaram; +Cc: 72714
Thank you Arnaud for this well-written home-sway-service!
Some comments for you or the one who pushes your patch. I would
rather not take any responsibility for sway myself.
> @quotation Note
> This home service only sets up configuration file and profile packages
Typo: Please add 'the': sets up the configuration file and profile packages
> 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}.
Good. Even though it is a little strange that one would add a home
module (gnu home services sway) to the operating-system configuration,
I know no better place for this `sway-configuration->file' procedure,
since the record is for Guix Home and being able to use it for greetd
is just an extra feature.
> @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
Why not (bg #~(file-append #$guix-backgrounds
"\
/share/backgrounds/guix/guix-checkered-16-9.svg"))
? This does not work right now, but could you change bg and
perhaps status-command to accept gexps?
> swiping down (resp.@ up) with three fingers moves the active window to
> the scratchpad (resp.@ shows/hides the scratchpad).
Should be with a colon: resp.@: up
You should run untabify on all of gnu/home/services/sway.scm
to get rid of nasty tabs.
Otherwise looks really good to me (although I have not cross-checked
the man pages).
Regards,
Florian
^ permalink raw reply [flat|nested] 9+ messages in thread
* [bug#72714] [PATCH v4] home: services: Add 'home-sway-service-type'.
2024-09-14 13:28 ` pelzflorian (Florian Pelz)
@ 2024-09-14 14:06 ` pelzflorian (Florian Pelz)
2024-09-17 6:52 ` Arnaud Daby-Seesaram via Guix-patches via
1 sibling, 0 replies; 9+ messages in thread
From: pelzflorian (Florian Pelz) @ 2024-09-14 14:06 UTC (permalink / raw)
To: Arnaud Daby-Seesaram; +Cc: 72714
One more thing,
> (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)))))
this does not put a comma between each element of xkb-options.
Could you make it join the xkb-options with a comma in between?
Regards,
Florian
^ permalink raw reply [flat|nested] 9+ messages in thread
* [bug#72714] [PATCH v4] home: services: Add 'home-sway-service-type'.
2024-09-14 13:28 ` pelzflorian (Florian Pelz)
2024-09-14 14:06 ` pelzflorian (Florian Pelz)
@ 2024-09-17 6:52 ` Arnaud Daby-Seesaram via Guix-patches via
1 sibling, 0 replies; 9+ messages in thread
From: Arnaud Daby-Seesaram via Guix-patches via @ 2024-09-17 6:52 UTC (permalink / raw)
To: pelzflorian (Florian Pelz); +Cc: 72714
[-- Attachment #1: Type: text/plain, Size: 868 bytes --]
Hi Florian,
Thank you for your review. I will submit a v5 soon to take your remarks
into account and add an additional configuration field (to easily add
modes, e.g. the resize mode).
>> 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}.
>
> Good. Even though it is a little strange that one would add a home
> module (gnu home services sway) to the operating-system configuration,
> I know no better place for this `sway-configuration->file' procedure,
> since the record is for Guix Home and being able to use it for greetd
> is just an extra feature.
Yes, I agree; I could not find a better place for this function either.
Do you think that this note is helpful, or should I remove it?
Best regards,
--
Arnaud
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 857 bytes --]
^ permalink raw reply [flat|nested] 9+ messages in thread
* [bug#72714] [PATCH v5] home: services: Add 'home-sway-service-type'.
2024-08-19 15:30 [bug#72714] [PATCH] home: services: Add 'home-sway-service-type' Arnaud Daby-Seesaram via Guix-patches via
` (2 preceding siblings ...)
2024-09-03 7:27 ` [bug#72714] [PATCH v4] " Arnaud Daby-Seesaram via Guix-patches via
@ 2024-09-18 8:15 ` Arnaud Daby-Seesaram via Guix-patches via
2024-09-18 18:56 ` Arnaud Daby-Seesaram via Guix-patches via
3 siblings, 1 reply; 9+ messages in thread
From: Arnaud Daby-Seesaram via Guix-patches via @ 2024-09-18 8:15 UTC (permalink / raw)
To: 72714; +Cc: Arnaud Daby-Seesaram
* 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.
---
doc/guix.texi | 329 +++++++++++++++++
gnu/home/services/sway.scm | 711 +++++++++++++++++++++++++++++++++++++
gnu/local.mk | 1 +
3 files changed, 1041 insertions(+)
create mode 100644 gnu/home/services/sway.scm
diff --git a/doc/guix.texi b/doc/guix.texi
index bdaefe3802..07598a2a7e 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.
@@ -45190,6 +45192,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
@@ -47104,6 +47107,332 @@ 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 sway in a
+declarative way.
+
+@quotation Note
+This home service only sets up the 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
+(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 guix-backgrounds
+ "\
+/share/backgrounds/guix/guix-checkered-16-9.svg")))))))
+@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 or G-expressions (@pxref{G-Expressions}).
+
+Example: @code{'(mod . "Mod4")}.
+
+@item @code{keybindings} (default: @code{%sway-default-keybindings})
+This field describes keybindings for the @emph{default} mode. As above,
+the value is an association list: keys are symbols and values are either
+strings, G-expressions or file-append objects.
+
+Examples using:
+@itemize
+@item
+a string: @code{'($mod+Return . "exec $term")}
+@item
+a G-exp: @code{`($mod+t . ,#~(string-append #$st "/bin/st"))}
+@item
+a file-append: @code{`($mod+t . ,(file-append st "/bin/st"))}
+@end itemize
+
+@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.
+
+@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{modes} (default: @code{'()})
+Optional list of @code{sway-mode} records (described below).
+
+@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{%sway-default-execs})
+Programs to execute at startup time. The value of this field is a list
+of strings or G-expressions.
+
+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 of the screen 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)}). 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.
+@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 @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 separator.
+@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})
+Colour scheme for active workspaces.
+@item @code{inactive-workspace} (optional @code{sway-border-color})
+Colour scheme for inactive workspaces.
+@item @code{urgent-workspace} (optional @code{sway-border-color})
+Colour scheme for workspaces containing `urgent' windows.
+@item @code{binding-mode} (optional @code{sway-border-color})
+Colour 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 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 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"
+ (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 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
+@end table
+@end deftp
+
+@deftp {Data Type} sway-mode
+Describes a Sway mode.
+
+Here is 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.
+@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.
+@item @code{mouse-bindings} (default @code{'()})
+Ditto, but keys are mouse events.
+@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..7d665e7280
--- /dev/null
+++ b/gnu/home/services/sway.scm
@@ -0,0 +1,711 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Arnaud Daby-Seesaram <ds-ac@nanein.fr>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu home services sway)
+ #:use-module (guix monads)
+ #:use-module (guix modules)
+ #:use-module (guix gexp)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (guix packages)
+ #:use-module (gnu services configuration)
+ #:use-module (gnu home services)
+ #:use-module (gnu packages freedesktop)
+ #:use-module (gnu packages xdisorg)
+ #:use-module (gnu packages image)
+ #:use-module (gnu packages gnome)
+ #:use-module (gnu packages wm)
+ #:use-module (gnu packages emacs)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages suckless)
+ #:use-module (gnu packages glib)
+ #:export (;; 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-execs))
+
+;; Helper function.
+(define (flatten l)
+ (let loop ((lst (reverse l)) (acc '()))
+ (match lst
+ (() acc)
+ ((head . tail)
+ (loop tail (append head acc))))))
+
+\f
+;;;
+;;; 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-variables
+ `((mod . "Mod4")
+ (left . "h")
+ (down . "j")
+ (up . "k")
+ (right . "l")
+ (term . ,(file-append st "/bin/st"))
+ (menu . ,#~(string-append
+ #$dmenu "/bin/dmenu_path | "
+ #$wmenu "/bin/wmenu | "
+ #$findutils "/bin/xargs "
+ #$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 'You pressed the exit "
+ "shortcut. Do you really want to exit sway? This will end your "
+ "Wayland session.' -B 'Yes, exit sway' '"
+ #$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-execs
+ (list
+ #~(string-append
+ #$swayidle "/bin/swayidle -w \\\n"
+ ;; 300: lock screen.
+ " timeout 300 '" #$swaylock "/bin/swaylock "
+ "--indicator-radius 75 "
+ "-i " #$sway "/share/backgrounds/sway/Sway_Wallpaper_Blue_1920x1080.png"
+ " -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'")))
+
+\f
+;;;
+;;; Definition of configurations.
+;;;
+
+(define (string-ish? s)
+ (or (gexp? s)
+ (file-append? 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 (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-ish?))
+
+(define mouse-bindings?
+ (make-alist-predicate integer? string-ish?))
+
+(define (variables? lst)
+ (make-alist-predicate symbol? string-ish?))
+
+(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
+ (strings '())
+ "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
+ "Colour scheme for focused workspaces.")
+ (active-workspace
+ maybe-sway-border-color
+ "Colour scheme for active workspaces.")
+ (inactive-workspace
+ maybe-sway-border-color
+ "Colour scheme for inactive workspaces.")
+ (urgent-workspace
+ maybe-sway-border-color
+ "Colour scheme for workspaces containing `urgent' windows.")
+ (binding-mode
+ maybe-sway-border-color
+ "Colour 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-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
+ (status-command %sway-default-status-command)
+ "Status command. It must be file-like.")
+ (keybindings
+ (bindings '())
+ "Keybindings.")
+ (mouse-bindings
+ (mouse-bindings '())
+ "Actions triggered by mouse events.")
+ (extra-content
+ (list-of-string-ish '())
+ "Extra configuration lines."))
+
+(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-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-or-gexp
+ "Background image.")
+ (extra-content
+ (list-of-string-ish '())
+ "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: 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
+ (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
+ (variables %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.")
+ (modes
+ (sway-modes '())
+ "Additional modes.")
+ (always-execs
+ (list-of-string-ish '())
+ "Programs to execute at startup time.")
+ (execs
+ (list-of-string-ish %sway-default-execs)
+ "Programs to execute at startup time.")
+ (extra-content
+ (list-of-string-ish '())
+ "Lines to add at the end of the configuration file."))
+
+\f
+;;;
+;;; Serialization functions.
+;;;
+
+(define (serialize-mouse-binding var)
+ (let ((ev-code (number->string (car var)))
+ (command (cdr var)))
+ #~(string-append "bindcode " #$ev-code " " #$command)))
+
+(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))))))
+ (map
+ (lambda (s)
+ #~(string-append " " #$s))
+ 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-append " xkb_options "
+ (string-join 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 (serialize-sway-mode mode)
+ (let ((name (sway-mode-mode-name mode))
+ (keys (sway-mode-keybindings mode))
+ (clicks (sway-mode-mouse-bindings mode))
+ (serialize-keybinding
+ (lambda (kbd)
+ #~(string-append " " #$(serialize-keybinding kbd))))
+ (serialize-mouse-binding
+ (lambda (kbd)
+ #~(string-append " " #$(serialize-mouse-binding kbd)))))
+ (append
+ (list (string-append "mode \"" name "\" {"))
+ (map serialize-keybinding keys)
+ (map serialize-mouse-binding clicks)
+ '("}"))))
+
+(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
+ (line*
+ #$@(map serialize-keybinding
+ (sway-bar-keybindings bar)))
+ (line*
+ #$@(map serialize-mouse-binding
+ (sway-bar-mouse-bindings bar)))
+ (line*
+ #$@(sway-bar-extra-content bar))
+ (end-block) ;; bar
+ (line*
+ "" "# Modes." "# ======"
+ #$@(flatten
+ (map serialize-sway-mode
+ (sway-configuration-modes conf))))
+ (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 fcdf174099..fc877ebfaf 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
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [bug#72714] [PATCH v5] home: services: Add 'home-sway-service-type'.
2024-09-18 8:15 ` [bug#72714] [PATCH v5] " Arnaud Daby-Seesaram via Guix-patches via
@ 2024-09-18 18:56 ` Arnaud Daby-Seesaram via Guix-patches via
0 siblings, 0 replies; 9+ messages in thread
From: Arnaud Daby-Seesaram via Guix-patches via @ 2024-09-18 18:56 UTC (permalink / raw)
To: 72714
[-- Attachment #1: Type: text/plain, Size: 157 bytes --]
Apologies for the noise.
I just realised that I forgot one line in the commit message:
(sway-mode): New configuration record.
Best,
--
Arnaud
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 857 bytes --]
^ permalink raw reply [flat|nested] 9+ messages in thread
end of thread, other threads:[~2024-09-18 18:58 UTC | newest]
Thread overview: 9+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-08-19 15:30 [bug#72714] [PATCH] home: services: Add 'home-sway-service-type' Arnaud Daby-Seesaram via Guix-patches via
2024-08-24 15:32 ` [bug#72714] [PATCH v2] " Arnaud Daby-Seesaram via Guix-patches via
2024-08-26 10:38 ` [bug#72714] [PATCH v3] " Arnaud Daby-Seesaram via Guix-patches via
2024-09-03 7:27 ` [bug#72714] [PATCH v4] " Arnaud Daby-Seesaram via Guix-patches via
2024-09-14 13:28 ` pelzflorian (Florian Pelz)
2024-09-14 14:06 ` pelzflorian (Florian Pelz)
2024-09-17 6:52 ` Arnaud Daby-Seesaram via Guix-patches via
2024-09-18 8:15 ` [bug#72714] [PATCH v5] " Arnaud Daby-Seesaram via Guix-patches via
2024-09-18 18:56 ` Arnaud Daby-Seesaram via Guix-patches via
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.