rosenthal: Add emacs-kdl-mode.

* modules/rosenthal/packages/emacs-xyz.scm (emacs-kdl-mode): New variable.

modules/rosenthal/packages/binaries.scm

@@ -11,11 +11,13 @@
   #:use-module (guix gexp)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix packages)
+  #:use-module (guix platform)
   #:use-module (guix utils)
   #:use-module (rosenthal utils packages)
   ;; Guix origin methods
   #:use-module (guix download)
   ;; Guix build systems
+  #:use-module (guix build-system gnu)
   #:use-module (guix build-system copy)
   ;; Guix packages
   #:use-module (gnu packages base)
@@ -483,76 +485,72 @@ rather a set of labels for each log stream.")
                 "1pxnjzygm2mylipf6cjkqxm4k3i9vnm7v80avxbhv8400p3aszqk"))))))
 
 (define-public alloy-bin
-  (package
-    (name "alloy-bin")
-    (version (package-version %alloy-source-x86_64-linux))
-    (source #f)
-    (build-system copy-build-system)
-    (arguments
-     (let ((binary-source
-            (match (or (%current-target-system)
-                       (%current-system))
-              ((? target-aarch64?)
-               (package-source %alloy-source-aarch64-linux))
-              (_
-               (package-source %alloy-source-x86_64-linux)))))
-       (list
-        #:install-plan
-        (match (or (%current-target-system)
-                   (%current-system))
-          ((? target-aarch64?)
-           #~'(("alloy-linux-arm64" "bin/alloy")))
-          (_
-           #~'(("alloy-linux-amd64" "bin/alloy"))))
-        #:modules
-        '((ice-9 match)
-          (guix build copy-build-system)
-          (guix build utils))
-        #:phases
-        #~(modify-phases %standard-phases
-            (replace 'unpack
-              (lambda _
-                ((assoc-ref %standard-phases 'unpack)
-                 #:source #+binary-source)))
-            (add-after 'install 'patch-elf
-              (lambda _
-                (let ((name "alloy")
-                      (dest (in-vicinity #$output "bin"))
-                      (ld.so #$(file-append glibc (glibc-dynamic-linker))))
-                  (with-directory-excursion dest
-                    (invoke "patchelf" "--set-interpreter" ld.so name)
-                    (chmod name #o555)))))
-            (add-after 'patch-elf 'install-extras
-              (lambda* (#:key native-inputs inputs #:allow-other-keys)
-                (let ((alloy
+  (binary-package
+   `(("x86_64-linux"  . ,%alloy-source-x86_64-linux)
+     ("aarch64-linux" . ,%alloy-source-aarch64-linux))
+   (package
+     (name "alloy-bin")
+     (version "")
+     (source #f)
+     (build-system gnu-build-system)
+     (arguments
+      (list
+       #:modules
+       `((ice-9 match)
+         ,@%default-gnu-modules)
+       #:phases
+       #~(modify-phases %standard-phases
+           (delete 'bootstrap)
+           (delete 'configure)
+           (delete 'build)
+           (delete 'check)
+           (replace 'install
+             (lambda _
+               (let ((src #$(mapping-for-system
+                             '(("x86_64-linux"  . "alloy-linux-amd64")
+                               ("aarch64-linux" . "alloy-linux-arm64"))))
+                     (dst (in-vicinity #$output "bin/alloy")))
+                 (mkdir-p (dirname dst))
+                 (copy-file src dst))))
+           (add-after 'install 'patch-elf
+             (lambda* (#:key inputs #:allow-other-keys)
+               (let ((ld.so (search-input-file inputs #$(glibc-dynamic-linker)))
+                     (dest (in-vicinity #$output "bin"))
+                     (name "alloy"))
+                 (with-directory-excursion dest
+                   (invoke "patchelf" "--set-interpreter" ld.so name)
+                   (chmod name #o555)))))
+           (add-after 'patch-elf 'install-extras
+             (lambda* (#:key native-inputs inputs outputs #:allow-other-keys)
+               (let ((alloy
+                      (search-input-file
                        (if #$(%current-target-system)
-                           (search-input-file (or native-inputs inputs)
-                                              "bin/alloy")
-                           (in-vicinity #$output "bin/alloy"))))
-                  (for-each
-                   (match-lambda
-                     ((shell . file)
-                      (mkdir-p (in-vicinity #$output (dirname file)))
-                      (with-output-to-file (in-vicinity #$output file)
-                        (lambda ()
-                          (invoke alloy "completion" shell)))))
-                   '(("bash" . "share/bash-completion/completions/alloy")
-                     ("fish" . "share/fish/vendor_completions.d/alloy.fish")
-                     ("zsh"  . "share/zsh/site-functions/_alloy"))))))))))
-    (native-inputs
-     (append (if (%current-target-system)
-                 (list this-package)
-                 '())
-             (list patchelf unzip)))
-    (supported-systems '("x86_64-linux" "aarch64-linux"))
-    (home-page "https://grafana.com/oss/alloy-opentelemetry-collector/")
-    (synopsis
-     "OpenTelemetry Collector distribution with programmable pipelines")
-    (description
-     "Grafana Alloy is an open source OpenTelemetry Collector distribution with
+                           native-inputs
+                           outputs)
+                       "bin/alloy")))
+                 (for-each
+                  (match-lambda
+                    ((shell . file)
+                     (mkdir-p (in-vicinity #$output (dirname file)))
+                     (with-output-to-file (in-vicinity #$output file)
+                       (lambda ()
+                         (invoke alloy "completion" shell)))))
+                  '(("bash" . "share/bash-completion/completions/alloy")
+                    ("fish" . "share/fish/vendor_completions.d/alloy.fish")
+                    ("zsh"  . "share/zsh/site-functions/_alloy")))))))))
+     (native-inputs
+      (append (if (%current-target-system)
+                  (list this-package)
+                  '())
+              (list patchelf unzip)))
+     (supported-systems '("x86_64-linux" "aarch64-linux"))
+     (home-page "https://grafana.com/oss/alloy-opentelemetry-collector/")
+     (synopsis
+      "OpenTelemetry Collector distribution with programmable pipelines")
+     (description
+      "Grafana Alloy is an open source OpenTelemetry Collector distribution with
 built-in Prometheus pipelines and support for metrics, logs, traces, and
 profiles.")
-    (license license:agpl3)
-    (properties '((disable-updater? . #t)))))
+     (license license:agpl3))))
 
 (define-deprecated-package alloy-bin-aarch64-linux alloy-bin)

modules/rosenthal/packages/emacs-xyz.scm

@@ -82,6 +82,28 @@ end the search.  Moreover, the search status information in the echo area and
 some keybindings are slightly simplified.")
     (license license:gpl3+)))
 
+(define-public emacs-kdl-mode
+  (let ((commit "2d849e298199f490e4894c01764a8a83decd704a")
+        (revision "0"))
+    (package
+      (name "emacs-kdl-mode")
+      (version (git-version "0.0.1" revision commit))
+      (source (origin
+                (method git-fetch)
+                (uri (git-reference
+                       (url "https://github.com/taquangtrung/emacs-kdl-mode")
+                       (commit commit)))
+                (file-name (git-file-name name version))
+                (sha256
+                 (base32
+                  "18va5ipay9grbv84kwq9ji4dn1sabnzydj4hb1mjd9mbbibw1wg4"))))
+      (build-system emacs-build-system)
+      (arguments (list #:tests? #f))    ;No tests.
+      (home-page "https://github.com/taquangtrung/emacs-kdl-mode")
+      (synopsis "Emacs major mode for editing files in the KDL document language")
+      (description "")
+      (license license:gpl3+))))
+
 (define-public emacs-pcmpl-tailscale
   (let ((commit "acd6bce54af506b0450cf6aa1068f63d4e25c8ce")
         (revision "0"))

modules/rosenthal/services/desktop.scm

@@ -74,7 +74,6 @@
             home-waybar-configuration
             home-waybar-service-type
 
-            %rosenthal-set-keymap
             %rosenthal-skeletons
             %rosenthal-desktop-services/gdm
             %rosenthal-desktop-services/tuigreet
@@ -551,116 +550,6 @@ gtk-key-theme-name = ~a~%"
 ;;; Configuration file presets.
 ;;;
 
-(define %rosenthal-set-keymap-script
-  (program-file "set-keymap"
-    (with-imported-modules (source-module-closure '((guix build utils)))
-      #~(begin
-          (use-modules (srfi srfi-1)
-                       (srfi srfi-26)
-                       (srfi srfi-37)
-                       (ice-9 match)
-                       (ice-9 popen)
-                       (guix build utils))
-
-          (define* (build-keyboard-layout file layout #:optional variant #:key model options)
-            (define pipe
-              (apply open-pipe* OPEN_READ
-                     #$(file-append console-setup "/bin/ckbcomp")
-                     (string-append "-I" #$xkeyboard-config "/share/X11/xkb")
-                     "-rules" "base"
-                     `(,@(if model
-                             '("-model" ,model)
-                             '())
-                       ,layout
-                       ,(or variant "")
-                       ,(string-join options ","))))
-            (mkdir-p (dirname file))
-            (call-with-output-file file
-              (lambda (output)
-                (dump-port pipe output))))
-
-          (define* (set-keyboard-layout layout #:optional variant #:key model options)
-            (define file-name
-              (port-filename
-               (mkstemp "/tmp/console-keymap.XXXXXX")))
-            (build-keyboard-layout file-name layout variant #:model model #:options options)
-            (invoke "sudo" #$(file-append kbd "/bin/loadkeys") file-name)
-            (false-if-exception
-             (substitute*
-                 (in-vicinity
-                  (if (zero? (getuid))
-                      "/home/live/.config"
-                      (getenv "XDG_CONFIG_HOME"))
-                  "niri/config.kdl")
-               (("^            (layout|variant|model|options) .*") "")
-               (("^        xkb \\{.*" line)
-                (string-append
-                 line
-                 (format             #f "            layout ~s~%"  layout)
-                 (if variant (format #f "            variant ~s~%" variant) "")
-                 (if model   (format #f "            model ~s~%"   model)   "")
-                 (format             #f "            options ~s~%" (string-join options ",")))))))
-
-          (define (show-help-and-exit)
-            (display "\
-Usage: set-keymap LAYOUT [VARIANT] [-m MODEL] [-o OPTIONS]
-
-OPTIONS are comma-separated e.g. \"ctrl:nocaps,grp:alt_shift_toggle\"
-
-Examples:
-set-keymap us
-set-keymap us dvorak
-set-keymap us dvorak -o ctrl:nocaps\n")
-            (quit))
-
-          (define (parse-options)
-            (args-fold (cdr (program-arguments))
-                       (list (option '(#\m "model") #t #f
-                                     (lambda (opt name arg result)
-                                       (alist-cons 'model arg result)))
-                             (option '(#\o "options") #t #f
-                                     (lambda (opt name arg result)
-                                       (alist-cons 'options (string-split arg #\,)
-                                                   result)))
-                             (option '("help") #f #f
-                                     (lambda _
-                                       (show-help-and-exit))))
-                       (lambda (opt name arg loads)
-                         (error "Unrecognized option `~A'" name))
-                       (lambda (opt loads) (cons opt loads))
-                       '()))
-
-          (let* ((opts (parse-options))
-                 (model (assoc-ref opts 'model))
-                 (options (or (assoc-ref opts 'options) '()))
-                 (args (remove pair? (reverse opts))))
-            (match args
-              ((layout)
-               (set-keyboard-layout layout #:model model #:options options))
-              ((layout variant)
-               (set-keyboard-layout layout variant #:model model #:options options))
-              (_
-               (show-help-and-exit))))))))
-
-(define %rosenthal-set-keymap
-  (hidden-package
-   (package
-     (name "rosenthal-set-keymap")
-     (version "0.0.0")
-     (source %rosenthal-set-keymap-script)
-     (build-system copy-build-system)
-     (arguments
-      (list
-       #:phases
-       #~(modify-phases %standard-phases
-           (replace 'install
-             (lambda _
-               (install-file "set-keymap" (in-vicinity #$output "bin")))))))
-     (home-page "")
-     (synopsis "")
-     (description "")
-     (license #f))))
-
 (define %rosenthal-skeletons
   `((".config/emacs/init.el"
      ,(local-file "../examples/emacs/init.el"))

modules/rosenthal/utils/packages.scm

@@ -11,10 +11,13 @@
   #:use-module (guix deprecation)
   #:use-module (guix diagnostics)
   #:use-module (guix discovery)
+  #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (guix memoization)
   #:use-module (guix packages)
+  #:use-module (guix platform)
   #:use-module (guix ui)
+  #:use-module (guix utils)
   ;; Guix packages
   #:use-module (gnu packages)
   #:use-module (gnu packages base)
@@ -32,7 +35,9 @@
             specs->pkgs
             specs->pkgs+out
 
-            %binary-source))
+            %binary-source
+            binary-package
+            mapping-for-system))
 
 (define %rosenthal-root-directory
   ;; This is like %distro-root-directory from (gnu packages), with adjusted
@@ -145,4 +150,33 @@ packages, excluding superseded packages."
   (hidden-package
    (package
      (inherit hello)
-     (supported-systems '()))))
+     (supported-systems '())
+     (home-page "")
+     (synopsis "Binary package source (internal use)")
+     (description "")
+     (license #f))))
+
+(define* (mapping-for-system mapping #:optional (default-system "x86_64-linux"))
+  (let ((system
+         (or (and=> (%current-target-system) platform-target->system)
+             (%current-system))))
+    (or (assoc-ref mapping system)
+        (assoc-ref mapping default-system))))
+
+(define* (binary-package source-mapping p #:optional (default-system "x86_64-linux"))
+  (package
+    (inherit p)
+    (version (package-version (assoc-ref source-mapping default-system)))
+    (source #f)
+    (arguments
+     (substitute-keyword-arguments (package-arguments p)
+       ((#:phases phases #~%standard-phases)
+        #~(modify-phases #$phases
+            (replace 'unpack
+              (lambda _
+                ((assoc-ref %standard-phases 'unpack)
+                 #:source
+                 #+(package-source (mapping-for-system source-mapping)))))))))
+    (properties
+     (cons '(disable-updater? . #t)
+           (package-properties p)))))