;;; 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 modules)
#:use-module (guix gexp)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (guix packages)
#:use-module (gnu system keyboard)
#:use-module (gnu services configuration)
#:use-module (gnu home services)
#:use-module (gnu packages wm)
#:use-module (gnu packages terminals)
#:export (;; Event codes
%ev-code-mouse-left
%ev-code-mouse-right
%ev-code-mouse-scroll-click
;; Configuration records.
sway-configuration
sway-bar
sway-output
sway-input
point
sway-color
sway-border-color
home-sway-service-type
sway-configuration->file
sway-mode
;; Default values.
%sway-default-variables
%sway-default-gestures
%sway-default-modes
%sway-default-keybindings
%sway-default-startup-programs
%sway-default-packages))
;; Helper function.
(define (flatmap f l)
(let loop ((lst (reverse l)) (acc '()))
(match lst
(() acc)
((head . tail)
(let* ((h (f head))
(acc (append h acc)))
(loop tail acc))))))
;;;
;;; Definition of configurations.
;;;
(define (string-ish? s)
(or (gexp? s)
(file-like? s)
(string? s)))
(define (string-or-gexp? s)
(or (gexp? s)
(string? s)))
(define (list-of-string-ish? lst)
(every string-ish? lst))
(define (list-of-packages? lst)
(every package? lst))
(define (bar-position? p)
(member p '(top bottom)))
(define (hidden-state? st)
(member st '(hide show)))
(define (string-or-symbol? s)
(or (string? s)
(symbol? s)))
(define (strings? lst)
(every string? lst))
(define (extra-content? extra)
(every string-or-gexp? extra))
(define (make-alist-predicate key? val?)
(lambda (lst)
(every
(lambda (item)
(match item
((k . v)
(and (key? k)
(val? v)))
(_ #f)))
lst)))
(define bindings?
(make-alist-predicate symbol? string-or-gexp?))
(define mouse-bindings?
(make-alist-predicate integer? string-or-gexp?))
(define (variables? lst)
(make-alist-predicate symbol? string-ish?))
(define-maybe string (no-serialization))
(define-maybe strings (no-serialization))
(define-maybe boolean (no-serialization))
(define-maybe keyboard-layout (no-serialization))
(define-configuration/no-serialization sway-input
(identifier
(string-or-symbol '*)
"Identifier of the input.")
(layout
maybe-keyboard-layout
"Keyboard layout of the input.")
(disable-while-typing
maybe-boolean
"If `#t', disable the input while typing; if `#f' do not.")
(disable-while-trackpointing
maybe-boolean
"If `#t', disable the input while using a trackpoint; if `#f' do not.")
(tap
maybe-boolean
"Enable or disable tap.")
(extra-content
(extra-content '())
"Lines to add at the end of the configuration file."))
(define (sway-inputs? lst)
(every sway-input? lst))
(define-configuration/no-serialization sway-border-color
(border
string
"Border color.")
(background
string
"Background color.")
(text
string
"Text color."))
(define-maybe sway-border-color (no-serialization))
(define-configuration/no-serialization sway-color
(background
maybe-string
"Background color of the bar.")
(statusline
maybe-string
"Text color of the status line.")
(focused-background
maybe-string
"Background color of the bar on the currently focused monitor.")
(focused-statusline
maybe-string
"Text color of the statusline on the currently focused monitor.")
(focused-workspace
maybe-sway-border-color
"Color scheme for focused workspaces.")
(active-workspace
maybe-sway-border-color
"Color scheme for active workspaces.")
(inactive-workspace
maybe-sway-border-color
"Color scheme for inactive workspaces.")
(urgent-workspace
maybe-sway-border-color
"Color scheme for workspaces containing `urgent' windows.")
(binding-mode
maybe-sway-border-color
"Color scheme for the binding mode indicator."))
(define-maybe sway-color (no-serialization))
(define (status-command? c)
(or (string? c)
(file-like? c)
(gexp? c)))
(define-maybe bar-position (no-serialization))
(define-maybe hidden-state (no-serialization))
(define-maybe status-command (no-serialization))
(define-configuration/no-serialization sway-bar
(identifier
(symbol 'bar0)
"Identifier of the bar.")
(position
maybe-bar-position
"Position of the bar.")
(hidden-state
maybe-hidden-state
"Hidden state.")
(binding-mode-indicator
maybe-boolean
"Binding indicator.")
(colors
maybe-sway-color
"Color palette of the bar.")
(status-command
maybe-status-command
"Status command.")
(mouse-bindings
(mouse-bindings '())
"Actions triggered by mouse events.")
(extra-content
(extra-content '())
"Extra configuration lines."))
(define-maybe sway-bar (no-serialization))
(define-configuration/no-serialization point
(x integer "X coordinate.")
(y integer "Y coordinate."))
(define-maybe point (no-serialization))
(define (background? bg)
(or (string-ish? bg)
(and (pair? bg)
(string-ish? (car bg))
(member (cdr bg) '(stretch fill fit center tile)))))
(define-maybe background (no-serialization))
(define-configuration/no-serialization sway-output
(identifier
(string-or-symbol '*)
"Identifier of the output.")
(resolution
maybe-string
"Mode of the monitor.")
(position
maybe-point
"Position of the monitor.")
(background
maybe-background
"Background image.")
(extra-content
(extra-content '())
"Extra lines."))
(define (sway-outputs? lst)
(every sway-output? lst))
(define-configuration/no-serialization sway-mode
(mode-name
(string "default")
"Name of the mode.")
(keybindings
(bindings '())
"Keybindings.")
(mouse-bindings
(mouse-bindings '())
"Mouse bindings."))
(define (sway-modes? lst)
(every sway-mode? lst))
(define-configuration/no-serialization sway-configuration
(keybindings
(bindings %sway-default-keybindings)
"Keybindings.")
(gestures
(bindings %sway-default-gestures)
"Gestures.")
(packages
(list-of-packages
%sway-default-packages)
"List of packages to add to the profile.")
(variables
(variables %sway-default-variables)
"Variables declared at the beginning of the file.")
(inputs
(sway-inputs '())
"Inputs.")
(outputs
(sway-outputs '())
"Outputs.")
(bar
maybe-sway-bar
"Bar configuration.")
(modes
(sway-modes %sway-default-modes)
"Additional modes.")
(startup+reload-programs
(list-of-string-ish '())
"Programs to execute at startup time.")
(startup-programs
(list-of-string-ish %sway-default-startup-programs)
"Programs to execute at startup time.")
(extra-content
(extra-content '())
"Lines to add at the end of the configuration file."))
;;;
;;; Default settings and useful constants.
;;;
(define sway-menu
(program-file
"sway-menu.scm"
(with-imported-modules
(source-module-closure '((guix build utils)))
#~(begin
(use-modules (ice-9 ftw)
(ice-9 popen)
(ice-9 receive)
(ice-9 rdelim)
(guix build utils)
(srfi srfi-1))
(define (directory->files dir)
(define (executable-file? f)
;; Cf. `(@ (guix build utils) executable-file?)' for an
;; explanation of `(zero? ...)'.
(and=> (and (not (eq? (string-ref f 0) #\.))
(stat f))
(lambda (s)
(not (or
(zero? (logand (stat:mode s) #o100))
(eq? (stat:type s) 'directory))))))
(with-directory-excursion dir
(scandir "." executable-file?)))
(let ((path (string-append (getenv "HOME")
"/.guix-home/profile/bin"))
(wmenu #$(file-append wmenu "/bin/wmenu"))
(swaymsg #$(file-append sway "/bin/swaymsg")))
(receive (from to pids)
(pipeline `((,wmenu)))
(for-each
(lambda (c) (format to "~a~%" c))
(directory->files path))
(close to)
(let ((choice (read-line from)))
(close from)
(waitpid (first pids))
(when (string? choice) ;do not attempt to launch if no choice
;was given (e.g. if Escape is pressed in
;wmenu).
(execl swaymsg swaymsg "exec" "--"
choice)))))))))
(define %ev-code-mouse-left 272)
(define %ev-code-mouse-right 273)
(define %ev-code-mouse-scroll-click 274)
(define %sway-default-modes
(list (sway-mode
(mode-name "resize")
(keybindings
'(($left . "resize shrink width 10px")
($down . "resize grow height 10px")
($up . "resize shrink height 10px")
($right . "resize grow width 10px")
(Left . "resize shrink width 10px")
(Down . "resize grow height 10px")
(Up . "resize shrink height 10px")
(Right . "resize grow width 10px")
(Return . "mode \"default\"")
(Escape . "mode \"default\""))))))
(define %sway-default-packages
(list sway))
(define %sway-default-variables
`((mod . "Mod4")
(left . "h")
(down . "j")
(up . "k")
(right . "l")
(term . ,(file-append foot "/bin/foot"))
(menu . ,sway-menu)))
(define %sway-default-gestures
'((swipe:3:right . "workspace next_on_output")
(swipe:3:left . "workspace prev_on_output")
(swipe:3:down . "move to scratchpad")
(swipe:3:up . "scratchpad show")))
(define %sway-default-keybindings
`(($mod+Return . "exec $term")
($mod+Shift+q . "kill")
($mod+d . "exec $menu")
($mod+Shift+c . "reload")
($mod+Shift+e
. ,#~(string-append
"exec " #$sway "/bin/swaynag -t warning -m \\\n "
"'You pressed the exit shortcut. Do you really want to exit sway?"
" This will end your Wayland session.' \\\n "
"-B 'Yes, exit sway' \\\n '"
#$sway "/bin/swaymsg exit'"))
($mod+$left . "focus left")
($mod+$down . "focus down")
($mod+$up . "focus up")
($mod+$right . "focus right")
($mod+Left . "focus left")
($mod+Down . "focus down")
($mod+Up . "focus up")
($mod+Right . "focus right")
($mod+Shift+$left . "move left")
($mod+Shift+$down . "move down")
($mod+Shift+$up . "move up")
($mod+Shift+$right . "move right")
($mod+Shift+Left . "move left")
($mod+Shift+Down . "move down")
($mod+Shift+Up . "move up")
($mod+Shift+Right . "move right")
($mod+1 . "workspace number 1")
($mod+2 . "workspace number 2")
($mod+3 . "workspace number 3")
($mod+4 . "workspace number 4")
($mod+5 . "workspace number 5")
($mod+6 . "workspace number 6")
($mod+7 . "workspace number 7")
($mod+8 . "workspace number 8")
($mod+9 . "workspace number 9")
($mod+0 . "workspace number 10")
($mod+Shift+1 . "move container to workspace number 1")
($mod+Shift+2 . "move container to workspace number 2")
($mod+Shift+3 . "move container to workspace number 3")
($mod+Shift+4 . "move container to workspace number 4")
($mod+Shift+5 . "move container to workspace number 5")
($mod+Shift+6 . "move container to workspace number 6")
($mod+Shift+7 . "move container to workspace number 7")
($mod+Shift+8 . "move container to workspace number 8")
($mod+Shift+9 . "move container to workspace number 9")
($mod+Shift+0 . "move container to workspace number 10")
($mod+b . "splith")
($mod+v . "splitv")
($mod+s . "layout stacking")
($mod+w . "layout tabbed")
($mod+e . "layout toggle split")
($mod+f . "fullscreen")
($mod+Shift+space . "floating toggle")
($mod+space . "focus mode_toggle")
($mod+a . "focus parent")
($mod+Shift+minus . "move scratchpad")
($mod+minus . "scratchpad show")
($mod+r . "mode \"resize\"")))
(define %sway-default-startup-programs
(list
#~(string-append
#$swayidle "/bin/swayidle -w \\\n "
;; 300: lock screen.
"timeout 300 '" #$swaylock "/bin/swaylock "
"--indicator-radius 75 \\\n "
"-i " #$sway
"/share/backgrounds/sway/Sway_Wallpaper_Blue_1920x1080.png \\\n "
"-f -c 000000' \\\n "
;; 600: lock + screen off.
"timeout 600 '" #$sway "/bin/swaymsg \"output * power off\"' \\\n "
;; Resume + sleep.
"resume '" #$sway "/bin/swaymsg \"output * power on\"' \\\n "
"before-sleep '" #$swaylock "/bin/swaylock -f -c 000000'")))
;;;
;;; Serialization functions.
;;;
;; The main serialization code is defined in `sway-configuration->file' below.
;; In this function, the configuration is seen as a list of lines and blocks.
;;
;; The other serialization functions of this files are helpers that will build
;; the above list. Each function either returns a list, or elements that will
;; be put in one. The elements of these lists will either be:
;; - strings,
;; In this case, the string is seen as a line to add to the configuraiton
;; file.
;; - a pair (cons 'begin-block string),
;; In this case, a line "string {" is added to the configuration file, and
;; the indentation level is increased by four.
;; - the symbol 'end-block.
;; In which case the indentation level is decreased by four, and the current
;; configuration block is closed (with the line "}").
;; A few helper functions:
(define* (add-line-if field value
#:key (serializer %unset-value)
(suffix %unset-value))
(if (eq? %unset-value value)
%unset-value
#~(string-append #$field " "
#$(if (eq? serializer %unset-value)
value
(serializer value))
#$(if (eq? suffix %unset-value)
""
suffix))))
(define (add-block name content)
(let ((content (filter
(lambda (elt) (not (eq? elt %unset-value)))
content)))
(if (equal? content '())
'()
(append
(list #~(cons 'begin-block #$name))
content
(list #~'end-block)))))
(define-syntax add-block*
(syntax-rules ()
((add-block* name elt ...)
(add-block name (append elt ...)))))
;; Serialization functions:
(define (box str)
(let* ((len (string-length str))
(line (make-string (+ 8 len) #\#)))
(list
line
(string-append "### " str " ###")
line)))
(define (with-heading str lst)
(define (heading str)
(let* ((len (string-length str))
(line (make-string (+ 2 len) #\#)))
(list
"" ;add an empty line before the configuration section.
(string-append "# " str)
line)))
(if (equal? lst '())
'() ;if the configuration block is empty, do not add the heading.
(append (heading str) lst)))
(define-inlinable (serialize-boolean-yn b)
(if b "yes" "no"))
(define-inlinable (serialize-boolean-ed b)
(if b "enable" "disable"))
(define-inlinable (serialize-binding binder key value)
#~(string-append #$binder #$key " " #$value))
(define (serialize-mouse-binding var)
(let* ((ev (car var))
(ev-code (number->string ev))
(command (cdr var)))
(serialize-binding "bindcode " ev-code command)))
(define (serialize-keybinding var)
(let ((name (symbol->string (car var)))
(value (cdr var)))
(serialize-binding "bindsym " name value)))
(define (serialize-gesture var)
(let ((name (symbol->string (car var)))
(value (cdr var)))
(serialize-binding "bindgesture " name value)))
(define (serialize-variable var)
(let ((name (symbol->string (car var)))
(value (cdr var)))
(serialize-binding "set $" name value)))
(define (serialize-exec b)
(if b
(lambda (exe)
#~(string-append "exec_always " #$exe))
(lambda (exe)
#~(string-append "exec " #$exe))))
(define (serialize-output out)
(let* ((pre-ident (sway-output-identifier out))
(ident (if (symbol? pre-ident)
(symbol->string pre-ident)
(string-append "\"" pre-ident "\"")))
(background (let ((bg (sway-output-background out)))
(if (pair? bg)
bg
(cons bg 'fill))))
(resolution (sway-output-resolution out))
(position (sway-output-position out))
(extra-content (sway-output-extra-content out)))
(add-block
(string-append "output " ident)
(cons*
;; Optional elements.
(add-line-if "bg" (car background)
#:suffix
(string-append " " (symbol->string (cdr background))))
(add-line-if "resolution" resolution)
(add-line-if "position" position
#:serializer
(lambda (p)
(string-append (number->string (point-x p))
" "
(number->string (point-y p)))))
;; Extra-content: inlined as-is.
extra-content))))
(define (serialize-input input)
(define-inlinable (fetch-arg layout acc)
(if (eq? layout %unset-value)
%unset-value
(acc layout)))
(define-inlinable (unfalse f)
(lambda (arg)
(let ((res (f arg)))
(if res res %unset-value))))
(define-inlinable (unnil f)
(lambda (arg)
(let ((res (f arg)))
(if (nil? res) %unset-value res))))
(let* ((pre-ident (sway-input-identifier input))
(ident (if (symbol? pre-ident)
(symbol->string pre-ident)
(string-append "\"" pre-ident "\"")))
;; unpack the `layout' field.
(layout (sway-input-layout input))
(xkb-layout (fetch-arg layout keyboard-layout-name))
(xkb-variant (fetch-arg layout (unfalse keyboard-layout-variant)))
(xkb-model (fetch-arg layout (unfalse keyboard-layout-model)))
(xkb-options (fetch-arg layout (unnil keyboard-layout-options)))
(tap (sway-input-tap input))
(dwt (sway-input-disable-while-typing input))
(dwtp (sway-input-disable-while-trackpointing input))
(extra-content (sway-input-extra-content input)))
(add-block
(string-append "input " ident)
(cons*
;; Optional.
(add-line-if "xkb_layout" xkb-layout)
(add-line-if "xkb_model" xkb-model)
(add-line-if "xkb_variant" xkb-variant)
(add-line-if "xkb_options" xkb-options
#:serializer (lambda (l) (string-join l ",")))
(add-line-if "dwt" dwt
#:serializer serialize-boolean-ed)
(add-line-if "dwtp" dwtp
#:serializer serialize-boolean-ed)
(add-line-if "tap" tap
#:serializer serialize-boolean-ed)
;; extra-content inlined as-is.
extra-content))))
(define (serialize-colors colors)
(define (border-serializer val)
(string-append (sway-border-color-border val)
" " (sway-border-color-background val)
" " (sway-border-color-text val)))
(if (eq? %unset-value colors)
'()
(let ((background (sway-color-background colors))
(statusline (sway-color-statusline colors))
(focused-background (sway-color-focused-background colors))
(focused-statusline (sway-color-focused-statusline colors))
(focused-workspace (sway-color-focused-workspace colors))
(active-workspace (sway-color-active-workspace colors))
(inactive-workspace (sway-color-inactive-workspace colors))
(urgent-workspace (sway-color-urgent-workspace colors))
(binding-mode (sway-color-binding-mode colors)))
(add-block
"colors"
(list
(add-line-if "background" background)
(add-line-if "statusline" statusline)
(add-line-if "focused_background" focused-background)
(add-line-if "focused_statusline" focused-statusline)
(add-line-if "focused_workspace" focused-workspace
#:serializer border-serializer)
(add-line-if "active_workspace" active-workspace
#:serializer border-serializer)
(add-line-if "inactive_workspace" inactive-workspace
#:serializer border-serializer)
(add-line-if "urgent_workspace" urgent-workspace
#:serializer border-serializer)
(add-line-if "binding_mode" binding-mode
#:serializer border-serializer))))))
(define (serialize-mode mode)
(let ((name (sway-mode-mode-name mode))
(keys (sway-mode-keybindings mode))
(clicks (sway-mode-mouse-bindings mode)))
(add-block*
(string-append "mode \"" name "\"")
(map serialize-keybinding keys)
(map serialize-mouse-binding clicks))))
(define (serialize-bar bar)
(define serialize-symbol
symbol->string)
(let ((identifier (symbol->string (sway-bar-identifier bar)))
(position (sway-bar-position bar))
(hidden-state (sway-bar-hidden-state bar))
(status-command (sway-bar-status-command bar))
(binding-mode-indicator (sway-bar-binding-mode-indicator bar))
(mouse-bindings (sway-bar-mouse-bindings bar))
(extra-content (sway-bar-extra-content bar))
(colors (sway-bar-colors bar)))
(add-block*
(string-append "bar " identifier)
(if (eq? colors %unset-value)
'()
(serialize-colors colors))
(list
(add-line-if "position" position
#:serializer serialize-symbol)
(add-line-if "hidden_state" hidden-state
#:serializer serialize-symbol)
(add-line-if "status_command" status-command)
(add-line-if "binding_mode_indicator" binding-mode-indicator
#:serializer serialize-boolean-yn))
;; Mouse-bindings and extra-content
(map serialize-mouse-binding mouse-bindings)
extra-content)))
(define (sway-configuration->file conf)
(let* ((extra (sway-configuration-extra-content conf))
(bar (sway-configuration-bar conf)))
(computed-file
"sway-config"
#~(begin
(use-modules (ice-9 format) (ice-9 match)
(srfi srfi-1))
(call-with-output-file #$output
(lambda (port)
;; Add the (indented) line "s" to the output file.
(define (line s)
(lambda (i)
(format port "~a~a~%" i s)
i))
;; Begin a block "name" and adjust the indentation.
(define (begin-block name)
(lambda (i)
(format port "~a~a {~%" i name)
(string-append " " i)))
;; Ends an open block and adjust the indentation.
;; Note: we must currently be in a configuration block.
;; Otherwise, `string-drop' might fail.
(define (end-block)
(lambda (i)
(let ((i (string-drop i 4)))
(format port "~a}~%" i)
i)))
;; Helper function. The configuration is represented as a list
;; of actions (alter the indentation level, add a line, ...).
;; This function recognises the action and calls the right
;; function among those defined above.
(define (serializer-dispatch-m arg)
(match arg
;; Special cases:
(('begin-block . str) (begin-block str))
('end-block (end-block))
;; Default case: `arg' is assumed to be a string.
(_ (line arg))))
(define (serializer-dispatch elt i)
((serializer-dispatch-m elt) i))
(fold
;; Dispatch function: depending on its argument, it will change
;; the indentation level or add a line to the output file.
serializer-dispatch
;; Initial indentation string. This string is prepended to
;; lines before their serialization.
""
;; List of lines or indentation modifiers.
(list
;; Header.
#$@(box "Auto-generated configuration")
"# DO NOT EDIT MANUALLY."
;; Variables.
#$@(with-heading "Variables."
(map serialize-variable
(sway-configuration-variables conf)))
;; Outputs.
#$@(with-heading "Outputs."
(flatmap serialize-output
(sway-configuration-outputs conf)))
;; Inputs.
#$@(with-heading "Inputs."
(flatmap serialize-input
(sway-configuration-inputs conf)))
;; Bar configuration:
;; If the bar is unset, do not include anything.
#$@(if (eq? bar %unset-value)
'()
(with-heading "Bar configuration."
(serialize-bar bar)))
;; Keybindings.
#$@(with-heading "Keybindings."
(map serialize-keybinding
(sway-configuration-keybindings conf)))
;; Gestures.
#$@(with-heading "Gestures."
(map serialize-gesture
(sway-configuration-gestures conf)))
;; Modes.
#$@(with-heading "Modes."
(flatmap serialize-mode
(sway-configuration-modes conf)))
;; Startup-Programs.
#$@(with-heading
"Programs to execute (at startup)."
(map (serialize-exec #f)
(sway-configuration-startup-programs conf)))
;; startup+reload-programs.
#$@(with-heading
"Programs to execute (at startup & after reload)."
(map (serialize-exec #t)
(sway-configuration-startup+reload-programs conf)))
;; Extra-content.
#$@(with-heading "Extra-content" extra)))))))))
;;;
;;; Definition of the Home Service.
;;;
(define (sway-configuration->files sway-conf)
`((".config/sway/config" ,(sway-configuration->file sway-conf))))
(define home-sway-service-type
(service-type
(name 'home-sway-config)
(extensions
(list (service-extension home-files-service-type
sway-configuration->files)
(service-extension home-profile-service-type
sway-configuration-packages)))
(description "Configure Sway by providing a file
@file{~/.config/sway/config}.")
(default-value (sway-configuration))))
