kanshi service wayland

1 files changed, 192 insertions, 0 deletions

diff --git a/sigils/home/services/wayland.scm b/sigils/home/services/wayland.scm
new file mode 100644
index 0000000..379e2e3
--- /dev/null
+++ b/sigils/home/services/wayland.scm
@@ -0,0 +1,192 @@
+;;; si sourcehut avait une ipv6 je pourrais leur envoyer des mails
+;;; mais je peux pas donc rde aura pas mes changements
+;;;
+;;; rde --- Reproducible development environment.
+;;;
+;;; Copyright © 2022 Andrew Tropin <andrew@trop.in>
+;;;
+;;; This file is part of rde.
+;;;
+;;; rde 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.
+;;;
+;;; rde 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 rde.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (sigils home services wayland)
+  #:use-module (gnu home services)
+  #:use-module (gnu home services shepherd)
+  #:use-module (gnu packages wm)
+  #:use-module (gnu services configuration)
+  #:use-module (guix packages)
+  #:use-module (guix gexp)
+  #:use-module (guix diagnostics)
+  #:use-module (guix ui)
+  #:use-module (sigils home services desktop)
+
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-43)
+  #:use-module (ice-9 match)
+
+  #:export (home-kanshi-service-type
+            home-kanshi-configuration
+            sway-config?))
+
+
+(define sway-config? list?)
+(define (serialize-sway-config val)
+  (define (aligner nestness)
+    (apply string-append
+           (map (const "    ") (iota nestness))))
+
+  (define (serialize-sway-term term)
+    ;; (format #t "finval. ~a\n" term)
+    (match term
+      (#t "yes")
+      (#f "no")
+      ((? symbol? e) (symbol->string e))
+      ((? number? e) (number->string e))
+      ;; TODO: Change it to ((? string? e) (format #f "~s" e))
+      ((? string? e) e)
+      ((lst ...)
+       (raise (formatted-message
+               (G_ "Sway term should be a non-list value (string, \
+boolean, number, symbol, or gexp). Provided term is:\n ~a") lst)))
+      (e e)))
+
+  (define* (serialize-sway-expression
+            expr #:optional (nestness 0))
+    ;; (format #t "expres. ~a\n" expr)
+    (match expr
+      ;; subconfig has the same structure as config,
+      ;; the only difference: it's not a top-level form
+      ;; can be found at the end of expression.
+      ;; (term subconfig)
+      ((term ((expressions ...) ...))
+       ;; (format #t "subtop. ~a . ~a\n" term expressions)
+       (append
+        (list (serialize-sway-term term) " {\n")
+        (serialize-sway-subconfig expressions (1+ nestness))
+        `(,(aligner nestness)
+          "}\n")))
+
+      ;; subexpression:
+      ;; (term . rest)
+      ((term rest ..1)
+       ;; (format #t "inside. ~a . ~a\n" term rest)
+       (cons* (serialize-sway-term term) " "
+              (serialize-sway-expression rest)))
+
+      ;; last element of subexpression
+      ((term)
+       ;; (format #t "term.   ~a\n" term)
+       (list (serialize-sway-term term) "\n"))
+
+      (e
+       (raise (formatted-message
+               (G_ "Sway expression should be a list of terms \
+optionally ending with subconfigs, but provided expression is:\n ~a")
+               e)))))
+
+  (define* (serialize-sway-subconfig
+            subconfig #:optional (nestness 0))
+    (match subconfig
+      ;; config:
+      ;; ((expr1) (expr2) (expr3))
+      (((expressions ...) ...)
+       (append-map
+        (lambda (e)
+          (append (list (aligner nestness))
+                  (serialize-sway-expression e nestness)))
+        expressions))
+      (e
+       (raise (formatted-message
+               (G_ "Sway (sub)config should be a list of expressions, \
+where each expression is also a list, but provided value is:\n ~a") e))) ))
+
+  (serialize-sway-subconfig val))
+
+;;;
+;;; kanshi.
+;;;
+
+(define (serialize-string field-name value) value)
+
+(define-configuration home-kanshi-configuration
+  (kanshi
+   (file-like kanshi)
+   "kanshi package to use.")
+  (config
+   (sway-config
+    `())
+   "This field has the same format as sway's config field, but in reality kanshi
+supports only a subset of sway config.  To get the complete list of available
+options see @code{man 5 kanshi}.
+
+The example configuration:
+
+@lisp
+()
+@end lisp"))
+
+(define (add-kanshi-packages config)
+  (list (home-kanshi-configuration-kanshi config)))
+
+(define (add-kanshi-configuration config)
+  `(("kanshi/config"
+     ,(apply
+       mixed-text-file
+       "kanshi-config"
+       (serialize-sway-config (home-kanshi-configuration-config config))))))
+
+(define (home-kanshi-shepherd-service config)
+  (let ((kanshi (home-kanshi-configuration-kanshi config)))
+    (list
+     (shepherd-service
+      (provision '(kanshi))
+      (requirement '(wayland-display))
+      (start #~(make-forkexec-constructor
+                (list #$(file-append kanshi "/bin/kanshi"))
+                #:log-file (string-append
+                            (getenv "XDG_STATE_HOME") "/log"
+                            "/kanshi.log")
+                #:environment-variables
+                (cons (string-append "WAYLAND_DISPLAY="
+                                     (getenv "WAYLAND_DISPLAY"))
+                      (remove (cut string-prefix? "WAYLAND_DISPLAY=" <>)
+                              (default-environment-variables)))))
+      (stop #~(make-kill-destructor))
+      (documentation "Run Kanshi")))))
+
+(define (home-kanshi-extensions cfg extensions)
+  (home-kanshi-configuration
+   (inherit cfg)
+   (config
+    (append (home-kanshi-configuration-config cfg)
+            (append-map identity (reverse extensions))))))
+
+(define home-kanshi-service-type
+  (service-type (name 'home-kanshi)
+                (extensions
+                 (list (service-extension
+                        home-profile-service-type
+                        add-kanshi-packages)
+                       (service-extension
+                        home-shepherd-service-type
+                        home-kanshi-shepherd-service)
+                       (service-extension
+                        home-xdg-configuration-files-service-type
+                        add-kanshi-configuration)))
+                (compose identity)
+                (extend home-kanshi-extensions)
+                (default-value (home-kanshi-configuration))
+                (description "\
+Install and configure kanshi, output profile manager.")))