(address . guix-patches@gnu.org)(name . Arnaud Daby-Seesaram)(address . ds-ac@nanein.fr)
1e82e473639f21a2950a0827f156437ef1bc9c48.1724081442.git.ds-ac@nanein.fr
* 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
Toggle diff (543 lines)
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))))))
+
+
+;;;
+;;; Default settings.
+;;;
+
+(define %sway-default-variables
+ `((mod . "Mod4")
+ (left . "h")
+ (down . "j")
+ (up . "k")
+ (right . "l")
+ (term . ,#~(string-append #$st "/bin/st"))
+ (menu . ,#~(string-append #$dmenu "/bin/dmenu_run"))))
+
+(define %sway-default-gestures
+ `((swipe:3:right . "workspace next_on_output")
+ (swipe:3:left . "workspace prev_on_output")
+ (swipe:3:down . "move to scratchpad")
+ (swipe:3:up . "scratchpad show")
+ (pinch:2:clockwise
+ . "move container to workspace prev_on_output")
+ (pinch:2:counterclockwise
+ . "move container to workspace next_on_output")
+ (swipe:4:left . "exec alacritty")
+ (swipe:4:right . "exec qutebrowser")
+ (swipe:4:down . "exec st")
+ (swipe:4:up
+ . ,#~(string-append
+ "exec " #$emacs "/bin/emacsclient -a '"
+ #$libnotify "/bin/notify-send Oups \"emacs not loaded :/\"' -c"))
+ (pinch:inward+right . "resize shrink width")
+ (pinch:inward+left . "resize grow width")
+ (pinch:inward+down . "resize shrink height")
+ (pinch:inward+up . "resize grow height")
+ (pinch:outward+up . "move up")
+ (pinch:outward+down . "move down")
+ (pinch:outward+left . "move left")
+ (pinch:outward+right . "move right")))
+
+(define %sway-default-keybindings
+ `(($mod+Shift+e
+ . ,#~(string-append
+ "exec " #$emacs
+ "/bin/emacsclient -a '"
+ #$libnotify "/bin/notify-send Oups \"emacs not loaded :/\"' -c"))
+ ($mod+Return . "exec $term")
+ ($mod+Shift+c . "kill")
+ ($mod+p . "exec $menu")
+ ($mod+Shift+r . "reload")
+ ($mod+Shift+q
+ . ,#~(string-append
+ "exec " #$sway "/bin/swaynag -t warning "
+ "-m 'You pressed the exit shortcut. Do you really want to exit sway?"
+ " This will end your Wayland session.'"
+ " -B 'Yes, exit sway' 'swaymsg exit'"))
+ ($mod+$left . "focus left")
+ ($mod+$right . "focus right")
+ ($mod+$up . "focus up")
+ ($mod+$down . "focus down")
+ ($mod+Shift+$left . "move left")
+ ($mod+Shift+$right . "move right")
+ ($mod+Shift+$up . "move up")
+ ($mod+Shift+$down . "move down")
+ ($mod+ampersand . "workspace number 1")
+ ($mod+eacute . "workspace number 2")
+ ($mod+quotedbl . "workspace number 3")
+ ($mod+apostrophe . "workspace number 4")
+ ($mod+parenleft . "workspace number 5")
+ ($mod+minus . "workspace number 6")
+ ($mod+egrave . "workspace number 7")
+ ($mod+underscore . "workspace number 8")
+ ($mod+ccedilla . "workspace number 9")
+ ($mod+agrave . "workspace number 10")
+ ($mod+Shift+ampersand . "move container to workspace number 1")
+ ($mod+Shift+eacute . "move container to workspace number 2")
+ ($mod+Shift+quotedbl . "move container to workspace number 3")
+ ($mod+Shift+apostrophe . "move container to workspace number 4")
+ ($mod+Shift+parenleft . "move container to workspace number 5")
+ ($mod+Shift+minus . "move container to workspace number 6")
+ ($mod+Shift+egrave . "move container to workspace number 7")
+ ($mod+Shift+underscore . "move container to workspace number 8")
+ ($mod+Shift+ccedilla . "move container to workspace number 9")
+ ($mod+Shift+agrave . "move container to workspace number 10")
+ ($mod+b . "splith")
+ ($mod+v . "splitv")
+ ($mod+s . "layout stacking")
+ ($mod+w . "layout tabbed")
+ ($mod+e . "layout toggle split")
+ ($mod+f . "fullscreen")
+ ($mod+Shift+space . "floating toggle")
+ ($mod+space . "focus mode_toggle")
+ ($mod+z . "focus parent")
+ ($mod+Shift+o . "move scratchpad")
+ ($mod+o . "scratchpad show")
+ ($mod+r . "mode \"resize\"")
+ ($mod+Shift+n . "bar mode toggle")
+ ($mod+Shift+b . "border toggle")
+ ($mod+tab . "workspace back_and_forth")))
+
+
+;;;
+;;; Definition of configurations.
+;;;
+
+(define (list-of-string-or-gexp? lst)
+ (every (lambda (elt)
+ (or (string? elt)
+ (gexp? elt)))
+ lst))
+
+(define (list-of-packages? lst)
+ (every package? lst))
+
+(define (bar-position? p)
+ (member p '(top bottom)))
+
+(define (hidden-state? st)
+ (member st '(hide show)))
+
+(define (string-or-symbol? s)
+ (or (string? s)
+ (symbol? s)))
+
+(define (strings? lst)
+ (every string? lst))
+
+(define-maybe string (no-serialization))
+(define-maybe strings (no-serialization))
+
+(define-configuration/no-serialization sway-input
+ (identifier
+ (string-or-symbol '*)
+ "Identifier of the input.")
+ (xkb-layout
+ maybe-string
+ "Keyboard layout.")
+ (xkb-model
+ maybe-string
+ "Keyboard model.")
+ (xkb-options
+ maybe-strings
+ "Keyboard options.")
+ (xkb-variant
+ maybe-string
+ "Keyboard layout variant.")
+ (extra-content
+ (list-of-string-or-gexp '())
+ "Lines to add at the end of the configuration file."))
+
+(define (sway-inputs? lst)
+ (every sway-input? lst))
+
+(define-configuration/no-serialization sway-border-color
+ (border
+ string
+ "Border color.")
+ (background
+ string
+ "Background color.")
+ (text
+ string
+ "Text color."))
+
+(define-maybe sway-border-color (no-serialization))
+
+(define-configuration/no-serialization sway-color
+ (background
+ maybe-string
+ "Background color of the bar.")
+ (statusline
+ maybe-string
+ "Text color of the separator.")
+ (focused-background
+ maybe-string
+ "Background color of the bar on the currently focused monitor.")
+ (focused-statusline
+ maybe-string
+ "Text color of the statusline on the currently focused monitor.")
+ (focused-workspace
+ maybe-sway-border-color
+ "...")
+ (active-workspace
+ maybe-sway-border-color
+ "...")
+ (inactive-workspace
+ maybe-sway-border-color
+ "...")
+ (urgent-workspace
+ maybe-sway-border-color
+ "...")
+ (binding-mode
+ maybe-sway-border-color
+ "..."))
+
+(define-maybe sway-color (no-serialization))
+
+(define-configuration/no-serialization sway-bar
+ (identifier
+ (symbol 'bar0)
+ "Identifier of the bar.")
+ (position
+ (bar-position 'top)
+ "Position of the bar.")
+ (hidden-state
+ (hidden-state 'hide)
+ "Hidden state.")
+ (binding-mode-indicator
+ (boolean #t)
+ "Binding indicator.")
+ (colors
+ maybe-sway-color
+ "Color palette of the bar.")
+ (status-command
+ (file-like
+ (program-file
+ "sway-bar-status"
+ (with-imported-modules
+ (source-module-closure
+ '((ice-9 textual-ports) (ice-9 regex) (ice-9 popen) (ice-9 format)
+ (srfi srfi-19)))
+ #~(begin
+ (use-modules (ice-9 textual-ports)
+ (ice-9 format)
+ (ice-9 popen)
+ (ice-9 regex)
+ (srfi srfi-19))
+ (let loop ()
+ (let* ((date (date->string (current-date) "~a ~D ~H:~M:~S"))
+ (batline (let* ((p (open-pipe*
+ OPEN_READ
+ #$(file-append acpi "/bin/acpi") "-b"))
+ (bat (get-line p)))
+ (close-pipe p)
+ bat))
+ (bat (match:substring (string-match "[0-9]+%" batline))))
+ (format #t "~a - ~a~%~!" bat date)
+ (sleep 1)
+ (loop)))))))
+ "Status command. It must be file-like."))
+
+(define-configuration/no-serialization point
+ (x integer "X coordinate.")
+ (y integer "Y coordinate."))
+
+(define-maybe point (no-serialization))
+(define-maybe file-like (no-serialization))
+
+(define-configuration/no-serialization sway-output
+ (identifier
+ (string-or-symbol '*)
+ "Identifier of the output.")
+ (resolution
+ maybe-string
+ "Mode of the monitor.")
+ (position
+ maybe-point
+ "Position of the monitor.")
+ (bg
+ maybe-file-like
+ "Background image.")
+ (extra-content
+ (list-of-string-or-gexp '())
+ "Extra lines."))
+
+(define (sway-outputs? lst)
+ (every sway-output? lst))
+
+(define-configuration/no-serialization sway-configuration
+ (keybindings
+ (alist %sway-default-keybindings)
+ "Keybindings.")
+ (gestures
+ (alist %sway-default-gestures)
+ "Gestures.")
+ (packages
+ (list-of-packages
+ (list sway swaylock waybar swaybg slurp grim dmenu bemenu
+ dbus xdg-desktop-portal-wlr xdg-desktop-portal))
+ "List of packages to add to the profile.")
+ (variables
+ (alist %sway-default-variables)
+ "Variables declared at the beginning of the file.")
+ (inputs
+ (sway-inputs (list (sway-input)))
+ "Inputs.")
+ (outputs
+ (sway-outputs '())
+ "Outputs.")
+ (bar
+ (sway-bar (sway-bar))
+ "Bar configuration.")
+ (execs
+ (list-of-string-or-gexp '())
+ "Programs to execute at startup time.")
+ (extra-content
+ (list-of-string-or-gexp '())
+ "Lines to add at the end of the configuration file."))
+
+
+;;;
+;;; Serialization functions.
+;;;
+
+(define (serialize-keybinding var)
+ (let ((name (symbol->string (car var)))
+ (value (cdr var)))
+ #~(string-append "bindsym " #$name " " #$value)))
+
+(define (serialize-gesture var)
+ (let ((name (symbol->string (car var)))
+ (value (cdr var)))
+ #~(string-append "bindgesture " #$name " " #$value)))
+
+(define (serialize-variable var)
+ (let ((name (symbol->string (car var)))
+ (value (cdr var)))
+ #~(string-append "set $" #$name " " #$value)))
+
+(define (serialize-exec exe)
+ #~(string-append "exec " #$exe))
+
+(define (serialize-output out)
+ (let* ((pre-ident (sway-output-identifier out))
+ (ident (if (symbol? pre-ident)
+ (symbol->string pre-ident)
+ (string-append "\"" pre-ident "\"")))
+ (bg (sway-output-bg out))
+ (resolution (sway-output-resolution out))
+ (position (sway-output-position out))
+ (extra-content (sway-output-extra-content out)))
+ (append
+ (filter
+ (lambda (elt) (not (eq? elt %unset-value)))
+ (list
+ ;; Beginning of the block.
+ #~(string-append "output " #$ident " {")
+ ;; Optional elements.
+ (if (eq? %unset-value bg)
+ %unset-value
+ #~(string-append " bg " #$bg " fill"))
+ (if (eq? %unset-value resolution)
+ %unset-value
+ (string-append " resolution " resolution))
+ (if (eq? %unset-value position)
+ %unset-value
+ (string-append " position " (number->string (point-x position))
+ " " (number->string (point-y position))))))
+ extra-content
+ ;; End of the block.
+ '("}"))))
+
+(define-inlinable (add-line-if prefix value)
+ (if (eq? %unset-value value)
+ %unset-value
+ (string-append prefix " " value)))
+
+(define (serialize-input input)
+ (let* ((pre-ident (sway-input-identifier input))
+ (ident (if (symbol? pre-ident)
+ (symbol->string pre-ident)
+ (string-append "\"" pre-ident "\"")))
+ (xkb-layout (sway-input-xkb-layout input))
+ (xkb-model (sway-input-xkb-model input))
+ (xkb-variant (sway-input-xkb-variant input))
+ (xkb-options (sway-input-xkb-options input)))
+ (append
+ (filter
+ (lambda (elt) (not (eq? elt %unset-value)))
+ (list
+ (string-append "input " ident " {")
+ ;; Optional.
+ (add-line-if " xkb_layout" xkb-layout)
+ (add-line-if " xkb_model" xkb-model)
+ (add-line-if " xkb_variant" xkb-variant)
+ (if (eq? %unset-value xkb-options)
+ %unset-value
+ (string-concatenate (cons " xkb_options " xkb-options)))))
+ (map (lambda (s)
+ (string-append (string-pad "" 4) s))
+ (sway-input-extra-content input))
+ '("}"))))
+
+(define (serialize-colors colors)
+ (define (add-border-color-if name val)
+ (if (eq? %unset-value val)
+ %unset-value
+ (string-append
+ name
+ " " (sway-border-color-border val)
+ " " (sway-border-color-background val)
+ " " (sway-border-color-text val))))
+ (let ((background (sway-color-background colors))
+ (statusline (sway-color-statusline colors))
+ (focused-background (sway-color-focused-background colors))
+ (focused-statusline (sway-color-focused-statusline colors))
+ (focused-workspace (sway-color-focused-workspace colors))
+ (active-workspace (sway-color-active-workspace colors))
+ (inactive-workspace (sway-color-inactive-workspace colors))
+ (urgent-workspace (sway-color-urgent-workspace colors))
+ (binding-mode (sway-color-binding-mode colors)))
+ (filter
+ (lambda (elt) (not (eq? elt %unset-value)))
+ (list
+ (add-line-if "background" background)
+ (add-line-if "statusline" statusline)
+ (add-line-if "focused_background" focused-background)
+ (add-line-if "focused_statusline" focused-statusline)
+ (add-border-color-if "focused_workspace" focused-workspace)
+ (add-border-color-if "active_workspace" active-workspace)
+ (add-border-color-if "inactive_workspace" inactive-workspace)
+ (add-border-color-if "urgent_workspace" urgent-workspace)
+ (add-border-color-if "binding_mode" binding-mode)))))
+
+(define (make-sway-config conf)
+ (let* ((extra (sway-configuration-extra-content conf))
+ (bar (sway-configuration-bar conf)))
+
+ (with-imported-modules
+ (source-module-closure
+ '((ice-9 popen) (ice-9 match) (ice-9 format) (guix monads)))
+ (computed-file
+ "sway-config"
+ #~(begin
+ (use-modules (ice-9 format) (ice-9 popen) (ice-9 match)
+ (guix monads))
+ ;; Helper functions to pretty-print the configuration file.
+ (define (line s)
+ (lambda (port)
+ (lambda (i)
+ (format port "~a~a~%" (string-pad "" i) s)
+ (values port i))))
+ (define (lines lst)
+ (lambda (port)
+ (lambda (i)
+ (let loop ((l lst))
+ (match l
+ (() #t)
+ ((head . tail)
+ (format port "~a~a~%" (string-pad "" i)
+ (if (list? head)
+ (string-concatenate head)
+ head))
+ (loop tail))))
+ (values port i))))
+ (define-syntax line*
+ (syntax-rules ()
+ ((line* elt ...)
+ (lines (list elt ...)))))
+ (define-syntax line2
+ (syntax-rules ()
+ ((line2 a b)
+ (line (string-append a b)))))
+ (define (indent k)
+ (lambda (port)
+ (lambda (i)
+ (values port (+ i k)))))
+ (define (begin-block name)
+ (lambda (port)
+ (lambda (i)
+ (format port "~a~a {~%" (string-pad "" i) name)
+ (values port (+ i 4)))))
+ (define (end-block)
+ (lambda (port)
+ (lambda (i)
+ (let ((i (- i 4)))
+ (format port "~a}~%" (string-pad "" i))
+ (values port i)))))
+
+ (let* ((file #$output)
+ (port (open-output-file #$output)))
+ ;; The previous iteration of this work computed the content of the
+ ;; configuration file as a string. The state monad was used to
+ ;; keep track of the state during the computation.
+ ;; However, this first approach was too expensive. Now that I use
+ ;; `computed-file', the "computed value" is the constant port to
+ ;; which I write. Thus, using the state monad is overkill here.
+ ;; It can be replaced by the identity monad, where the value being
+ ;; passed around is the pair of `port' and the indentation level.
+
This message was truncated. Download the full message here.