phrenetic.org

#+TITLE: Phrenetic
#+PROPERTY: header-args :mkdirp yes

* Phrenetic
:PROPERTIES:
:meta-dir+: phrenetic
:END:
** Install
:PROPERTIES:
:header-args+: :tangle (meta-in-dir "install.scm")
:END:
Run with ~sudo~.
#+begin_src scheme
(define-module (phrenetic install)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module ((gnu packages cryptsetup) #:select (cryptsetup))
  #:use-module ((gnu packages disk) #:select (dosfstools parted))
  #:use-module ((gnu packages linux) #:select (btrfs-progs util-linux))
  #:use-module ((gnu packages package-management) #:select (guix))
  #:use-module (phrenetic utils)
  #:export (installer-package))
#+end_src
*** Package
#+begin_src scheme
(define* (installer-package #:rest opts)
  (package
    (inherit simple-package)
    (name "installer")
    (source (apply installer-program opts))
    (arguments
     `(#:builder
       ,#~(begin
            (let ((bin (string-append #$output "/bin")))
              (mkdir #$output)
              (mkdir bin)
              (symlink #$source (string-append bin "/install"))))))))
#+end_src
*** Program
#+begin_src scheme
(define* (installer-program #:key
                            os-name
                            efi?
                            boot-label
                            boot-target
                            root-label
                            disk-encryption?
                            luks-label
                            filesystem
                            mountables
                            btrfs-mount-flags
                            btrfs-mount-options)
  (program-file
   "installer"
   (with-imported-modules '((guix build utils))
     #~(begin
         (use-modules ((guix build utils) #:select (invoke mkdir-p))
                      ((ice-9 match) #:select (match-lambda))
                      ((ice-9 readline) #:select (readline))
                      ((ice-9 string-fun) #:select (string-replace-substring)))

         (define* (cmd command #:rest args)
           (display (string-join (cons (basename command) args)))
           (newline)
           (apply invoke (cons command args)))

         (define* (read-user-input prompt #:key default)
           (let ((input (readline (string-append prompt
                                                 (if default
                                                     (string-append " (default " default ")") "")
                                                 ": "))))
             (if (string-null? input)
                 (or default (exit))
                 input)))

         (define (user-pause text)
           (readline (string-append text " Press enter to continue.")))

         (define (display-block-devices)
           (display "Block devices:")
           (newline)
           (invoke #$(file-append util-linux "/bin/lsblk"))
           (newline))

         (display-block-devices)
         (define device
           (read-user-input "Enter device (for exmple, /dev/sda)"))

         (let ((parted-bin #$(file-append parted "/sbin/parted"))
               (align "optimal")
               (boot-size "1GB"))
           (cmd parted-bin device "mklabel" "gpt")
           (for-each (match-lambda
                       ((label start end)
                        (cmd parted-bin "--align" align device "mkpart" label start end)))
                     `(("sky" "0%" ,boot-size)
                       ("earth" ,boot-size "100%")))
           (cmd parted-bin device "set" "1" (if #$efi? "esp" "bios_grub") "on")
           (for-each (lambda (n)
                       (cmd parted-bin device "align-check" align n))
                     '("1" "2")))
         (user-pause "Check that disks are aligned.")

         (display-block-devices)
         (define boot-partition
           (read-user-input (string-append "Boot partition")
                            #:default (string-append device "1")))
         (define root-partition
           (read-user-input (string-append "Root partition")
                            #:default (string-append device "2")))

         (cmd #$(file-append dosfstools "/sbin/mkfs.fat") "-F" "32" "-n" #$boot-label boot-partition)

         (define system-root
           (if #$disk-encryption?
               (let* ((crypt-name "deciphered-new")
                      (crypt-mapping (string-append "/dev/mapper/" crypt-name))
                      (cryptsetup-bin #$(file-append cryptsetup "/bin/cryptsetup")))
                 (cmd cryptsetup-bin "luksFormat" "--type" "luks2" "--pbkdf" "pbkdf2" "--label" #$luks-label root-partition)
                 (cmd cryptsetup-bin "open" root-partition crypt-name)
                 crypt-mapping)
               root-partition))

         (case #$filesystem
           ;; ((#:filesystem/ext4)
           ;;  (cmd #$(file-append e2fsprogs "/sbin/mkfs.ext4") "-L" #$root-label system-root))
           ((#:filesystem/btrfs)
            (cmd #$(file-append btrfs-progs "/bin/mkfs.btrfs") "--label" #$root-label system-root)))

         (define mount-dir
           (read-user-input (string-append "Mount directory")
                            #:default "/mnt"))

         (define mount-bin "/run/privileged/bin/mount")
         (define umount-bin "/run/privileged/bin/umount")

         (when (equal? #$filesystem #:filesystem/btrfs)
           (let ((btrfs-bin #$(file-append btrfs-progs "/bin/btrfs")))
             (cmd mount-bin system-root mount-dir)
             (for-each (match-lambda
                         ((subvol . _)
                          (cmd btrfs-bin "subvolume" "create" (string-append mount-dir "/" subvol))))
                       '#$mountables)
             (cmd umount-bin mount-dir)))

         (case #$filesystem
           ;; ((#:filesystem/ext4)
           ;;  (cmd mount-bin system-root mount-dir))
           ((#:filesystem/btrfs)
            (for-each
             (match-lambda
               ((subvol . mount-point)
                (let ((path-on-mount (string-append mount-dir mount-point)))
                  (mkdir-p path-on-mount)
                  (cmd mount-bin "-o"
                       (string-append
                        "subvol=" subvol
                        (let ((opts (append
                                     (or '#$btrfs-mount-options '())
                                     (map (lambda (flag)
                                            (string-replace-substring (symbol->string flag) "-" ""))
                                          (or '#$btrfs-mount-flags '())))))
                          (if (null? opts)
                              ""
                              (string-append "," (string-join opts ",")))))
                       system-root path-on-mount))))
             '#$mountables)))
         (let ((boot-target-on-mount (string-append mount-dir #$boot-target)))
           (mkdir-p boot-target-on-mount)
           (cmd mount-bin boot-partition boot-target-on-mount))

         (let ((source-dir "/etc/config-source")
               (configs-dir "phrenetic/configs"))
           (cmd #$(file-append guix "/bin/guix") "time-machine"
                (string-append "--channels=" source-dir "/" configs-dir "/" os-name "-channels-lock")
                "--"
                "system"
                (string-append "--load-path=" source-dir)
                "init"
                (string-append source-dir "/" configs-dir "/" #$os-name)
                mount-dir))

         (cmd umount-bin (string-append mount-dir #$boot-target))
         (case #$filesystem
           ;; ((#:filesystem/ext4)
           ;;  (cmd umount-bin mount-dir))
           ((#:filesystem/btrfs)
            (for-each (match-lambda
                        ((_ . mount-point)
                         (cmd umount-bin (string-append mount-dir mount-point))-point))
                      '#$mountables)))))))
#+end_src
** System
:PROPERTIES:
:header-args+: :tangle (meta-in-dir "system.scm")
:END:
#+begin_src scheme
(define-module (phrenetic system)
  #:use-module ((guix modules) #:select (source-module-closure))
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module ((guix store) #:select (%default-substitute-urls))
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader grub)
  #:use-module ((gnu build accounts) #:select (%password-lock-file))
  #:use-module ((gnu packages bash) #:select (bash))
  #:use-module ((gnu packages base) #:select (coreutils))
  #:use-module ((gnu packages firmware) #:select (ath9k-htc-ar7010-firmware ath9k-htc-ar9271-firmware openfwwf-firmware))
  #:use-module ((gnu packages freedesktop) #:select (elogind libinput-minimal switchd))
  #:use-module ((gnu packages fonts) #:select (font-terminus))
  #:use-module ((gnu packages haskell-apps) #:select (kmonad))
  #:use-module ((gnu packages hyprland) #:select (hyprlock))
  #:use-module ((gnu packages libusb) #:select (libmtp))
  #:use-module ((gnu packages linux) #:select (brightnessctl customize-linux e2fsprogs kbd linux-libre util-linux))
  #:use-module ((gnu packages nfs) #:select (nfs-utils))
  #:use-module ((gnu packages shells) #:select (zsh))
  #:use-module ((gnu packages wm) #:select (swaylock swaylock-effects))
  #:use-module (gnu services)
  #:use-module (gnu services admin)
  #:use-module (gnu services avahi)
  #:use-module (gnu services base)
  #:use-module (gnu services dbus)
  #:use-module (gnu services desktop)
  #:use-module (gnu services games)
  #:use-module ((gnu services linux) #:select (zram-device-service-type zram-device-configuration))
  #:use-module (gnu services networking)
  #:use-module (gnu services nix)
  #:use-module (gnu services shepherd)
  #:use-module ((gnu services sound) #:select (alsa-service-type pipewire-service-type pipewire-configuration pulseaudio-service-type))
  #:use-module (gnu services sysctl)
  #:use-module ((gnu services xorg) #:select (gdm-service-type gdm-configuration screen-locker-service-type screen-locker-configuration))
  #:use-module (gnu services virtualization)
  #:use-module (gnu system)
  #:use-module (gnu system accounts)
  #:use-module (gnu system file-systems)
  #:use-module ((gnu system privilege) #:select (privileged-program))
  #:use-module ((gnu system shadow) #:select (account-service-type))
  #:use-module (gnu system mapped-devices)
  #:use-module ((rde gexp) #:select (slurp-file-like))
  #:use-module (rde system services networking)
  #:use-module (phrenetic modules)
  #:use-module ((phrenetic stateless) #:prefix stateless:)
  #:use-module (phrenetic utils)
  #:use-module ((ice-9 match) #:select (match match-lambda))
  #:use-module ((ice-9 string-fun) #:select (string-replace-substring))
  #:use-module ((srfi srfi-1) #:select (append-map delete-duplicates first remove iota))
  #:export (blank-os
            system-comp
            define-system-comp
            base-services
            classic-login
            greetd-login
            accounts
            guix-pm
            public-key-serialize
            nix-pm
            kmonad-tool
            desktop-base-services
            classic-media
            pipewire-media
            network-manager
            bluetooth
            gdm
            desktop-tty
            gnome-desktop
            sway-wm
            host-info
            ext4
            btrfs
            tmpfs
            disk-encryption
            swap
            zram-swap
            zswap
            stateless
            linux-libre-kernel
            linux-with-customizations
            grub-efi-boot
            virtualization
            console-keyboard-layouts
            console-fonts
            os-base))

(define %random-seed-file (@@ (gnu services base) %random-seed-file))
#+end_src
*** Create
#+begin_src scheme
(define blank-os
  (operating-system
    (host-name #f)
    (bootloader (bootloader-configuration
                 (bootloader #f)))
    (firmware (remove (lambda (p)
                        (member p (list ath9k-htc-ar7010-firmware
                                        ath9k-htc-ar9271-firmware
                                        openfwwf-firmware)))
                      %base-firmware))
    (services '())
    (file-systems %base-file-systems)))
#+end_src
*** Components
#+begin_src scheme
(define-syntax-rule (system-comp os field ...)
  (operating-system
    (inherit os)
    field ...))

(define-syntax define-system-comp
  (lambda (x)
    (syntax-case x ()
      ((_ (name arg ...) field ...)
       (with-syntax ((os (datum->syntax x 'os)))
         #'(define* (name os arg ...)
             (system-comp os field ...)))))))
#+end_src
**** Base services
#+begin_src scheme
(define-system-comp (base-services #:key stateless?)
  (services
   (append
    (operating-system-user-services os)
    (list (service virtual-terminal-service-type)
          (service syslog-service-type)
          (service static-networking-service-type
                   (list %loopback-static-networking))
          (service urandom-seed-service-type)
          (service nscd-service-type)
          (service rottlog-service-type)
          (service udev-service-type)
          (service sysctl-service-type)
          (service special-files-service-type
                   `(("/bin/sh" ,(file-append bash "/bin/sh"))
                     ("/usr/bin/env" ,(file-append coreutils "/bin/env")))))
    (if stateless?
        (list
         (stateless-service
          'base-services
          #:state `(((#:path . ,%random-seed-file)
                     (#:storage . #:storage/machine))
                    ((#:path . "/var/db/nscd/")
                     (#:storage . #:storage/machine))
                    ((#:path . "/var/lib/rottlog/")
                     (#:storage . #:storage/machine)))
          #:ignore '(((#:path . "/etc/resolv.conf"))
                     ((#:path . "/etc/resolv.conf.bak"))
                     ((#:path . "/bin/sh")
                      (#:preds . ((#:symlink-to-store))))
                     ((#:path . "/usr/bin/env")
                      (#:preds . ((#:symlink-to-store)))))))))))
#+end_src
**** Login
***** Classic
#+begin_src scheme
(define-system-comp (classic-login #:key number-of-ttys)
  (services
   (append
    (operating-system-user-services os)
    (list (service login-service-type)
          (service agetty-service-type (agetty-configuration
                                        (extra-options '("-L"))
                                        (term "vt100")
                                        (tty #f)
                                        (shepherd-requirement '(syslogd)))))
    (map (lambda (n)
           (service mingetty-service-type (mingetty-configuration
                                           (tty (string-append "tty" (number->string n))))))
         (iota number-of-ttys 1)))))
#+end_src
***** Greetd
#+begin_src scheme
(define-system-comp (greetd-login #:key number-of-ttys)
  (services
   (cons* (service greetd-service-type
                   (greetd-configuration
                    (terminals
                     (map (lambda (n)
                            (greetd-terminal-configuration
                             (terminal-vt (number->string n))))
                          (iota number-of-ttys 1)))))
          (operating-system-user-services os))))
#+end_src
**** Accounts
#+begin_src scheme
(define-system-comp (accounts #:key who)
  (services
   (cons* (service accounts-service-type
                   (map (lambda (user)
                          (apply account (alist->list user)))
                        who))
          (operating-system-user-services os))))

(define* (account #:key
                  name
                  comment
                  shell
                  admin?)
  (user-account
   (name name)
   (comment (or comment ""))
   (group "users")
   (supplementary-groups (if admin? '("wheel") '()))
   (shell (case shell
            ((#:shell/bash) (file-append bash "/bin/bash"))
            ((#:shell/zsh) (file-append zsh "/bin/zsh"))))))
#+end_src
***** Service
#+begin_src scheme
(define accounts-service-type
  (service-type (name 'accounts-servce)
                (extensions
                 (list (service-extension account-service-type
                                          identity)))
                (compose identity)
                (extend (lambda (accounts groups)
                          (map (lambda (account)
                                 (account-with-groups account groups))
                               accounts)))
                (description "Add user accounts and extend them with supplementary groups.")))

(define (account-with-groups account groups)
  (user-account
   (inherit account)
   (supplementary-groups (-> (user-account-supplementary-groups account)
                             (append (->> groups
                                          (filter (match-lambda
                                                    ((users . _)
                                                     (member (user-account-name account) users))))
                                          (append-map (match-lambda
                                                        ((_ . groups) groups)))))
                             delete-duplicates))))
#+end_src
**** Package management
***** Guix
#+begin_src scheme
(define-system-comp (guix-pm #:key
                             authorized-keys
                             substitute-urls
                             (dev? #t)
                             stateless?)
  (services
   (append
    (operating-system-user-services os)
    (list
     (service guix-service-type
              (guix-configuration
               (authorized-keys (append
                                 %default-authorized-guix-keys
                                 (or authorized-keys '())))
               (substitute-urls (append
                                 %default-substitute-urls
                                 (or substitute-urls '())))
               (extra-options (if dev?
                                   (list "--gc-keep-derivations=yes"
                                         "--gc-keep-outputs=yes")
                                   '()))))
     (service log-cleanup-service-type
              (log-cleanup-configuration
               (directory "/var/log/guix/drvs"))))
    ;; TODO Should these (at least e.g. "/var/guix") be in Stateless > Guix System? Update: or in both places?
    (if stateless?
        (list
         (stateless-service
          'guix-pm
          #:state '(((#:path . "/etc/guix/signing-key.pub")
                     (#:storage . #:storage/machine)
                     (#:parent-dir-perms . ((#:mode . #o111))))
                    ((#:path . "/etc/guix/signing-key.sec")
                     (#:storage . #:storage/machine)
                     (#:parent-dir-perms . ((#:mode . #o111)))))
          #:ignore `(;((#:path . "/gnu/store/")) ; TODO inscrutable error on system build: "guix system: error: path `/gnu/store/' is not in the store"
                     ((#:path . "/var/guix/"))
                     ((#:path . "/etc/guix/acl")
                      (#:preds . ((#:symlink-to-store))))
                     ((#:path . ,(string-append (user-account-home-directory %root-account) "/.cache/guix/"))))))
        '()))))

(define (public-key-serialize pk)
  (let ((sexp `(public-key
                ,(case (assoc-ref pk #:public-key/type)
                   ((#:public-key.type/ecc)
                    `(ecc
                      (curve ,(assoc-ref pk #:public-key.ecc/curve))
                      (q ,(around (assoc-ref pk #:public-key.ecc/q) "#"))))
                   ;; ...
                   ))))
    (call-with-output-string
      (lambda (port)
        (display sexp port)))))
#+end_src
***** Nix
#+begin_src scheme
(define-system-comp (nix-pm #:key stateless?)
  (services
   (append
    (operating-system-user-services os)
    (list
     (service (without-profile-extension nix-service-type)
              (nix-configuration
               (extra-config (if stateless?
                                 (list
                                  (nix-conf-serialize '((allow-symlinked-store . #t))))
                                 '()))))
     (service log-cleanup-service-type
              (log-cleanup-configuration
               (directory "/nix/var/log/nix/drvs"))))
    (if stateless?
        (list
         (stateless-service
          'nix-pm
          #:state '(((#:path . "/nix/store/")
                     (#:storage . #:storage/machine))
                    ((#:path . "/nix/var/nix/")
                     (#:storage . #:storage/machine))
                    ((#:path . "/nix/var/log/nix/")
                     (#:storage . #:storage/machine)))
          #:ignore `(((#:path . ,(string-append (user-account-home-directory %root-account) "/.cache/nix/"))))))
        '()))))

(define (nix-conf-serialize config)
  (apply string-append
         (append-map (match-lambda
                       ((n . v)
                        (list (symbol->string n)
                              " = "
                              (match v
                                (#t "true")
                                (#f "false")
                                ;; ((lst ...) (string-join lst))
                                (v v))
                              "\n")))
                     config)))
#+end_src
**** Console
***** KMonad :upstream:
#+begin_src scheme
(define-system-comp (kmonad-tool #:key
                                 users
                                 kmonad)
  (services
   (append
    (operating-system-user-services os)
    (let ((groups '("uinput" "input")))
      (list
       (simple-service 'kmonad-users-add-groups
                       accounts-service-type
                       (cons users groups))
       (udev-rules-service 'kmonad-add-udev-rules
                           kmonad
                           ;; The input group is already part of %base-groups so we don't have to add it here. More importantly, if we do Guix issues a warning on build "guix system: warning: the following groups appear more than once: input" and I don't think it's dangerous but let's just be safe.
                           #:groups (delete "input" groups)))))))
#+end_src
**** Desktop
***** Base services
#+begin_src scheme
(define-system-comp (desktop-base-services #:key
                                           avahi-users
                                           stateless?)
  (services
   (append
    (operating-system-user-services os)
    (list (simple-service 'libinput udev-service-type (list libinput-minimal))
          (simple-service 'mtp udev-service-type (list libmtp))
          (service sane-service-type)
          polkit-wheel-service
          (simple-service 'nfs-mount-privileged privileged-program-service-type
                          (list (privileged-program
                                 (program (file-append nfs-utils "/sbin/mount.nfs"))
                                 (setuid? #t))))
          fontconfig-file-system-service ; TODO Make a dedicated component for this so the Home fonts component has an analogue in System?
          (service udisks-service-type)
          ;; (service accountsservice-service-type)
          (service cups-pk-helper-service-type)
          (service colord-service-type)
          (service geoclue-service-type)
          (service polkit-service-type)
          (service rtkit-service-type)
          (service dbus-root-service-type)
          (service ntp-service-type)
          (service x11-socket-directory-service-type) ; TODO Gate this, only necessary for wayland with xwayland. In fact, determine if it's necessary at all or, ideally, if something equivalent can be done at the user level.
          ;; TODO Probably doesn't belong in desktop-base-services, sticking it here for the moment.
          ;; TODO Could this be home service instead (except for the udev rules part of course)? Does the daemon need to udev/system-y stuff?
          (service joycond-service-type))
    (avahi-services #:users avahi-users)
    (if stateless?
        (list
         (stateless-service
          'desktop-base-services
          #:state '(((#:path . "/etc/machine-id")
                     (#:storage . #:storage/machine))
                    ;; ((#:path . "/var/lib/AccountsService/")
                    ;;  (#:storage . #:storage/machine))
                    ;; ((#:path . "/var/lib/colord/")
                    ;;  (#:storage . #:storage/machine))
                    ;; ((#:path . "/var/lib/udisks2/")
                    ;;  (#:storage . #:storage/machine))
                    )
          #:ignore `(((#:path . ,(string-append (file-system-mount-point %fontconfig-file-system) "/"))
                      (#:preds . ((#:empty-dir)))))))
        '()))))

(define* (avahi-services #:key users)
  (let ((group "avahi-users"))
    (list
     (service avahi-service-type
              (avahi-configuration
               (dbus-privileged-group group)))
     (simple-service 'avahi-groups
                     account-service-type
                     (list (user-group (name group) (system? #t))))
     (simple-service 'avahi-users-add-groups
                     accounts-service-type
                     (cons users (list group))))))
#+end_src
***** Power
****** Upower
Ideally Upower would allow providing a program/script to run as the ~critical-power-action~ but it's hardcoded to talk to logind (over dbus).
#+begin_src scheme
(define-system-comp (upower-power #:key stateless?)
  (services
   (append
    (operating-system-user-services os)
    (list
     (service upower-service-type
              (upower-configuration
               ;; The defaults are quite low, set them higher. In particular `percentage-action' is 2 which isn't a lot of battery to have in reserve.
               (percentage-low 30)
               (percentage-critical 15)
               (percentage-action 10)
               (critical-power-action 'hybrid-sleep)))) ; This is the default but let's be explicit.
    (if stateless?
        (list
         (stateless-service
          'upower
          #:state '(((#:path . "/var/lib/upower/")
                     (#:storage . #:storage/machine)))))
        '()))))
#+end_src
***** Media
****** Classic
#+begin_src scheme
(define-system-comp (classic-media)
  (services
   (append
    (operating-system-user-services os)
    (list (service pulseaudio-service-type)
          (service alsa-service-type)))))
#+end_src
****** Pipewire
#+begin_src scheme
(define-system-comp (pipewire-media #:key
                                    pipewire
                                    users)
  (services
   (append
    (operating-system-user-services os)
    (list
     (service pipewire-service-type
              (pipewire-configuration
               (pipewire pipewire)))
     (simple-service 'pipewire-users-add-groups
                     accounts-service-type
                     (cons users (list "pipewire")))))))
#+end_src
***** Network
****** Network manager
#+begin_src scheme
(define-system-comp (network-manager #:key
                                     (wireless #:wireless/iwd)
                                     wireless-users
                                     stateless?)
  (services
   (append
    (operating-system-user-services os)
    (list
     (service network-manager-service-type
              (network-manager-configuration
               (shepherd-requirement (if wireless
                                         (case wireless
                                           ((#:wireless/wpa-supplicant) '(wpa-supplicant))
                                           ((#:wireless/iwd) '(iwd)))
                                         '())))))
    (if wireless
        (wireless-services #:wireless wireless
                           #:users wireless-users
                           #:stateless? stateless?)
        '())
    (modem-services)
    (if stateless?
        (list
         (stateless-service
          'network-manager
          #:state '(((#:path . "/etc/NetworkManager/system-connections/")
                     (#:storage . #:storage/machine))
                    ((#:path . "/var/lib/NetworkManager/")
                     (#:storage . #:storage/machine)
                     (#:mode . #o700)))))
        '()))))
#+end_src
****** Shared
#+begin_src scheme
(define* (wireless-services #:key
                            wireless
                            users
                            stateless?)
  (case wireless
    ((#:wireless/wpa-supplicant) (list
                                  (service wpa-supplicant-service-type)))
    ((#:wireless/iwd) (iwd-services #:users users
                                    #:stateless? stateless?))))

(define* (iwd-services #:key
                       users
                       stateless?)
  (append
   (let ((group "iwd-users"))
     (list
      (service iwd-service-type
               (iwd-configuration
                (main-conf
                 '((Settings ((AutoConnect . #t)))))
                (dbus-users-group group)))
      (simple-service 'iwd-groups
                      account-service-type
                      (list (user-group (name group) (system? #t))))
      (simple-service 'iwd-users-add-groups
                      accounts-service-type
                      (cons users (list group)))))
   (if stateless?
       (list
        (stateless-service
         'iwd
         #:state '(((#:path . "/var/lib/iwd")
                    (#:storage . #:storage/machine)
                    (#:mode . #o700)))))
       '())))

(define (modem-services)
  (list (service modem-manager-service-type)
        (service usb-modeswitch-service-type)))
#+end_src
***** Bluetooth
#+begin_src scheme
(define-system-comp (bluetooth #:key stateless?)
  (services
   (append
    (operating-system-user-services os)
    (list
     (service bluetooth-service-type
              (bluetooth-configuration
               (auto-enable? #t))))
    (if stateless?
        (list
         (stateless-service
          'bluetooth
          #:state '(((#:path . "/var/lib/bluetooth/")
                     (#:storage . #:storage/machine)
                     (#:mode . #o700)))))
        '()))))
#+end_src
***** ACPI
****** Switchd
#+begin_src scheme
(define-system-comp (switchd-acpi)
  (services
   (cons* (simple-service
           'switchd
           shepherd-root-service-type
           (list (switchd-shepherd-service)))
          (operating-system-user-services os))))

(define (switchd-shepherd-service)
  (let ((events->commands
         `((power-button . ,suspend-program)
           ;; (restart-button . ...)
           ;; (sleep-button . ...)
           ;; (suspend-button . ...)
           (lid-closed . ,suspend-program)
           ;; (lid-opened . ...)
           ;; (dock-attached . ...)
           ;; (dock-detached . ...)
           )))
    (shepherd-service
     (provision '(switchd))
     (requirement '(udev)) ; Requires '/dev/input' be populated.
     (respawn? #t) ; switchd exits when devices disappear and expects to be restarted when this happens, thus explicitly set respawning to true (even though that's already the default value).
     (start #~(make-forkexec-constructor
               (cons #$(file-append switchd "/bin/switchd")
                     '#$(alist->list
                         (update-keys events->commands
                                      (lambda (event)
                                        (-> event
                                            symbol->string
                                            (string-replace-substring  "-" "_"))))))
               #:log-file "/var/log/switchd.log"))
     (stop #~(make-kill-destructor)))))

(define suspend-program
  (program-file
   "suspend"
   (with-imported-modules '((guix build utils))
     #~(begin
         (use-modules ((guix build utils) #:select (invoke)))
         ;; TODO For now I'm using the loginctl (elogind) command to implement suspending which presumably will break if I switch seat managers. Figure out a generic alternative (pm-utils...).
         (invoke #$(file-append elogind "/bin/loginctl") "suspend")))))
#+end_src
***** Seat management
****** Elogind
Configure elogind to do as little as possible:
- seat manger flexbility
  Make it easier to switch between seat managers.
- enable using dedicated tools
  "Do one thing well". Supplant elogind functionality with other programs that can be customized or swapped out.
- systemd is too opinionated
  And elogind inherits this characteristic. There's some consensus about this in the Linux community. Even the default settings can err on the side of too aggressive so don't feel bad ignoring them.
There are considerably more options that to pare down / disable (see documentation for =loginctl.conf= and =sleep.conf=) not done yet. It's a headache and Guix doesn't even have fields for all of them in elogind-configuration at the moment (in particular options added in newer versions of elogind seem like they were neglected).
#+begin_src scheme
(define-system-comp (elogind-seats)
  (services
   (cons* (service elogind-service-type
                   (elogind-configuration
                    (kill-user-processes? #f) ; Guix default but state explicitly.
                    ;; (inhibit-delay-max-seconds 0) ; Find/implement an inhibitor lock system / PrepareForSleep + PrepareForShutdown DBus API before disabling this functionality in elogind.
                    (holdoff-timeout-seconds 0)
                    (idle-action 'ignore) ; Guix default but state explicitly.
                    (runtime-directory-size-percent 100) ; "Clearing" this field might be better but elogind-configuration validates that it's a number.
                    (remove-ipc? #f)

                    ;; Ignore all ACPI.
                    (handle-power-key                 'ignore)
                    (handle-suspend-key               'ignore)
                    (handle-hibernate-key             'ignore)
                    (handle-lid-switch                'ignore)
                    (handle-lid-switch-docked         'ignore)
                    (handle-lid-switch-external-power 'ignore)))
          (operating-system-user-services os))))
#+end_src
****** Seatd
#+begin_src scheme
(define-system-comp (seatd-seats #:key users)
  (services
   (append
    (operating-system-user-services os)
    (let ((group "seat"))
      (list
       (service seatd-service-type
                (seatd-configuration
                 (group group)))
       (simple-service 'seatd-users-add-groups
                       accounts-service-type
                       (cons users (list group))))))))
#+end_src
***** Login management
****** Login managers
******* GDM
#+begin_src scheme
(define-system-comp (gdm #:key
                         wayland?
                         auto-login?
                         auto-login-user
                         stateless?)
  (services
   (append
    (operating-system-user-services os)
    (list
     (service gdm-service-type
              (gdm-configuration
               (auto-login? auto-login?)
               (default-user auto-login-user)
               (wayland? wayland?)))
     gdm-file-system-service)
    (if stateless?
        (list
         (stateless-service
          'gdm
          #:ignore `(((#:path . ,(string-append (file-system-mount-point %gdm-file-system) "/"))))))
        '()))))
#+end_src
****** Desktop TTY
- TODO only run switch-to-tty-service on startup
  Currently it's running on reconfigure too so if I'm logged in a different tty it switches away on reconfigure. Options:
  - IIRC there are greetd/mingetty-specific ways of setting the intiial tty
    I like the login-manager-independence of this method but consider those.
  - possibly theshepherd service `transient?` field
#+begin_src scheme
(define-system-comp (desktop-tty #:key
                                 login
                                 (tty-number 2)
                                 auto-login?
                                 auto-login-user)
  (services
   (cons* (switch-to-tty-service #:tty-number tty-number)
          (if auto-login?
              (with-auto-login-to-tty (operating-system-user-services os)
                                      #:login login
                                      #:tty-number tty-number
                                      #:user auto-login-user)
              (operating-system-user-services os)))))

(define* (switch-to-tty-service #:key tty-number)
  (simple-service
   'switch-to-tty
   shepherd-root-service-type
   (list
    (shepherd-service
     (provision '(switch-to-tty))
     (requirement '(virtual-terminal))
     (one-shot? #t)
     (start #~(lambda ()
                (invoke #$(file-append kbd "/bin/chvt")
                        (number->string #$tty-number))))))))

(define* (with-auto-login-to-tty services #:key login tty-number user)
  (case login
    ((#:login/classic)
     (modify-services services
       (mingetty-service-type
        config =>
        (if (equal? (mingetty-configuration-tty config)
                    (string-append "tty" (number->string tty-number)))
            (mingetty-configuration
             (inherit config)
             (auto-login user))
            config))))
    ((#:login/greetd)
     (modify-services services
       (greetd-service-type
        config =>
        (greetd-configuration
         (inherit config)
         (terminals
          (map (lambda (terminal-config)
                 (if (equal? (greetd-terminal-vt terminal-config)
                             (number->string tty-number))
                     (greetd-terminal-configuration
                      (inherit terminal-config)
                      ;; (initial-session-user user)
                      ;; (initial-session-command "default-session-start")
                      )
                     terminal-config))
               (greetd-terminals config)))))))))
#+end_src
***** Sessions
****** Desktop environments
******* GNOME
#+begin_src scheme
(define-system-comp (gnome-desktop)
  (services
   (cons* (service (without-profile-extension gnome-desktop-service-type))
          (operating-system-user-services os))))
#+end_src
****** Window managers
******* Hyprland
#+begin_src scheme
(define-system-comp (hyprland-wm #:key users)
  (services
   (append (operating-system-user-services os)
           (list
            (hyprlock-service))
           (brightnessctl-services #:users users))))
#+end_src
******* Sway
#+begin_src scheme
(define-system-comp (sway-wm #:key
                             users
                             swaylock-effects?
                             swaylock
                             swaylock-effects)
  (services
   (append (operating-system-user-services os)
           (list
            (swaylock-service #:effects? swaylock-effects?
                              #:swaylock swaylock
                              #:swaylock-effects swaylock-effects))
           ;; TODO Omit dup with hyprland
           ;; (brightnessctl-services #:users users)
           )))
#+end_src
******* Pieces
******** Screen lockers
********* Hyprlock
#+begin_src scheme
(define* (hyprlock-service)
  (service screen-locker-service-type
           (screen-locker-configuration
            (name "hyprlock")
            (program (file-append hyprlock "/bin/hyprlock"))
            (allow-empty-password? #t)
            (using-setuid? #f))))
#+end_src
********* Swaylock
#+begin_src scheme
(define* (swaylock-service #:key
                           effects?
                           swaylock
                           swaylock-effects)
  (service screen-locker-service-type
           (screen-locker-configuration
            (name "swaylock")
            (program (file-append (if effects?
                                      swaylock-effects
                                      swaylock)
                                  "/bin/swaylock"))
            (allow-empty-password? #t)
            (using-setuid? #f))))
#+end_src
******** Controls
********* Backlights
********** Brightnessctl
#+begin_src scheme
(define* (brightnessctl-services #:key users)
  (let ((groups '("backlight-brightness"
                  "leds-brightness")))
    (list
     (simple-service 'brightnessctl-users-add-groups
                     accounts-service-type
                     (cons users groups))
     (udev-rules-service 'brightnessctl-add-udev-rules
                         brightnessctl
                         #:groups groups))))
#+end_src
**** Host-specific
***** Host
#+begin_src scheme
(define-system-comp (host-info #:key
                               host-name
                               timezone
                               locale)
  (host-name host-name)
  (timezone (or timezone
                (operating-system-timezone os)))
  (locale (or locale
              (operating-system-locale os))))
#+end_src
***** File systems
****** Ext4
#+begin_src scheme
(define-system-comp (ext4 #:key
                          label
                          mount-point
                          flags
                          options)
  (file-systems
   (cons* (file-system
            (device (file-system-label label))
            (mount-point mount-point)
            (type "ext4")
            (flags (or flags '()))
            (options (alist->file-system-options (or options '()))))
          (operating-system-file-systems os))))
#+end_src
****** Btrfs
#+begin_src scheme
(define-system-comp (btrfs #:key
                           label
                           mounts)
  (file-systems
   (append
    (operating-system-file-systems os)
    (map (lambda (mount)
           (apply btrfs-mount
                  #:label label
                  (alist->list mount)))
         mounts))))

(define* (btrfs-mount #:key
                      label
                      mount-point
                      subvol
                      (flags '(no-atime))
                      (options '(("compress" . "zstd")
                                 "autodefrag")))
  (file-system
    (device (file-system-label label))
    (mount-point mount-point)
    (type "btrfs")
    (flags (or flags '()))
    (options (as-> (or options '()) $
                   (if subvol
                       (acons "subvol" subvol $) $)
                   (alist->file-system-options $)))))
#+end_src
****** Tmpfs
#+begin_src scheme
(define-system-comp (tmpfs #:key
                           mount-point
                           size)
  (file-systems
   (cons* (file-system
            (device "none")
            (mount-point mount-point)
            (options (if size
                         (string-append "size=" (number->string size))
                         #f))
            (type "tmpfs")
            (check? #f))
          (operating-system-file-systems os))))
#+end_src
***** Disk encryption
Must succeed [[*File systems][File systems]] component.
#+begin_src scheme
(define* (disk-encryption os
                          #:key
                          device-uuid
                          (target "deciphered")
                          mount-points)
  (let ((encrypted-device (mapped-device
                           (source (uuid device-uuid))
                           (targets (list target))
                           (type luks-device-mapping))))
    (system-comp
     os
     (mapped-devices
      (cons* encrypted-device
             (operating-system-mapped-devices os)))
     (file-systems
      (map (lambda (fs)
             (if (member (file-system-mount-point fs) mount-points)
                 (file-system
                   (inherit fs)
                   (dependencies (cons* encrypted-device
                                        (file-system-dependencies fs))))
                 fs))
           (operating-system-file-systems os))))))
#+end_src
***** Swap
****** Disk-backed
No ~swap-space-dependencies~ are required as long as the file system on which the swap file resides is ~needed-for-boot?~ (indeed, adding them triggers a build error since no Shepherd service is created for such file systems).
#+begin_src scheme
(define-system-comp (swap #:key
                          (target "/.swap")
                          file?
                          file-size
                          file-no-cow?
                          stateless?)
  (swap-devices
   (cons* (swap-space
           (target target))
          (operating-system-swap-devices os)))
  (services
   (append
    (operating-system-user-services os)
    (let ((name (lambda (base)
                  (symbol-append base '- (string->symbol target)))))
      (if file?
          (cons* (simple-service (name 'swap-create-file)
                                 activation-service-type
                                 (create-swap-file-gexp target file-size file-no-cow?))
                 (if stateless?
                     (list
                      (stateless-service
                       (name 'swap-file)
                       #:state `(((#:path . ,target)
                                  (#:storage . #:storage/machine)
                                  (#:preemptively? . #t)))))
                     '()))
          (list
           (simple-service (name 'create-swap-device)
                           activation-service-type
                           (create-swap-device-gexp target))))))))

(define (create-swap-file-gexp file size no-cow?)
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules ((guix build utils) #:select (mkdir-p invoke symbolic-link?)))

        ;; TODO Forget what I said in the comment below, do do this just for stateless
        ;; Check if the swap file is a symblic link and create its target if so. I do this to make stateless setups work but don't gate it because hey having this functionality available can't hurt.
        (let ((file* (if (and (file-exists? #$file)
                              (symbolic-link? #$file))
                         (readlink #$file)
                         #$file)))
          (when (and (file-exists? file*)
                     (not (= (stat:size (stat file*))
                             #$size)))
            (delete-file file*))
          (when (not (file-exists? file*))
            (mkdir-p (dirname file*))
            (when #$no-cow?
              (invoke #$(file-append coreutils "/bin/truncate") "--size" "0" file*)
              (invoke #$(file-append e2fsprogs "/bin/chattr") "+C" file*))
            (invoke #$(file-append util-linux "/bin/fallocate") "--length" (number->string #$size) file*)
            (chmod file* #o600)
            (invoke #$(file-append util-linux "/sbin/mkswap") file*))))))

(define (create-swap-device-gexp target)
  #~(begin
      ;; ...
      ;; Find the swap device using the same (somewhat complex) logic as `swap-service-type' and run `mkswap' on it (if that hasn't been done already, donno how I'd check).
      ))
#+end_src
******* Zswap
Works only if disk-backed swap is available, consider [[*Zram][Zram]] otherwise.
#+begin_src scheme
(define-system-comp (zswap #:key
                           (compressor "zstd")
                           (allocator "z3fold")
                           (max-pool-percent 20))
  (kernel-arguments (append
                     (operating-system-user-kernel-arguments os)
                     (map (match-lambda
                            ((k . v)
                             (string-append k "=" v)))
                          `(("zswap.enabled" . "1")
                            ("zswap.compressor" . ,compressor)
                            ("zswap.zpool" . ,allocator)
                            ("zswap.max_pool_percent" . ,(number->string max-pool-percent))))))
  (initrd-modules (append
                   (operating-system-initrd-modules os)
                   (list compressor
                         allocator))))
#+end_src
****** Zram
Useful when disk-backed swap doesn't make sense (e.g. a system on a flash drive where there's no room or I/O would be slow), consider [[*Zswap][Zswap]] otherise.
#+begin_src scheme
(define-system-comp (zram-swap #:key
                               (compression 'zstd)
                               size
                               memory-limit
                               priority)
  (services
   (cons* (service zram-device-service-type
                   (zram-device-configuration
                    (size size)
                    (compression-algorithm compression)
                    (memory-limit memory-limit)
                    (priority priority)))
          (operating-system-user-services os))))
#+end_src
***** Stateless
Must succeed [[*File systems][File systems]] component. To be useful, the stateless service's activation must happen before that of other services that create state so including this comonent after all others is safest.
#+begin_src scheme
(define* (stateless os
                    #:key
                    storage-paths
                    hes
                    state-users
                    password-users)
  (as-> os $
    (system-comp
     $
     (file-systems
      (->> (operating-system-file-systems os)
           (map (lambda (fs)
                  (if (member (file-system-mount-point fs)
                              (cons "/var/guix"
                                    (map (match-lambda ((_ . dir) dir))
                                         storage-paths)))
                      (file-system
                        (inherit fs)
                        (needed-for-boot? #t))
                      fs)))))
     (services
      ;; Important: put the stateless-service *after* the rest of the operating system services.
      (append
       (operating-system-user-services os)
       (list
        (service stateless-service-type
                 (let ((machine-dir (assoc-ref storage-paths #:storage/machine)))
                   `(#:storage-paths ,storage-paths
                     #:hes ,(or hes '())
                     #:state-users ,(or state-users '())
                     #:password-files ,(->> (or password-users '())
                                            (cons (user-account-name %root-account))
                                            (map (lambda (user)
                                                   `(,user . ,(string-append machine-dir
                                                                             "/.passwords/"
                                                                             user)))))
                     #:symlink-log-dir? #t
                     #:log-storage-dir ,machine-dir)))))))

    (stateless-guix-system $)))
#+end_src
****** Service
******* Service type
#+begin_src scheme
(define stateless-service-type
  (service-type
   (name 'stateless)
   (extensions
    (list (service-extension boot-service-type
                             (lambda (config)
                               (boot-gexp
                                (assoc-ref config #:symlink-log-dir?)
                                (assoc-ref config #:log-storage-dir)
                                (assoc-ref config #:password-files))))
          (service-extension activation-service-type
                             (lambda (config)
                               (activation-gexp
                                (assoc-ref config #:state-users)
                                (assoc-ref config #:state)
                                (assoc-ref config #:storage-paths))))
          (service-extension shepherd-root-service-type
                             (lambda (config)
                               (activate-he-shepherd-services
                                (assoc-ref config #:hes))))
          (service-extension profile-service-type
                             (lambda (config)
                               (list (stateless:tool-package
                                      "stateless"
                                      (assoc-ref config #:state)
                                      (assoc-ref config #:ignore)
                                      "/"
                                      (assoc-ref config #:storage-paths)
                                      ;; #:additional-known
                                      ;; (system-additional-known (map car (assoc-ref config #:hes)))
                                      ))))))
   (compose identity)
   (extend (lambda (config exts)
             (stateless:extend-proc
              config

              exts
              ;; (append exts
              ;;         (list `((#:ignore . ,(map (lambda (store)
              ;;                                     (string-append store "/"))
              ;;                                   ;; (map (match-lambda ((_ . dir) dir)) (assoc-ref config #:storage-paths))
              ;;                                   '(list
              ;;                                     "/.persist"
              ;;                                     "/.machine")))))
              ;;         (if #t ; TODO (assoc-ref config #:symlink-log-dir?)
              ;;             (list '((#:ignore . ("/var/log"))))
              ;;             '()))
              )))
   (description "Initialize a stateless system.")))
#+end_src
******** Boot
#+begin_src scheme
(define (boot-gexp symlink-log-dir? log-storage-dir password-files)
  (gexps->gexp
   (list (populate-root-gexp symlink-log-dir? log-storage-dir)
         (populate-passwords-gexp password-files))))

(define (populate-root-gexp symlink-log-dir? log-storage-dir)
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules ((guix build utils) #:select (mkdir-p))
                     ((ice-9 match) #:select (match-lambda)))

        (for-each
         (match-lambda
           ((dir . mode)
            (mkdir-p dir)
            (chmod dir mode))
           (dir
            (mkdir-p dir)))
         ;; Taken from `populate-root-file-system'. Some of these might not be necessary (for example, "/tmp" and "/var/run" are deleted and recreated in `cleanup-service-type') but it's safest to do them here anyway just in case some early-running code assumes their presence.
         ;; TODO Update: /run and /var/run are probably no longer necessary but I remember some stateless population/activation ordering stuff being subtle so I'm not removing them just yet. Relevant commits:
         ;; - https://git.savannah.gnu.org/cgit/guix.git/commit/?id=e73db355b127b9ca2b5339f645f2d3eb6929531f
         ;; - https://git.savannah.gnu.org/cgit/guix.git/commit/?id=27ee6f06d0ecab58ca3b739c911bacefda440177
         '("/bin"
           "/etc"
           ("/gnu/store" . #o1775)
           "/home"
           "/mnt"
           "/run"
           ("/tmp" . #o1777)
           "/var/db"
           "/var/empty"
           ("/var/lock" . #o1777)
           "/var/run"
           ("/var/tmp" . #o1777)))

        (let ((log-dir "/var/log"))
          (if #$symlink-log-dir?
              (let ((log-state-dir (string-append #$log-storage-dir log-dir)))
                (mkdir-p log-state-dir)
                (symlink log-state-dir log-dir))
              (mkdir-p log-dir))))))

;; HACK Guix assumes /etc/shadow is persistent between reboots and doesn't allow specifying a password file (like Nix's `passwordFile') so imitate this functionality by writing a shadow file on every boot populated with our users and their password hashes. The file doesn't have to be complete: Guix will add the missing entries (for system accounts, etc).
(define (populate-passwords-gexp password-files)
  (with-imported-modules (source-module-closure
                          '((gnu build accounts)))
    #~(begin
        (use-modules ((gnu build accounts) #:select (shadow-entry write-shadow))
                     ((ice-9 match) #:select (match-lambda))
                     ((ice-9 textual-ports) #:select (get-line)))

        (write-shadow
         (map (match-lambda
                ((user . password-file)
                 (shadow-entry
                  (name user)
                  (password (if (file-exists? password-file)
                                (call-with-input-file password-file get-line)
                                ""))
                  (last-change #f))))
              '#$password-files)))))
#+end_src
******** Activation
#+begin_src scheme
(define (activation-gexp state-users state storage-paths)
  (gexps->gexp
   (list (create-state-homes-gexp state-users
                                  (map (match-lambda ((_ . dir) dir))
                                       storage-paths))
         (activate-gexp state storage-paths))))

(define (create-state-homes-gexp users storage-dirs)
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules ((guix build utils) #:select (mkdir-p)))

        (for-each
         (lambda (user)
           (let* ((pw (getpwnam user))
                  (home (passwd:dir pw)))
             (for-each (lambda (storage-dir)
                         (let ((state-home (string-append storage-dir home)))
                           (mkdir-p state-home)
                           (chmod state-home #o700)
                           (chown state-home (passwd:uid pw) (passwd:gid pw))))
                       '#$storage-dirs)))
         '#$users))))

(define (activate-gexp state storage-paths)
  (with-imported-modules (source-module-closure
                          '((phrenetic build stateless))
                          #:select? phrenetic-module-name?)
    #~(begin
        (use-modules ((phrenetic build stateless) #:select (activate)))
        (activate '#$state
                  ""
                  '#$storage-paths))))
#+end_src
******** Shepherd
#+begin_src scheme
(define (activate-he-shepherd-services hes)
  (cons (user-homes-shepherd-service (map (match-lambda ((user . _) user))
                                          hes))
        (map (match-lambda
               ((user . he)
                (activate-he-shepherd-service user he)))
             hes)))

(define (activate-he-shepherd-service user he)
  (shepherd-service
   (provision (list (symbol-append 'stateless-home- (string->symbol user))))
   (requirement '(stateless-user-homes))
   (one-shot? #t)
   (start #~(make-forkexec-constructor
             '(#$(file-append he "/activate"))
             #:user #$user
             #:group (group:name (getgrgid (passwd:gid (getpw #$user))))
             #:log-file (string-append "/var/log/stateless-home-" #$user ".log")
             #:environment-variables
             (list (string-append "HOME=" (passwd:dir (getpw #$user))))))
   (stop #~(make-kill-destructor))))

;; HACK Clear the home directories because the `user-homes' shepherd service puts skeleton files in them. Only do this when a new user is added and on startup activation, not reconfigure activation: determine which it is by checking for the presence of ".guix-home".
;; Update: possibly the shepherd servie `transient?` field could be of help here.
(define (user-homes-shepherd-service users)
  (shepherd-service
   (provision '(stateless-user-homes))
   (requirement '(user-homes))
   (one-shot? #t)
   (start (with-imported-modules '((guix build utils)) ; Donno if `with-imported-modules' is necessary. Most of the Shepherd services in Guix (that are defined this way, i.e. with a lambda gexp) don't have it but a few do and it doesn't seem to hurt anything.
            #~(lambda ()
                (define (run)
                  (for-each
                   (lambda (user)
                     (let ((home (passwd:dir (getpwnam user))))
                       (when (not (file-exists? (string-append home "/.guix-home")))
                         (delete-directory-contents home))))
                   '#$users))

                (define (delete-directory-contents dir)
                  (for-each (lambda (name)
                              (delete-file-recursively (string-append dir "/" name)))
                            (scandir dir (lambda (name)
                                           (not (member name '("." "..")))))))

                (run)
                #t)))
   (modules '(((guix build utils) #:select (delete-file-recursively))
              ((ice-9 ftw) #:select (scandir))))))
#+end_src
******** Tool
#+begin_src scheme
(define (system-additional-known users)
  #~(append
     #$etc-static-files
     ;; #$root-skeleton-files ; TODO commenting this until I fix / am sure doesn't matter: "warning: importing module (guix config) from the host"
     #$(user-homes users)))

(define etc-static-files
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules ((guix build utils) #:select (symbolic-link?))
                     ((ice-9 ftw) #:select (scandir)))

        (let ((etc-static-dir "/etc/static"))
          (map (lambda (file)
                 (let ((target (string-append "/etc/" file))
                       (source (string-append etc-static-dir "/" file))
                       ;; TODO maybe replace with `directory-exists?', for brevity.
                       (directory? (lambda (path)
                                     (eq? (stat:type (stat path)) 'directory))))
                   (cons target
                         (if (directory? source)
                             (lambda (f)
                               (and (symbolic-link? f)
                                    (string-prefix? etc-static-dir (readlink f))))
                             (const #t))))) ; TODO a file (not a directory or a symlink)
               (scandir etc-static-dir (lambda (name)
                                         (not (member name '("." ".."))))))))))

;; TODO old implementation, remove
;; (define etc-static-files
;;   (with-imported-modules '((guix build utils))
;;     #~(begin
;;         (use-modules ((guix build utils) #:select (find-files)))

;;         (let ((etc-static-dir "/etc/static"))
;;           (map (lambda (file)
;;                  (cons (string-append "/etc" (string-drop file (string-length etc-static-dir)))
;;                        (if (equal? (dirname file) etc-static-dir)
;;                            (const #t) ; TODO a file (not a directory or a symlink)
;;                            symlink-to-store?)))
;;                (find-files etc-static-dir))))))


;; (define root-skeleton-files
;;   (with-imported-modules (source-module-closure
;;                           '((guix build utils)
;;                             (guix utils)))
;;     #~(begin
;;         (use-modules ((guix build utils) #:select (find-files))
;;                      ((guix utils) #:select (readlink*)))

;;         (let ((skel-dir (readlink* "/etc/skel")))
;;           (map (lambda (file)
;;                  (cons (string-append "/root" (string-drop file (string-length skel-dir)))
;;                        (const #t))) ; TODO a file with contents equal to the corresponding skeleton file
;;                (find-files skel-dir))))))

(define (user-homes users)
  #~(map (lambda (user)
           (let ((directory? (lambda (path)
                               (eq? (stat:type (lstat path)) 'directory))))
             (cons (string-append (passwd:dir (getpwnam user)) "/")
                   directory?))) ; TODO stat or lstat probably not important
         '#$users))




;; passwd subcommand WIP

;; (use-modules ((guix build utils) #:select (invoke mkdir-p)))

;; (define (enter-pass)
;;   (let ((pass (getpass "New password: "))
;;         (retype (getpass "Retype new password: ")))
;;     (if (equal? pass retype)
;;         pass
;;         (begin
;;           (display "Passwords do not match.")
;;           #f
;;           ;; (exit)
;;           ))))


;; (let ((pass (enter-pass)))
;;   (when pass
;;     ;; (invoke "/run/privileged/bin/passwd")

;;     (crypt pass (string-append "$" "6" "$" "sosalty"))

;;     (mkdir-p "/.machine/.passwords")
;;     ))
#+end_src
******** Shared
#+begin_src scheme
(define (gexps->gexp gexps)
  #~(begin
      #$@gexps))
#+end_src
******* Extension helper
#+begin_src scheme
(define stateless-service
  (stateless:service-fn stateless-service-type))
#+end_src
****** Guix system
#+begin_src scheme
(define* (stateless-guix-system os)
  (as-> os $
    (system-comp
     $
     (services
      (cons* (stateless-service
              'guix-system
              #:ignore `(;; General Linux system.
                         ((#:path . "/dev/"))
                         ((#:path . "/proc/"))
                         ((#:path . "/run/"))
                         ((#:path . "/sys/"))
                         ((#:path . "/tmp/"))
                         ((#:path . "/var/lock/"))
                         ((#:path . "/var/run/"))
                         ;; ((#:path . "/var/tmp/")) ; FHS specifies this should be preserved between reboots. I'm leaving it commented out for now because I want to know if something shows up. I'll decide then if I should be symlinking individual state files/dirs inside this directory or the directory entirely.
                         ((#:path . "/etc/group"))
                         ((#:path . "/etc/passwd"))
                         ((#:path . "/etc/shadow"))
                         ((#:path . ,%password-lock-file))
                         ;; Specifc to Guix system.
                         ((#:path . "/etc/mtab")
                          (#:preds . ((#:symlink-to "/proc/self/mounts"))))
                         ((#:path . "/etc/ssl")
                          (#:preds . ((#:symlink-to "/run/current-system/profile/etc/ssl"))))
                         ((#:path . "/etc/static")
                          (#:preds . ((#:symlink-to-store))))))
             (operating-system-user-services os))))

    (sudo-lectures $)))
#+end_src
******* Sudo lectures
#+begin_src scheme
(define-system-comp (sudo-lectures #:key lectures?)
  (services
   (append
    (operating-system-user-services os)
    (if lectures?
        (list
         (stateless-service
          'sudo-lectures
          #:state '(((#:path . "/var/db/sudo/lectured/")
                     (#:storage . #:storage/machine)))))
        '())))
  (sudoers-file
   (if (not lectures?)
       (mixed-text-file
        "sudoers"
        (slurp-file-like (operating-system-sudoers-file os))
        "Defaults lecture=never" "\n")
       (operating-system-sudoers-file os))))
#+end_src
**** Hardware-specific
***** Bootloaders
****** Grub
#+begin_src scheme
;; ...
#+end_src
****** Grub EFI
#+begin_src scheme
(define-system-comp (grub-efi-boot #:key
                                   label
                                   (target "/boot/efi")
                                   stateless?)
  (bootloader (bootloader-configuration
               (inherit (operating-system-bootloader os))
               (bootloader grub-efi-bootloader)
               (targets (list target))))
  (file-systems
   (cons* (file-system
            (device (file-system-label label))
            (mount-point target)
            (type "vfat"))
          (operating-system-file-systems os)))
  (services
   (append
    (operating-system-user-services os)
    (if stateless?
        (list
         (let ((grub-dir "/boot/grub"))
           (match (grub-efi-format+file-name)
             ((format . file-name)
              ;; I could be more exhaustive here if I wanted: locales and modles are in the GRUB package so I could map over them and add ignore entries for each. Unforunately there isn't an easy way to get the built grub.cfg contents for comparison.
              (stateless-service
               'grub-efi
               #:ignore `(((#:path . ,(string-append target "/EFI/Guix/" file-name)))
                          ((#:path . ,(string-append grub-dir "/" format "/")))
                          ((#:path . ,(string-append grub-dir "/locale/")))
                          ((#:path . ,(string-append grub-dir "/fonts/unicode.pf2")))
                          ((#:path . ,(string-append grub-dir "/grub.cfg")))
                          ((#:path . ,(string-append grub-dir "/grubenv"))
                           (#:preds . ((#:file-content ,grubenv))))))))))
        '()))))

(define* (grub-efi-format+file-name #:key removable?)
  (match (assoc-ref '(("x86_64" . ("x86_64-efi" . "x64"))
                      ;; ...
                      )
                    (-> %host-type ; Not sure this is the right way to do this. Will it fail under cross-compilation? What is `%current-(target-)system' in Guix code all about?
                        (string-split #\-)
                        first))
    ((format . base-name)
     (cons format
           (string-append (if removable? "boot" "grub")
                          base-name
                          ".efi")))))

(define (repeat n x)
  (map (lambda _ x) (iota n)))

(define grubenv
  (let* ((package "grub")
         (message (string-append "# GRUB Environment Block" "\n"
                                 "# WARNING: Do not edit this file by tools other than " package "-editenv!!!" "\n"))
         (envblk-size 1024)
         (padding-size (- envblk-size (string-length message))))
    (string-append message
                   (apply string-append (repeat padding-size "#")))))
#+end_src
****** U-Boot
#+begin_src scheme
;; ...
#+end_src
***** Linux
#+begin_src scheme
(define-system-comp (linux-libre-kernel #:key
                                        system
                                        linux-customization-params)
  (kernel (linux-with-customizations (get-linux system)
                                     linux-customization-params)))

(define (linux-with-customizations linux params)
  (if params
      (apply customize-linux
             #:linux linux
             params)
      linux))

(define (get-linux system)
  (or (assoc-ref `(;; ("aarch64-linux" . linux-libre-arm64-generic)
                   ;; ...
                   )
                 system)
      linux-libre))
#+end_src
***** Virtualization
#+begin_src scheme
(define-system-comp (virtualization #:key
                                    kvm-support?
                                    kvm-users
                                    native-platform
                                    binfmt-platforms)
  (services
   (append
    (operating-system-user-services os)
    (if kvm-support?
        (list
         (simple-service 'virtualization-users-add-groups
                         accounts-service-type
                         (cons kvm-users '("kvm"))))
        '())
    (let ((platforms (remove (lambda (p)
                               (equal? p native-platform))
                             (or binfmt-platforms '()))))
      (if (not (null? platforms))
          (list
           (service qemu-binfmt-service-type
                    (qemu-binfmt-configuration
                     (platforms (apply lookup-qemu-platforms platforms)))))
          '())))))
#+end_src
***** Console
****** Keyboard layouts
#+begin_src scheme
(define-system-comp (console-keyboard-layouts #:key kb-layout)
  (keyboard-layout kb-layout)
  (bootloader (bootloader-configuration
               (inherit (operating-system-bootloader os))
               (keyboard-layout kb-layout))))
#+end_src
****** Fonts
#+begin_src scheme
(define-system-comp (console-fonts #:key
                                   number-of-ttys
                                   hidpi?)
  (services
   (cons* (service console-font-service-type
                   (map (lambda (n)
                          (cons (string-append "tty" (number->string n))
                                (if hidpi?
                                    (file-append font-terminus "/share/consolefonts/ter-132n")
                                    %default-console-font)))
                        (iota number-of-ttys 1)))
          (operating-system-user-services os))))
#+end_src
**** Shared
#+begin_src scheme
(define without-profile-extension
  (rpartial without-extensions profile-service-type))
#+end_src
*** Composite components
**** Base
#+begin_src scheme
(define* (os-base os
                  #:key
                  (login #:login/greetd)
                  login-number-of-ttys
                  who
                  package-managers
                  guix-authorized-keys
                  guix-substitute-urls
                  console?
                  kmonad?
                  kmonad-users
                  kmonad
                  desktop?
                  avahi-users
                  media
                  media-pipewire
                  pipewire-users
                  (connection-manager #:cm/network-manager)
                  wireless-users
                  bluetooth?
                  login-manager
                  auto-login?
                  auto-login-user
                  (seat-manager #:seats/elogind)
                  seat-users
                  sessions
                  sessions-swaylock-effects?
                  sessions-swaylock
                  sessions-swaylock-effects
                  hyprland-users
                  sway-users
                  stateless?)
  (as-> os $
    (base-services $ #:stateless? stateless?)
    (case login
      ((#:login/classic) (classic-login $ #:number-of-ttys login-number-of-ttys))
      ((#:login/greetd) (greetd-login $ #:number-of-ttys login-number-of-ttys)))
    (accounts $ #:who who)
    (if (member #:pm/guix (or package-managers '()))
        (guix-pm $ #:authorized-keys guix-authorized-keys
                 #:substitute-urls guix-substitute-urls
                 #:stateless? stateless?) $)
    (if (member #:pm/nix (or package-managers '()))
        (nix-pm $ #:stateless? stateless?) $)
    (if console?
        (if kmonad?
            (kmonad-tool $ #:users kmonad-users
                         #:kmonad kmonad)
            $)
        $)
    (if desktop?
        (as-> $ $
          (desktop-base-services $ #:avahi-users avahi-users
                                 #:stateless? stateless?)
          (upower-power $ #:stateless? stateless?)
          (if media
              (case media
                ((#:media/classic) (classic-media $))
                ((#:media/pipewire) (pipewire-media $ #:pipewire media-pipewire
                                                      #:users pipewire-users)))
              $)
          (if connection-manager
              (case connection-manager
                ((#:cm/network-manager) (network-manager $ #:wireless-users wireless-users
                                                         #:stateless? stateless?)))
              $)
          (if bluetooth?
              (bluetooth $ #:stateless? stateless?)
              $)
          (switchd-acpi $)
          (if seat-manager
              (case seat-manager
                ((#:seats/elogind) (elogind-seats $))
                ((#:seats/seatd) (seatd-seats $ #:users seat-users)))
              $)
          (if login-manager
              (case login-manager
                ((#:lm/gdm) (gdm $ #:auto-login? auto-login?
                                 #:auto-login-user auto-login-user
                                 #:stateless? stateless?)))
              (desktop-tty $ #:login login
                           #:auto-login? auto-login?
                           #:auto-login-user auto-login-user))
          (if (member #:session/gnome (or sessions '()))
              (gnome-desktop $) $)
          (if (member #:session/hyprland (or sessions '()))
              (hyprland-wm $ #:users hyprland-users) $)
          (if (member #:session/sway (or sessions '()))
              (sway-wm $ #:users sway-users
                       #:swaylock-effects? sessions-swaylock-effects?
                       #:swaylock sessions-swaylock
                       #:swaylock-effects sessions-swaylock-effects)
              $))
        $)))
#+end_src
** Home
:PROPERTIES:
:header-args+: :tangle (meta-in-dir "home.scm")
:END:
#+begin_src scheme
(define-module (phrenetic home)
  #:use-module ((guix download) #:select (url-fetch))
  #:use-module (guix gexp)
  #:use-module ((guix modules) #:select (source-module-closure))
  #:use-module (guix packages)
  #:use-module (gnu home)
  #:use-module (gnu home services)
  #:use-module (gnu home services desktop)
  #:use-module (gnu home services fontutils)
  #:use-module (gnu home services shells)
  #:use-module (gnu home services shepherd)
  #:use-module (gnu home services sound)
  #:use-module (gnu home services ssh)
  #:use-module (gnu home services xdg)
  #:use-module (gnu home-services version-control)
  #:use-module ((gnu packages browser-extensions) #:select (ublock-origin/chromium))
  #:use-module ((gnu packages chromium) #:select (ungoogled-chromium))
  ;; #:use-module ((gnu packages compression) #:select (zip unzip))
  #:use-module ((gnu packages bash) #:select (bash))
  #:use-module ((gnu packages clojure) #:select (clojure-tools))
  ;; #:use-module ((gnu packages curl) #:select (curl))
  #:use-module ((gnu packages emacs) #:select (emacs emacs-pgtk))
  #:use-module ((gnu packages emacs-xyz) #:select (doom-emacs))
  #:use-module ((gnu packages fonts) #:select (font-fira-code font-google-noto font-google-noto-emoji font-google-noto-sans-cjk font-google-noto-serif-cjk font-iosevka font-iosevka-aile font-iosevka-etoile font-liberation font-gnu-unifont))
  #:use-module ((gnu packages fontutils) #:select (fontmanager-no-googlefonts))
  #:use-module ((gnu packages freedesktop) #:select (desktop-file-utils poweralertd xdg-utils xdg-user-dirs xdg-desktop-portal xdg-desktop-portal-gtk xdg-desktop-portal-wlr))
  #:use-module ((gnu packages gimp) #:select (gimp))
  #:use-module ((gnu packages glib) #:select (dbus))
  #:use-module ((gnu packages gnome) #:select (adwaita-icon-theme dconf gnome-essential-extras gnome-meta-core-services gnome-meta-core-shell gnome-meta-core-utilities gnome-session gnome-themes-extra hicolor-icon-theme))
  #:use-module ((gnu packages gnome-xyz) #:select (arc-theme papirus-icon-theme))
  #:use-module ((gnu packages gnuzilla) #:select (icecat))
  #:use-module ((gnu packages gstreamer) #:select (gst-libav gst-plugins-base gst-plugins-good gst-plugins-bad gst-plugins-ugly))
  #:use-module ((gnu packages haskell-apps) #:select (kmonad))
  #:use-module ((gnu packages hyprland) #:select (hypridle hyprland hyprlock xdg-desktop-portal-hyprland/simple))
  #:use-module ((gnu packages image) #:select (grim slurp swappy))
  #:use-module ((gnu packages java) #:select (openjdk-lts))
  #:use-module ((gnu packages linux) #:select (brightnessctl pipewire wireplumber wireplumber))
  #:use-module ((gnu packages music) #:select (playerctl))
  #:use-module ((gnu packages node) #:select (node-lts))
  #:use-module ((gnu packages package-management) #:select (flatpak (guix . guix-package) nix))
  #:use-module ((gnu packages pulseaudio) #:select (pulseaudio pavucontrol))
  #:use-module ((gnu packages python-web) #:select (awscli))
  #:use-module ((gnu packages qt) #:select (qtwayland qtwayland-5))
  #:use-module ((gnu packages shells) #:select (zsh))
  #:use-module ((gnu packages shellutils) #:select (direnv))
  #:use-module ((gnu packages terminals) #:select (alacritty))
  #:use-module ((gnu packages tor-browsers) #:select (torbrowser))
  #:use-module ((gnu packages version-control) #:select (git))
  #:use-module ((gnu packages video) #:select (vlc))
  #:use-module ((gnu packages virtualization) #:select (qemu))
  #:use-module ((gnu packages vpn) #:select (protonvpn-cli))
  #:use-module ((gnu packages web) #:select (jq))
  #:use-module ((gnu packages web-browsers) #:select (nyxt))
  #:use-module ((gnu packages wm) #:select (mako sway swayidle swaylock swaylock-effects))
  #:use-module ((gnu packages xdisorg) #:select (rofi rofi-wayland wl-clipboard))
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system keyboard)
  #:use-module ((gnu system shadow) #:select (%default-dotguile %default-gdbinit %default-nanorc))
  #:use-module ((rde serializers elisp) #:select (elisp-serialize))
  #:use-module ((rde serializers ini) #:select (ini-serialize))
  #:use-module (phrenetic modules)
  #:use-module ((phrenetic stateless) #:prefix stateless:)
  #:use-module (phrenetic utils)
  ;; #:use-module ((sxml simple) #:select (sxml->xml))
  #:use-module ((ice-9 match) #:select (match match-lambda match-let))
  #:use-module ((ice-9 string-fun) #:select (string-replace-substring))
  #:use-module ((srfi srfi-1) #:select (append-map concatenate delete-duplicates every list-index remove))
  #:export (create-he
            stateless
            home-stateless-service
            shells
            xdg-base-directories
            xdg-trash
            emacs-editor
            emacs-interface
            emacs-new-frame
            doom
            doom-service
            doom-ts-lang
            doom-web
            guix-pm
            nix-pm
            virtualization
            kmonad-tool
            pipewire-media
            %colors
            %wallpapers
            font-library
            %fonts
            %date-formats
            %time-formats
            xdg-user-directories
            mesa
            doom-desktop
            dbus-ipc
            gdm
            desktop-tty
            gnome-desktop
            gnome-start
            sway-wm
            sway-start
            swaylock-wm-piece
            swaylock-screen-locker
            swayidle-wm-piece
            swayidle-idle-manager
            mako-wm-piece
            mako-notifier
            poweralertd-wm-piece
            poweralertd-monitor
            ;; kanshi-wm-piece
            portal-services/gtk
            portal-services/wlr
            portal-config-services
            flatpak-apps
            aws-prog
            clojure-prog
            doom-calendar-prog
            doom-org-prog
            direnv-prog
            direnv-service-type
            node-prog
            protonvpn-prog
            ssh-prog
            doom-dired-prog
            ;; nano-prog
            doom-trash-prog
            git-prog
            ;; misc-progs
            pavucontrol-app
            font-manager-app
            doom-menu-app
            doom-menu
            rofi-app
            rofi-menu
            gimp-app
            alacritty-app
            alacritty-terminal
            doom-vterm-app
            doom-vterm-terminal
            ungoogled-chromium-app
            chromium-wrapper
            icecat-app
            nyxt-app
            tor-browser-app
            vlc-app
            work
            services-only-packages
            services-sans-packages
            system-features
            sway-environment
            programs
            applications
            he-entire))

(define serialize-rasi-config (@@ (rde home services xdisorg) serialize-rasi-config))
(define serialize-sway-config (@@ (rde home services wm) serialize-sway-config))
(define serialize-swaylock-config (@@ (rde home services wm) serialize-swaylock-config))
#+end_src
*** Create
#+begin_src scheme
(define (create-he services)
  (let ((he (home-environment)))
    (home-environment
     (inherit he)
     (essential-services (remove-services-by-types
                          (home-environment-essential-services he)
                          home-fontconfig-service-type))
     (services
      (filter service? services))))) ; A convenience to allow passing a list of services with #f, <unspecified> not filtered out.
#+end_src
*** Components
**** Stateless
- TODO probably move this to above "Virtualization" (to keep things in the same order in Home as in System). Update: probably create a "System-specific" section.
#+begin_src scheme
(define* (stateless #:key storage-paths)
  (append
   (list
    (service home-stateless-service-type
             `(#:storage-paths ,storage-paths)))
   (stateless-guix-home)))
#+end_src
***** Service
****** Service type
#+begin_src scheme
(define home-stateless-service-type
  (service-type
   (name 'home-stateless)
   (extensions
    (list (service-extension home-activation-service-type
                             (lambda (config)
                               (with-imported-modules (source-module-closure
                                                       '((phrenetic build stateless))
                                                       #:select? phrenetic-module-name?)
                                 #~(begin
                                     (use-modules ((phrenetic build stateless) #:select (activate)))
                                     (activate (#$state-with-home-expansions '#$(assoc-ref config #:state))
                                               #$homedir-gexp
                                               '#$(assoc-ref config #:storage-paths))))))
          ;; (service-extension home-profile-service-type
          ;;                    (lambda (config)
          ;;                      (list (stateless:tool-package
          ;;                             "home-stateless"
          ;;                             (state-with-home-expansions (assoc-ref config #:state))
          ;;                             (ignore-with-home-expansions (assoc-ref config #:ignore))
          ;;                             homedir-gexp
          ;;                             (assoc-ref config #:storage-paths)
          ;;                             #:additional-known
          ;;                             guix-home-files))))
          ))
   (compose identity)
   (extend stateless:extend-proc)
   (description "Initialize a stateless home.")))

(define homedir-gexp #~(getenv "HOME"))

(define path-with-home-expansion
  #~(lambda (path)
      (cond
       ((string? path) (string-append (getenv "HOME") "/" path))
       ((list? path)
        (apply
         (lambda* (#:optional tail #:key xdg-base)
           (string-append (getenv xdg-base) "/" (or tail "")))
         path)))))

(define state-with-home-expansions
  #~(lambda (state)
      (map (lambda (i)
             (acons #:path (#$path-with-home-expansion (assoc-ref i #:path)) i))
           state)))

(define ignore-with-home-expansions
  #~(lambda (ignore)
      (map #$path-with-home-expansion ignore)))
#+end_src
******* Tool
#+begin_src scheme
(define guix-home-files
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules ((guix build utils) #:select (find-files)))

        (let ((home-files
               (let* ((home-dir (getenv "HOME"))
                      (guix-home-dir (string-append
                                      home-dir "/.guix-home/" #$home-files-directory "/"))) ; TODO maybe do a `readlink' here instead of appending a slash, for clarity.
                 (map (lambda (file)
                        (string-append
                         home-dir
                         (string-drop file (string-length guix-home-dir))))
                      (find-files guix-home-dir)))))
          (make-known home-files symlink-to-store?)))))

;; (define (make-known files pred)
;;   (map (lambda (file)
;;          (cons file pred))
;;        files))

;; (define (symlink-to-store? file)
;;   (and (symbolic-link? file)
;;        (store-file-name? (readlink file))))
#+end_src
****** Extension helper
#+begin_src scheme
(define home-stateless-service
  (stateless:service-fn home-stateless-service-type))
#+end_src
***** Guix home
#+begin_src scheme
(define (stateless-guix-home)
  (list
   (home-stateless-service
    'guix-home
    #:state
    `(((#:path . ,(list (assoc-ref log-home #:path)
                        #:xdg-base
                        (assoc-ref log-home #:xdg-base)))
       (#:storage . #:storage/machine)))
    #:ignore
    '(((#:path . ".guix-home")
       (#:preds . ((#:symlink-to-store))))))))
#+end_src
**** Shells
#+begin_src scheme
(define* (shells #:key
                 stateless?
                 doom?
                 doom-tree-sitter?
                 login-shell
                 interactive-shells
                 (shell-configs `((#:shell/bash . ((#:bashrc . ,(list (local-file "bashrc")))))
                                  (#:shell/zsh . ((#:zshrc . ,(list (local-file "zshrc"))))))))
  (append
   (append-map
    (lambda (shell)
      (case shell
        ((#:shell/bash)
         (cons* (service home-bash-service-type
                         (let ((config (assoc-ref shell-configs #:shell/bash)))
                           (home-bash-configuration
                            (bashrc (or (assoc-ref config #:bashrc) '()))
                            ;; ... other fields
                            )))
                (if stateless?
                    (list
                     (home-stateless-service
                      'bash
                      #:state '(((#:path . ("bash/" #:xdg-base "XDG_STATE_HOME"))
                                 (#:storage . #:storage/persist))))
                     (simple-service 'bash-history
                                     home-bash-service-type
                                     (home-bash-extension
                                      (bashrc
                                       (list
                                        ;; TODO Line that sets HISTFILE to match stateless path.
                                        )))))
                    '())))
        ((#:shell/zsh)
         (cons* (service home-zsh-service-type
                         (let ((config (assoc-ref shell-configs #:shell/zsh)))
                           (home-zsh-configuration
                            (zshrc (or (assoc-ref config #:zshrc) '()))
                            ;; ... other fields
                            )))
                (if stateless?
                    (list
                     (home-stateless-service
                      'zsh
                      #:state '(((#:path . ("zsh/" #:xdg-base "XDG_STATE_HOME"))
                                 (#:storage . #:storage/persist))
                                ((#:path . ("zsh/" #:xdg-base "XDG_CACHE_HOME"))
                                 (#:storage . #:storage/machine))))
                     (simple-service 'zsh-history
                                     home-zsh-service-type
                                     (home-zsh-extension
                                      (zshrc
                                       (list
                                        ;; TODO Line that sets HISTFILE to match stateless path.
                                        )))))
                    '())))))
    (delete-duplicates
     (cons login-shell interactive-shells)))

   (list
    (let ((name 'shells-setup-login-shell)
          (shepherd-stop-cmd
           (let ((shepherd (home-shepherd-configuration-shepherd (home-shepherd-configuration))))
             (mixed-text-file
              "shepherd-stop"
              #~(string-join
                 (list
                  #$(file-append shepherd "/bin/herd") "stop" "root"))))))
      (case login-shell
        ((#:shell/bash)
         (simple-service name
                         home-bash-service-type
                         (home-bash-extension
                          (bash-logout
                           (list shepherd-stop-cmd)))))
        ((#:shell/zsh)
         (simple-service name
                         home-zsh-service-type
                         (home-zsh-extension
                          (zlogout
                           (list shepherd-stop-cmd)))))))

    (match-let (((default-interactive-shell _ ...) interactive-shells))
      (when-not (equal? login-shell default-interactive-shell)
                (simple-service
                 'shells-set-shell-env-var
                 home-environment-variables-service-type
                 `(("SHELL" . ,(case default-interactive-shell
                                 ((#:shell/bash) (file-append bash "/bin/bash"))
                                 ((#:shell/zsh) (file-append zsh "/bin/zsh")))))))))

   (if doom?
       (doom-shells #:stateless? stateless?
                    #:tree-sitter? doom-tree-sitter?)
       '())))
#+end_src
***** Bash
****** Bashrc
#+begin_src sh :tangle (meta-in-dir "bashrc")
HISTFILE=${XDG_STATE_HOME:-$HOME/.local/state}/bash/.bash_history
#+end_src
***** Zsh
****** Zshrc
:PROPERTIES:
:header-args+: :tangle (meta-in-dir "zshrc")
:END:
******* Andrew Tropin's zshrc
- TODO trying out Andrew Tropin's zsh configuration verbatim for now. Should I also try out vanilla zshell?
#+begin_src sh
# Prevent freezing output on ^s, needed for various isearches
hash stty 2> /dev/null && stty -ixon

# Completions and other stuff
autoload -U compinit
compinit -d ${XDG_CACHE_HOME:-$HOME/.cache}/zsh/.zcompdump

# Enable bash completion, requires to source them from somewhere
# autoload -U bashcompinit && bashcompinit

zstyle ':completion:*' menu select
zstyle ':completion:*' insert-tab false

# Automatically update cache of binaries avaliable in $PATH
zstyle ':completion:*' rehash true # Can have a performance penalty

# Approximate completion
# zstyle ':completion:::::' completer _complete _approximate
# zstyle ':completion:*:approximate:*' max-errors 2

# Fuzzy completion
# https://superuser.com/questions/415650/does-a-fuzzy-matching-mode-exist-for-the-zsh-shell
zstyle ':completion:*' matcher-list '' \
  'm:{a-z\-}={A-Z\_}' \
  'r:[^[:alpha:]]||[[:alpha:]]=** r:|=* m:{a-z\-}={A-Z\_}' \
  'r:|?=** m:{a-z\-}={A-Z\_}'

# Make kill completion smart
zstyle ':completion:*:*:*:*:processes' command "ps -u $USER -o pid,user,args -w -w"

# Colored completion for files and dirs according to LS_COLORS

hash dircolors 2> /dev/null && eval $(dircolors --sh) && \
zstyle ':completion:*' list-colors ${(s.:.)LS_COLORS}

# Prompt theme setup
clear_fn() {
#  zle reset-prompt
  zle kill-buffer
}

prompt_rde_precmd() {
  # Prevent killing prompt on ^C
  trap 'clear_fn' SIGINT
}

prompt_rde_setup() {
  if [[ $UID -eq 0 ]]; then
    user_part='%F{red}>%f'
  else
    user_part='%F{blue}>%f'
  fi
  if [ -n "$GUIX_ENVIRONMENT" ]; then
    genv_part='%F{yellow}>%f'
  fi
  # exit_code_part='%(?..[%?])'

  PS1="$user_part$genv_part "
  # RPS1="$exit_code_part"

  # Fish-like C-c behavior
  # add-zsh-hook precmd prompt_rde_precmd
}

# Load promptinit and set rde theme
autoload -Uz promptinit && promptinit
prompt_themes+=( rde )
prompt rde

setopt printexitvalue # Instead of using RPS1 for status code

echo -en "\033[6 q" # Make a cursor to be a vertical bar

# Remove slashes and dashes from wordchars to make M-b, M-f work
# correctly
WORDCHARS=""

# Configure history
# HISTSIZE=5000
# SAVEHIST=$HISTSIZE
HISTFILE=${XDG_STATE_HOME:-$HOME/.local/state}/zsh/.zhistory

#setopt incappendhistory # Save history to shared file, but not read
setopt sharehistory     # Share history across shell sessions
setopt histignorespace  # Ignore commands that start with space

# Configuring help (M-h to call it on current command/function)
autoload -Uz run-help
(( ${+aliases[run-help]} )) && unalias run-help
autoload -Uz run-help-git

# Delete, home, end buttons
bindkey  "^[[3~"  delete-char
bindkey  "^[[H"   beginning-of-line
bindkey  "^[[F"   end-of-line

# Launch $VISUAL or $EDITOR, for emacsclient if there is no server
# avaliable $ALTERNATE_EDITOR will be used.
autoload -z edit-command-line
zle -N edit-command-line
bindkey "^X^E" edit-command-line

# Do not require sudo for some system commands.
for command in mount umount sv updatedb su ; do
	alias $command="sudo $command"
done; unset command

# Verbosity and common settings.
alias \
      cp='cp -iv' \
      mv='mv -iv' \
      rm='rm -vI' \
      mkdir='mkdir -pv' \
      ffmpeg='ffmpeg -hide_banner'

# Colorize commands when possible.
alias \
      ls='ls -hp --color=auto' \
      ll='ls -lAh --group-directories-first --color=auto' \
      grep='grep --color=auto' \
      diff='diff --color=auto'

# Useful aliases.
alias help=run-help
alias try='guix shell man-db coreutils'
alias ka='killall'
alias sdn='sudo shutdown'
#+end_src
******* History
- TODO use ~very-big-history~
#+begin_src sh
HISTSIZE=1000000
SAVEHIST=$HISTSIZE
#+end_src
***** Doom shells
#+begin_src scheme
(define* (doom-shells #:key
                      stateless?
                      tree-sitter?)
  (append
   (doom-ts-lang 'sh #:tree-sitter? tree-sitter?)
   (doom-eshell #:stateless? stateless?)))
#+end_src
****** Doom eshell
#+begin_src scheme
(define* (doom-eshell #:key stateless?)
  (let ((name 'eshell))
    (list
     (doom-service
      name
      #:modules '((#:term
                   eshell))
      #:config `((after! eshell
                         (setq eshell-history-size ,very-big-history)))) ; Setting this to `nil' to inherit envvar HISTSIZE is another option.

     (when stateless?
       (doom-stateless-service
        name
        #:state '(((#:path . ("eshell/history" #:doom-base #:data))
                   (#:storage . #:storage/persist))
                  ((#:path . ("eshell/lastdir" #:doom-base #:data))
                   (#:storage . #:storage/persist))
                  ((#:path . ("eshell/z" #:doom-base #:data))
                   (#:storage . #:storage/persist))))))))
#+end_src
**** XDG
***** Base directories
#+begin_src scheme
(define* (xdg-base-directories)
  (list
   ;; Allowing parameterization not done. I'm unlikely to want to change any of these dirs and I'm lazy.
   ;; (simple-service
   ;;  'xdg-base-directories
   ;;  home-xdg-base-directories-service-type
   ;;  (xdg-base-directories-configuration
   ;;   ...))
   ))
#+end_src
***** Trash
~home-xdg-base-directories-service-type~ has an activation service to create the directories if they don't already exist, perhaps I should do the same thing here if only for consistency. The freedesktop specs for both don't require that the directories already exists so I don't know why we bother.
#+begin_src scheme
(define* (xdg-trash #:key stateless?)
  (list
   (when stateless?
     (home-stateless-service
      'xdg-trash
      #:state
      '(((#:path . ("Trash/" #:xdg-base "XDG_DATA_HOME"))
         (#:storage . #:storage/machine)))))))
#+end_src
**** Emacs
#+begin_src scheme
(define* (emacs-editor #:key
                       wayland?
                       (emacs emacs)
                       (emacs-pgtk emacs-pgtk))
  (let ((emacs (get-emacs #:wayland? wayland?
                          #:emacs emacs
                          #:emacs-pgtk emacs-pgtk)))
    (list
     (simple-service
      'emacs-add-packages
      home-profile-service-type
      (list emacs))

     (simple-service
      'emacs-set-editor-env-vars
      home-environment-variables-service-type
      `(("VISUAL" . ,(file-append emacs "/bin/emacsclient"))
        ("EDITOR" . "$VISUAL"))))))

(define* (emacs-interface #:key
                          wayland?
                          (emacs emacs)
                          (emacs-pgtk emacs-pgtk))
  (let ((emacs (get-emacs #:wayland? wayland?
                          #:emacs emacs
                          #:emacs-pgtk emacs-pgtk)))
    `((#:emacs/program . ,(list
                           (file-append emacs "/bin/emacs")))
      (#:emacs/new-frame . ,(list
                             (file-append emacs "/bin/emacsclient")
                             "--create-frame"))
      (#:emacs/handler . ,(partial emacs-handler emacs)))))

(define* (get-emacs #:key
                    wayland?
                    emacs
                    emacs-pgtk)
  (if wayland?
      emacs-pgtk
      emacs))
#+end_src
***** Handler
A similar package and possibly useful reference: [[https://github.com/alphapapa/yequake][GitHub - alphapapa/yequake: Drop-down Emacs frames, like Yakuake]]
#+begin_src scheme
(define* (emacs-handler emacs
                        name
                        exprs
                        #:key
                        modal?
                        modal-title
                        modal-width
                        modal-height
                        minibuffer?
                        input?)
  (program-file
   (string-append "emacs-handler-" name)
   #~(begin
       (use-modules ((ice-9 popen) #:select (close-pipe open-pipe*))
                    ((ice-9 textual-ports) #:select (get-string-all put-string)))

       (let* ((args (cdr (command-line)))
              (input (if #$input?
                         (string-drop-right (get-string-all (current-input-port)) 1)
                         #f))
              (pipe (let ((cmd (list
                                #$(file-append emacs "/bin/emacsclient")
                                "--eval"
                                (#$serialize-eval-expr
                                 (#$(eval-expr exprs
                                               modal?
                                               modal-title
                                               modal-width
                                               modal-height
                                               minibuffer?)
                                    args input)))))
                      (apply open-pipe* OPEN_READ cmd))))
         (put-string (current-output-port)
                     (let* ((res* (get-string-all pipe))
                            (end (string-take-right res* 1)) ; EOF or newline or something? Donno if this matters, doing it just in case.
                            (res (string-trim-both (string-drop-right res* 1) #\"))) ; `emacsclient' output is a sexp so strings will have quotes around them. Work around just this particular case, for now it's the only one that matters (for the dmenu-like functionality).
                       (string-append res end)))
         (close-pipe pipe)))))

(define (eval-expr exprs modal? modal-title modal-width modal-height minibuffer?)
  #~(lambda (args input)
      `(with-selected-frame
        (make-frame '(,@(if #$modal?
                            `((name . ,(string-append #$modal-title
                                                      #$emacs-modal-title-tail))
                              (width . ,(or #$modal-width 100))
                              (height . ,(or #$modal-height 20))
                              (alpha-background . 90))
                            '())
                      ,@(if #$minibuffer?
                            '((minibuffer . only)) '())))
        (let ((args ',args)
              (input ,(or input 'nil)))
          ,@(if #$minibuffer?
                '((unwind-protect
                   (progn
                    #$@exprs)
                   (delete-frame)))
                '#$exprs)))))

(define serialize-eval-expr
  #~(lambda (expr)
      (call-with-output-string
        (lambda (port)
          (write expr port)))))

(define emacs-modal-title-tail (string-append " - " "Emacs Modal"))

(define emacs-modal-window-props
  `((#:window-prop.criteria/title . ,(string-append ".*" emacs-modal-title-tail))
    (#:window-prop/floating? . #t)))
#+end_src
***** XDG service
#+begin_src scheme
(define* (emacs-xdg-service name
                            xdg-name
                            program
                            #:key
                            (exec-argument "%u")
                            default-for)
  (let ((file (symbol-append 'emacs- name)))
    (simple-service
     (symbol-append 'emacs-xdg- name)
     home-xdg-mime-applications-service-type
     (home-xdg-mime-applications-configuration
      (desktop-entries
       (list
        (xdg-desktop-entry
         (file (symbol->string file))
         (name (string-append "Emacs [" xdg-name "]"))
         (config `((exec . ,#~(string-append #$program " " #$exec-argument))
                   (icon . "emacs")))
         (type 'application))))
      (default (map (lambda (mime-type)
                      `(,mime-type . ,(symbol-append file '.desktop)))
                    (or default-for '())))))))
#+end_src
**** Doom
#+begin_src scheme
(define* (doom #:key
               stateless?
               services)
  (append
   (list
    (service doom-service-type)

    (simple-service
     'doom-set-paths
     home-environment-variables-service-type
     (let ((doom-local "$XDG_STATE_HOME/doom"))
       `(("DOOMLOCALDIR" . ,doom-local)
         ("DOOMPROFILELOADFILE" . ,(string-append doom-local "/profile-load.el"))))))

   (or services '())

   (if stateless?
       (list
        (home-stateless-service
         'doom
         #:state '(((#:path . ("doom/straight/" #:xdg-base "XDG_STATE_HOME"))
                    (#:storage . #:storage/machine))
                   ((#:path . ("doom/profile-load.el" #:xdg-base "XDG_STATE_HOME"))
                    (#:storage . #:storage/machine))))
        (doom-stateless-service
         'doom
         #:state '(((#:path . ("eln/" #:doom-base #:cache))
                    (#:storage . #:storage/machine))
                   ;; This is a temp directory for eln compilation and could probably just be ignored and not stored at all but let's be safe.
                   ((#:path . ("comp/" #:doom-base #:cache))
                    (#:storage . #:storage/machine))
                   ((#:path . ("profiles.@.el" #:doom-base #:cache))
                    (#:storage . #:storage/machine))
                   ((#:path . ("@/" #:doom-base #:data))
                    (#:storage . #:storage/machine))
                   ((#:path . ("sync" #:doom-base #:data))
                    (#:storage . #:storage/machine))
                   ((#:path . ("logs/" #:doom-base #:state))
                    (#:storage . #:storage/machine)))))
       '())))
#+end_src
***** Service :upstream:
****** Service type
#+begin_src scheme
(define doom-service-type
  (service-type
   (name 'home-doom)
   (extensions
    (list (service-extension home-profile-service-type
                             (const
                              (list `(,doom-emacs "bin"))))
          (service-extension home-xdg-configuration-files-service-type
                             (lambda (config)
                               `(("emacs" ,doom-emacs)
                                 ("doom" ,(doom-private config)))))))
   (compose identity)
   (extend (lambda (_ exts)
             (doom-extend exts)))
   (default-value #f)
   (description "Install and configure Doom.")))
#+end_src
******* Extend procedure
#+begin_src scheme
(define (doom-extend exts)
  (let ((field (lambda (k)
                 (map (lambda (i)
                        (or (assoc-ref i k) '()))
                      exts))))
    `((#:init-file . ,(init-file (field #:modules)))
      (#:config-file . ,(config-file (field #:config)))
      (#:packages-file . ,(packages-file (field #:packages)))
      (#:theme-files . ,(theme-files (field #:themes)))
      (#:snippets . ,(apply append (field #:snippets))))))

(define (init-file exts)
  (as-> exts $
    (map (lambda (i)
           (update-vals i (lambda (modules)
                            (map (lambda (m)
                                   (cond
                                    ((symbol? m) (list m))
                                    ((list? m) m)))
                                 modules))))
         $)
    (apply merge-with
           (lambda (ms ms*)
             (merge-with
              (lambda (flags flags*)
                (delete-duplicates (append flags flags*)))
              ms ms*))
           $)
    (sort $ (lambda (a b)
              (let ((idx (match-lambda
                           ((cat _ ...)
                            (list-index
                             (lambda (category)
                               (equal? cat category))
                             '(#:completion #:ui #:editor #:emacs #:term #:checkers #:tools #:lang #:app #:config))))))
                (< (idx a) (idx b)))))
    (update-vals $ (lambda (modules)
                     (let ((mod-name (match-lambda
                                       ((name _ ...)
                                        (symbol->string name)))))
                       (sort modules (lambda (a b)
                                       (string<? (mod-name a) (mod-name b)))))))
    (update-keys $ (lambda (category)
                     (symbol-append ': (keyword->symbol category))))
    (update-vals $ (lambda (modules)
                     (map (match-lambda
                            ((name) name)
                            (m m))
                          modules)))
    (apply append $)
    (elisp-serialize
     `(,#~";;; -*- lexical-binding: t; -*-"
          (doom! ,@$)))))

(define (config-file exts)
  (as-> exts $
    (delete-duplicates $)
    (apply append $)
    (elisp-serialize*
     (append
      `(,#~";;; -*- lexical-binding: t; -*-")
      $))))

(define (packages-file exts)
  (as-> exts $
    (delete-duplicates $)
    (apply append $)
    (elisp-serialize*
     (append
      `(,#~";; -*- no-byte-compile: t; -*-")
      $))))

(define (theme-files exts)
  (as-> exts $
    (apply append $)
    (map (match-lambda
           ((name defs extra-faces)
            (list name
                  (elisp-serialize*
                   `(,#~";;; -*- lexical-binding: t; no-byte-compile: t; -*-"
                     (require 'doom-themes)
                     (def-doom-theme ,name ,(symbol->string name) ,defs ,extra-faces))))))
         $)))

(define (elisp-serialize* exprs)
  #~(begin
      (use-modules ((ice-9 string-fun) #:select (string-replace-substring)))
      (string-replace-substring #$(elisp-serialize exprs) "(syntax " "(function ")))
#+end_src
******* Doom private
#+begin_src scheme
(define (doom-private config)
  (file-union
   "doom-private"
   (append
    (map (match-lambda
           ((name file)
            `(,(string-append name)
              ,(mixed-text-file (string-append "doom-" name) (assoc-ref config file)))))
         '(("init.el" #:init-file)
           ("config.el" #:config-file)
           ("packages.el" #:packages-file)))
    (map (match-lambda
           ((theme-name file)
            (let ((name (string-append (symbol->string theme-name) "-theme.el")))
              `(,(string-append "themes/" name)
                ,(mixed-text-file name file)))))
         (assoc-ref config #:theme-files))
    (append-map (match-lambda
                  ((mode snippets)
                   (map (match-lambda
                          ((name file)
                           `(,(string-append "snippets/" mode "/" name)
                             ,(mixed-text-file (string-append "emacs-snippet-" name) file))))
                        snippets)))
                (assoc-ref config #:snippets)))))
#+end_src
****** Extension helpers
#+begin_src scheme
(define* (doom-service name
                       #:key
                       modules
                       packages
                       config
                       themes
                       snippets)
  (simple-service
   (symbol-append name '-doom)
   doom-service-type
   `((#:modules . ,modules)
     (#:packages . ,packages)
     (#:config . ,config)
     (#:themes . ,themes)
     (#:snippets . ,snippets))))
#+end_src
******* Stateless
#+begin_src scheme
(define* (doom-stateless-service name #:key state ignore)
  (home-stateless-service
   (symbol-append name '-doom)
   #:state (state-with-doom-dir state)
   #:ignore ignore))

(define (state-with-doom-dir state)
  (map (lambda (i)
         (acons #:path (path-with-doom-dir (assoc-ref i #:path)) i))
       state))

(define (path-with-doom-dir path)
  (let ((doom-dir
         (lambda (base subpath)
           `(,(string-append
               "doom/"
               (case base
                 ((#:cache) "cache")
                 ((#:data) "etc")
                 ((#:state) "state"))
               "/" subpath)
             #:xdg-base "XDG_STATE_HOME"))))
    (apply (lambda* (tail #:key doom-base)
             (doom-dir doom-base tail))
           path)))
#+end_src
***** Doom Emacs
:PROPERTIES:
:meta-dir+: packages
:END:
****** packaging doom WIP
Extremely WIP, basically just a scratchpad
******* first attempts
Had =:tangle (meta-in-dir "packaging-doom-wip-1.scm")=
#+begin_src scheme :tangle no
(define-module (phrenetic packaging-doom-wip)
  #:use-module (guix build-system trivial)
  #:use-module (guix gexp)
  #:use-module (guix git-download)
  #:use-module (guix packages)
  #:use-module ((guix licenses) #:prefix license:)
  ;; #:use-module ((gnu packages emacs) #:select (emacs))
  #:use-module ((gnu packages version-control) #:select (git))
  #:use-module (phrenetic packages emacs)
  #:use-module (phrenetic packages doom-emacs)
  )

;; (define doom-inputs
;;   (computed-file
;;    "doom-inputs"
;;    (with-imported-modules '((guix build utils))
;;      #~(begin
;;          (use-modules (guix build utils))
;;          (invoke (string-append #+doom-emacs:bin "/bin/doom") "help")
;;          (copy-file #$(local-file "nixpkgs-config.nix") #$output)
;;          ;; `emacs-substitute-sexps' might be useful here if my needs get more sophisticated.
;;          ;; (substitute* #$output
;;          ;;   (("(dunstctl|dunst)" all) (case (string->symbol all)
;;          ;;                               ((dunst) (string-append #$(file-append dunst "/bin/dunst")
;;          ;;                                                       " -config " #$(local-file "dunstrc")))
;;          ;;                               ((dunstctl) #$(file-append dunst "/bin/dunstctl"))))
;;          ;;   (("nm-applet") #$(file-append network-manager-applet "/bin/nm-applet"))
;;          ;;   (("pasystray") #$(file-append pasystray "/bin/pasystray"))
;;          ;;   (("redshift-gtk") (string-append #$redshift:gtk "/bin/redshift-gtk"))
;;          ;;   (("udiskie") #$(file-append udiskie "/bin/udiskie")))
;;          ))))


(define-public temp-doom-emacs
  (package
    (name "doom-emacs")
    (version "0")
    (source
     (local-file "/home/pharcosyle/work/dotfiles/doom-emacs" #:recursive? #t))
    (build-system (@ (guix build-system copy) copy-build-system))
    (synopsis "")
    (description "")
    (home-page "")
    (license #f)))

(define-public doom-inputs
  (package
    (name "doom-inputs")
    (version "0")
    (source #f)
    (inputs
     (list emacs-29-pgtk+native-comp
           ;; doom-emacs
           temp-doom-emacs
           ;; (local-file "doom-private" #:recursive? #t)
           git
           ;; (local-file "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/straight.el" #:recursive? #t)
           ;; (local-file "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/use-package" #:recursive? #t)
           ))
    (build-system trivial-build-system)
    (arguments
     `(#:modules ((guix build utils))
       #:builder
       ,#~(begin
            (use-modules (guix build utils))
            (let ((doom-private #$(local-file "doom-private" #:recursive? #t))
                  (doom-local-dir (string-append #$output "/doom-local")))
              (mkdir-p doom-local-dir)

              ;; (mkdir-p (string-append #$output "/asdf"))
              ;; (with-output-to-file (string-append #$output "/asdf/asdf.txt")
              ;;   (lambda _
              ;;     (display "asdffffffffffff")))

              (setenv "PATH" (string-append (getenv "PATH")
                                            ":" (assoc-ref %build-inputs "emacs-29-pgtk+native-comp") "/bin"
                                            ":" (assoc-ref %build-inputs "git") "/bin"
                                            ))
              ;; (setenv "DOOMDIR" (assoc-ref %build-inputs "doom-private"))
              (setenv "DOOMDIR" doom-private)
              (setenv "DOOMLOCALDIR" doom-local-dir)

              ;; (chdir #$output)
              ;; (invoke "git" "clone" "https://github.com/dracula/gtk")

              ;; (display "hi!")
              ;; (display doom-private)
              ;; (display straight-el)

              (let ((repos-dir (string-append doom-local-dir "/straight/repos")))
                (mkdir-p repos-dir)
                (symlink #$(local-file "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/straight.el" #:recursive? #t)
                         (string-append repos-dir "/straight.el"))
                (symlink #$(local-file "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/use-package" #:recursive? #t)
                         (string-append repos-dir "/use-package"))
                (symlink #$(local-file "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/melpa" #:recursive? #t)
                         (string-append repos-dir "/melpa"))
                (symlink #$(local-file "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/gnu-elpa-mirror" #:recursive? #t)
                         (string-append repos-dir "/gnu-elpa-mirror"))
                (symlink #$(local-file "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/el-get" #:recursive? #t)
                         (string-append repos-dir "/el-get"))
                (symlink #$(local-file "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/emacsmirror-mirror" #:recursive? #t)
                         (string-append repos-dir "/emacsmirror-mirror")))

              (setenv "HOME" "/tmp/asdfasdf")
              (mkdir-p "/tmp/asdfasdf")

              ;; (symlink #$(local-file "/home/pharcosyle/work/dotfiles/doom-emacs" #:recursive? #t)
              ;;            (string-append #$output "/temp-doom-emacs"))
              (let ((doom
                     ;; #$(local-file "/home/pharcosyle/work/dotfiles/doom-emacs" #:recursive? #t)
                     (assoc-ref %build-inputs "doom-emacs")
                     ;; (string-append #$output "/temp-doom-emacs")
                     ))
                ;; (invoke (string-append #$(@ (gnu packages base) coreutils) "/bin/echo") "asdfasdfsdf")
                ;; (invoke (string-append doom "/bin/doom") "help")
                (invoke (string-append doom "/bin/doom") "install" "--no-config" "--no-env" "--no-fonts" "--no-hooks")
                )

              ;; (copy-file #$(local-file "nixpkgs-config.nix") #$output)
              )


            #t)))

    ;; (arguments
    ;;  `(;; #:install-plan
    ;;    ;; '(("." "share/doom-emacs/"))
    ;;    ;; #:tests? #t
    ;;    ;; #:test-command '("./bin/doom" "test")
    ;;    #:phases
    ;;    ,#~(modify-phases %standard-phases
    ;;         (add-after 'install 'symlink-bin
    ;;           (lambda _
    ;;             (mkdir #$output:bin)
    ;;             (symlink (string-append #$output "/bin")
    ;;                      (string-append #$output:bin "/bin")))))))

    (synopsis "")
    (description "")
    (home-page "")
    (license #f)))





(use-modules ((guix packages) #:select (content-hash content-hash-algorithm content-hash-value)))

(define doom-build
  (computed-file
   "doom-build"
   (with-imported-modules '((guix build utils))
     #~(begin
         (use-modules (guix build utils))

         ;; (mkdir-p #$output)

         (setenv "GIT_SSL_NO_VERIFY" "true") ; do ssl if it's easy. Also if I'm using `(guix build git) git-fetch' consider if it setting this variable leaks out.

         ;; (invoke (string-append #+doom-emacs:bin "/bin/doom") "help")
         ;; (copy-file #$(local-file "nixpkgs-config.nix") #$output)
         ;; (invoke (string-append #$(@ (gnu packages wget) wget) "/bin/wget") "--no-check-certificate" "https://xkcd.com/")
         ;; (copy-file "index.html" #$output)

         ;; TODO Consider making e.g. emacs, git not ungexped in a let but instead everywhere they're used (and move this let outside of the gexp). Then I could use file-append instead of string-append in places I guess. Which is better practice?
         (let ((doom-private #+(file-union "doom-private"
                                           `(("init.el" ,(file-append (local-file "/home/pharcosyle/work/dotfiles/doom-emacs" #:recursive? #t)
                                                                      "/init.example.el"))
                                             ("config.el" ,(file-append (local-file "/home/pharcosyle/work/dotfiles/doom-emacs" #:recursive? #t)
                                                                        "/core/templates/config.example.el"))
                                             ("packages.el" ,(file-append (local-file "/home/pharcosyle/work/dotfiles/doom-emacs" #:recursive? #t)
                                                                          "/core/templates/packages.example.el")))))
               ;; (doom-private #$(local-file "doom-private" #:recursive? #t))
               (doom-local-dir (string-append #$output "/doom-local"))
               (emacs #+emacs-29-pgtk+native-comp)
               (git #+git)
               ;; (emacs (assoc-ref %build-inputs "emacs-29-pgtk+native-comp"))
               ;; (git (assoc-ref %build-inputs "git"))
               (doom-emacs #+temp-doom-emacs)
               ;; (doom-emacs #+doom-emacs)
               ;; (doom-emacs (assoc-ref %build-inputs "doom-emacs"))
               ;; (doom-emacs #$(local-file "/home/pharcosyle/work/dotfiles/doom-emacs" #:recursive? #t))
               )
           (mkdir-p doom-local-dir)

           (setenv "PATH" (string-append (getenv "PATH")
                                         ":" emacs "/bin"
                                         ":" git "/bin"
                                         ":" #+(@ (gnu packages base) coreutils) "/bin" ; donno if this is necessary
                                         ":" #+(@ (gnu packages base) sed) "/bin"
                                         ))
           ;; Is this a better/cleaner way to do path-setting? Consider also the comment (from git-download.scm), should I add more stuff to the path?
           ;;
           ;; The 'git submodule' commands expects Coreutils, sed,
           ;; grep, etc. to be in $PATH.
           ;; (set-path-environment-variable "PATH" '("bin")
           ;;                                (match '#+inputs
           ;;                                  (((names dirs outputs ...) ...)
           ;;                                   dirs)))

           (setenv "DOOMDIR" doom-private)
           (setenv "DOOMLOCALDIR" doom-local-dir)

           ;; (chdir #$output)
           ;; (invoke "git" "clone" "https://github.com/dracula/gtk")

           ;; donno if this is necessary
           (setenv "HOME" "/tmp/asdfasdf")
           (mkdir-p "/tmp/asdfasdf")

           ;; temporary straight.el experimentation
           ;; (mkdir-p "/tmp/asdfasdf/123456")
           (mkdir-p (string-append doom-local-dir "/straight/repos"))
           (symlink #+(local-file "/home/pharcosyle/work/dotfiles/straight.el" #:recursive? #t)
                    (string-append doom-local-dir "/straight/repos/straight.el"))

           ;; (copy-file #$(local-file "nixpkgs-config.nix") (string-append doom-local-dir "/asdf.txt"))
           ;; (invoke (string-append doom-emacs "/bin/doom") "help")
           (invoke (string-append doom-emacs "/bin/doom") "install" "--no-config" "--no-env" "--no-fonts" "--no-hooks")
           ;; (invoke (string-append doom-emacs "/bin/doom") "upgrade")
           ;; (invoke (string-append doom-emacs "/bin/doom") "build")
           ;; (invoke (string-append doom-emacs "/bin/doom") "sync")

           ;; (invoke (string-append emacs "/bin/emacs") "--batch" "--eval=\"(progn (load user-init-file) (straight-freeze-versions))\"")
           ;; (invoke (string-append emacs "/bin/emacs") "--batch" "--eval='(progn (message \"hello!\"))'")
           ;; (invoke "emacs" "--batch" "--eval='(message \"hello!\")'")
           ;; (chdir #$output)
           ;; (invoke "emacs" "--batch" "--eval='(with-temp-file \"asdf.txt\" (insert \"asdfasdf\"))'")
           ;; (invoke "emacs" "--batch" "--eval='(message \"hello!\")'")
           ;; (invoke "emacs" "--help")
           ;; (invoke "echo" (string-append (string-append emacs "/bin/emacs") "--batch" (string-append "--load=" doom-emacs "/init.el") "--eval=(progn (message \"hi\") (message \"yo\"))"))
           ;; (invoke (string-append emacs "/bin/emacs") "--batch" (string-append "--load=" doom-emacs "/init.el") "--eval=(progn (message \"hi\") (straight-freeze-versions) (message \"yo\"))")
           ;; (invoke "echo" "asdf")

           )))
   #:options (let ((ch (content-hash "1zcpkabkizadc3j9jqnnpyqm4d71bnvxz2x6as53f6wjwn82ahd9")))
               (list #:hash (content-hash-value ch)
                     #:hash-algo (content-hash-algorithm ch)
                     #:recursive? #t
                     ;; #:substitutable? #f ; This isn't appropriate, right?
                     ))))

;; (define-public doom-build-pkg
;;   (package
;;     (name "doom-build-pkg")
;;     (version "0")
;;     (source doom-build)
;;     (build-system (@ (guix build-system copy) copy-build-system))
;;     (synopsis "")
;;     (description "")
;;     (home-page "")
;;     (license #f)))
#+end_src
******* second attempt
Had =:tangle (meta-in-dir "packaging-wip-2.scm") :comments link=
#+begin_src scheme :tangle no
(define-module (phrenetic packaging-wip)
  ;; #:use-module (guix build-system trivial)
  ;; #:use-module (guix gexp)
  ;; #:use-module (guix git-download)
  ;; #:use-module (guix packages)
  ;; #:use-module ((guix licenses) #:prefix license:)
  ;; ;; #:use-module ((gnu packages emacs) #:select (emacs))
  ;; #:use-module ((gnu packages version-control) #:select (git))
  ;; #:use-module (phrenetic packages emacs)
  ;; #:use-module (phrenetic packages doom-emacs)

  #:use-module ((guix packages) #:select (package-input-rewriting))
  #:use-module ((gnu packages emacs) #:select (emacs emacs-minimal emacs-no-x emacs-next emacs-next-pgtk emacs-xwidgets emacs-no-x-toolkit emacs-wide-int))

  )
(define emacs-variant (@ (phrenetic packages emacs) emacs-29-pgtk+native-comp))

;; TODO does this rewrite recursively?
;; package-input-rewriting/spec says it specifically does this while package-input-rewriting does not. And what about using `package-mapping'? I can check the final product for references to emacs/emacs-minimal but still read over the source code of each later. What about native-inputs, sometimes emacs(-minimal) is in there.
;; TODO do I need to specify all of the different emacs packages for rewriting?
;; Does it work without doing this already? Would package-input-rewriting/spec handle them somehow? Does `package/inherit' (in both the -spec and non-spec versions)?
(define with-emacs-variant
  (package-input-rewriting `((,emacs . ,emacs-variant)
                             (,emacs-minimal . ,emacs-variant)
                             (,emacs-no-x . ,emacs-variant)

                             ;; TODO maybe ths should be in a nested `package-input-rewriting' or having packages with themselves as input rewrites
                             ;; will cause problems, I donno. Putting this here for now.
                             (,(@ (gnu packages emacs-xyz) emacs-dash) . ,(@ (phrenetic packages emacs-xyz) emacs-dash)))))

;; (define-public test-reftex
;;   (with-emacs-variant (@ (gnu packages emacs-xyz) emacs-company-reftex)))
;; (define-public test-dash-existing
;;   (with-emacs-variant (@ (gnu packages emacs-xyz) emacs-dash)))
;; (define-public test-dash
;;   (with-emacs-variant (@ (phrenetic packages emacs-xyz) emacs-dash)))

;; (define orig-pkg (@ (gnu packages emacs-xyz) emacs-build-farm))
;; (define orig-pkg (@ (gnu packages emacs-xyz) emacs-cider))
(define orig-pkg (@ (gnu packages emacs-xyz) emacs-buttercup))

(define-public test-pkg
  (with-emacs-variant orig-pkg))





(use-modules (guix packages)
             (guix git-download))

(define (git-origin url commit hash recursive?)
  (origin
    (method git-fetch)
    (uri (git-reference
          (url url)
          (commit commit)
          (recursive? recursive?)))
    (sha256
     (base32
      hash))))



(use-modules (gnu packages)
             (guix profiles)
             ;; ((srfi srfi-1) #:select (remove))
             ;; (phrenetic utils)
             )

;; (define (doom-ps)
;;   (->> (call-with-input-file "../doom-packaging/guix-doom-emacs-packages-from-straight-build-cache.txt" read)
;;        (remove
;;         (lambda (dpns)
;;           (member dpns (list "donnager"

;;                              "straight"

;;                              ;; TODO built-in, ignoring for now but handle this when grabbing from ~doom-packages~. It marks them as ~:ignored t~
;;                              ;; - but what about built-in 'prefer, this isn't marked specially
;;                              "hideshow"
;;                              "vc"
;;                              "vc-annotate"
;;                              "smerge-mode"
;;                              "elisp-mode"
;;                              "css-mode"

;;                              "org-elpa"
;;                              "melpa"
;;                              "gnu-elpa-mirror"
;;                              "el-get"
;;                              "emacsmirror-mirror"
;;                              ))))))

(define (emacs-ps)
  (map (lambda (x)
         (string-append "emacs-" x))
       (doom-ps)))

;; (display
;;  (map (lambda (x)
;;         (find-best-packages-by-name x #f))
;;       (emacs-ps)))

;; (display
;;  (->> (emacs-ps)
;;       (map (lambda (x)
;;              (let ((found (find-best-packages-by-name x #f)))
;;                (if (null? found)
;;                  x '()))))
;;       (remove null?)))

(use-modules (gnu packages emacs-xyz)
             (phrenetic packages emacs-xyz)
             ;; (phrenetic packages emacs-xyz-batch)
             )

(define (str->pkg x)
  (primitive-eval
   (string->symbol
    (if (equal? "emacs-git-modes" x)
        "git-modes"
        x))))

;; (let ((the-manifest
;;        (packages->manifest
;;         (map str->pkg (emacs-ps)))))
;;   ;; (display the-manifest)
;;   #f)






(use-modules ((guix base32) #:select (bytevector->nix-base32-string))
             ((guix build git) #:select (git-fetch) #:prefix other:)
             (guix build utils)
             ((guix hash) #:select (file-hash*)))

(define* (git-checkout-hash url commit #:key recursive?)
  (let ((dir (string-append "/tmp" "/8888")))
    (when (file-exists? dir)
      (delete-file-recursively dir))
    (if (other:git-fetch url commit dir
                         #:recursive? recursive?
                         ;; #:git-command (string-append #+git "/bin/git")
                         )
        (let ((hash (bytevector->nix-base32-string (file-hash* dir))))
          (delete-file-recursively dir)
          hash)
        #f)))


(define (test-get-hash)
  (display
   (git-checkout-hash
    "https://github.com/emacs-evil/evil-surround"
    "282a975bda83310d20a2c536ac3cf95d2bf188a5"
    #:recursive? #t)))

;; (test-get-hash)


(define* (find-hash doom-pkg p commit #:key recursive?)
  (let ((hasher (lambda (url)
                  (git-checkout-hash url commit #:recursive? recursive?))))
    (as-> hasher $
          ($ (if (equal? (-> p package-source origin-method) git-fetch)
                 (-> p
                     package-source
                     origin-uri
                     git-reference-url)
                 (string-append "https://github.com/emacs-straight/" doom-pkg)))
          (if $ $ "NONE_FOUND"))))

;; TODO later: maybe don't look for hashes if the requested commit is already in the Guix package
;; - and maybe if the hashes turn out to be the same after doing `git-checkout-hash', presumably
;; because the Guix package had a git tag or something but it ended up being the same as the
;; Doom-requested commit, don't save the hash? Meh.
;; TODO maybe don't write out the hashes file
;; Just cache the results somehow in the guix store so hash generation can be run as-needed
(define (hashes ps)
  (let ((commits (call-with-input-file "../doom-packaging/straight-commits.txt" read)))
    (map
     (lambda (doom-pkg)
       (let* ((p (str->pkg (string-append "emacs-" doom-pkg)))
              (commit (assoc-ref commits doom-pkg))
              (hash (find-hash doom-pkg p commit #:recursive? #t)))
         (kvm #:package doom-pkg
              #:commit commit
              #:hash hash)))
     ps)))

(define (spit f content)
  (call-with-output-file f
    (lambda (port)
      (write content port))))

;; (define write-hashes (partial spit "../doom-packaging/hashes.txt"))

;; (write-hashes
;;  (hashes (list "restart-emacs" "smartparens")))
;; (write-hashes (doom-ps))
#+end_src
******* active WIP
******** clojure part
********* clj file
I had =:tangle phrenetic/src/protostar/hickeyland.clj :comments link= for the source block options here.
#+begin_src clojure :tangle no
(ns protostar.hickeyland
  (:require [clojure.alpha.spec :as s]
            [clojure.edn :as edn]
            [clojure.java.io :as io]
            [clojure.string :as str]))

;; TODO At end: just maybe try doing this, slurp, any anything else impure as some sort of "coeffects"
(defn- file-exists? [f]
  (.exists (io/file f)))


(s/defop nospec [_]
  any?)



(s/def ::str->edn (s/conformer edn/read-string)) ; TODO donno if I want to use this or just do it in clojure code (is that more idiomatic then writing a spec/conformer for everything?)


(s/def :char/blank #{\space \tab})
;; (s/def :char/newline #{\newline}) ; TODO remvoe if not needed

(s/def ::text->lines (s/conformer str/split-lines)) ; TODO donno if I want to use this or just do it in clojure code (is that more idiomatic then writing a spec/conformer for everything?)

(s/def ::str->chars (s/conformer seq))
(s/def ::chars->str (s/conformer (partial apply str)))



;; TODO would this be better / more flexible if I made it check validity (`valid?`) and then did conforming in a separate step?
;; TODO s/defop works currently but might not be the idiomatic way to do this
(s/defop s-filter [spec]
  (s/conformer
   (fn [xs]
     (keep (fn [x]
             (let [conformed (s/conform spec x)]
               (when-not (s/invalid? conformed)
                 conformed)))
           xs))))


(s/def :elisp/form any?)
(s/def :elisp/t #{t})
(s/def :elisp/list->car (s/conformer first)) ; TODO remove if not needed
(s/def :elisp/list->cdr (s/conformer next)) ; TODO remove if not needed
(s/def :elisp/plist->map (s/conformer (partial apply hash-map))) ; TODO remove if not needed
(s/def :elisp/nil-or-non-nil :elisp/form) ; TODO think this (perhaps just the name) through more?


(s/def :epkg.dep/name symbol?)
(s/def :epkg.dep/version (nospec string?))
(s/def :epkg.dep/name+ver (s/cat :name :epkg.dep/name
                                 :_version (s/? (nospec :epkg.dep/version))))
(s/def :epkg.dep/name+ver->name
  (s/conformer (fn [[form x]]
                 (case form
                   :name x
                   :name+ver (:name x)))))
(s/def :epkg/dep (s/or :name :epkg.dep/name
                       :name+ver :epkg.dep/name+ver))

(s/def :epkg/deps (s/coll-of :epkg/dep))
(s/def :epkg/deps->name-strs
  (s/coll-of (s/and
              :epkg.dep/name+ver->name
              (s/conformer str))))

;; Testing
;; (def test-deps '((emacs "24.1") another (seq) (cl-lib "0.5")))
;; (s/valid? :epkg/deps test-deps)
;; (s/explain-str :epkg/deps test-deps)
;; (s/conform :epkg/deps test-deps)
;; (s/conform
;;  (s/and
;;   :epkg/deps
;;   :epkg/deps->name-strs)
;;  test-deps)

;; TODO ideally do this better / more flexibly / maybe faster
(s/def :epkg.simple/req-header-name
  (s/&
   (s/+ char?)
   ::chars->str
   #(= "Package-Requires:" %))) ; TODO (if keeping things this way) could this just be a literal set predicate?

(s/def :epkg.simple/req-header-line
  (s/and
   ::str->chars
   (s/cat :_comment (s/&
                     (s/+ #{\;})
                     ::chars->str)
          :_ws (s/&
                (s/* :char/blank)
                ::chars->str)
          :_req-header :epkg.simple/req-header
          :_ws2 (s/&
                 (s/* :char/blank)
                 ::chars->str)
          :deps (s/&
                 (s/* char?)
                 ::chars->str
                 ::str->edn
                 :epkg/deps))))

(s/def :epkg.simple/reqs
  (s/and
   ::text->lines
   (s-filter :epkg.simple/req-header-line)
   ;; TODO spec that there should be exactly :count 1?
   (s/conformer first)
   ;; TODO what was I trying here?
   ;; (s/conformer (fn [xs]
   ;;                (or (first xs) :clojure.alpha.spec/invalid)))
   ))

;; Testing
;; (def test-pkgrequires-line ";; Package-Requires: ((emacs \"24.1\") (cl-lib \"0.5\"))")
;; (s/conform :epkg.simple/reqs (str "asdf\n" test-pkgrequires-line))
;; (s/explain-str :epkg.simple/reqs test-pkgrequires-line)

(s/def :epkg.multifile/reqs
  (s/cat :_define-package #{define-package}
         :_name (nospec string?)
         :_version (nospec :epkg.dep/version)
         :_docstring (s/? (nospec string?))
         :requirements (s/? (s/cat
                             :quote #(= (symbol (str \')) %) ; "Artifact" of `edn/read-string`.
                             :form :epkg/deps))
         :_extra (s/* (nospec nil))))

;; Testing
;; (s/conform :epkg.multifile/reqs {:pname "magit" :dir "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/magit/lisp"})
;; (s/conform :epkg.multifile/reqs (edn/read-string (slurp "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/magit/lisp/magit-pkg.el")))
;; (s/explain-str :epkg.multifile/reqs (edn/read-string (slurp "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/magit/lisp/magit-pkg.el")))
;; (s/conform :epkg.multifile/reqs "asdf")
;; (s/conform :epkg.multifile/reqs (edn/read-string (slurp "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/drag-stuff.el/drag-stuff-pkg.el")))

;; TODO Might not need to test if file-exists for simple packages, is there always a packagename.el file? Or should always be one if there's no -pkg.el so its find to have it as a fallthrough case?
;; TODO maybe do coeffects if it's easy
;; Maybe see my now-deleted cofx attempts
(s/def :epkg/reqs->deps
  (s/or :multifile
        (s/and
         (s/conformer
          (fn [{:keys [pname dir]}]
            (let [f (str dir "/" pname "-pkg.el")]
              (if (file-exists? f)
                (-> f slurp edn/read-string)
                :clojure.alpha.spec/invalid))))
         :epkg.multifile/reqs
         (s/conformer #(get-in % [:requirements :form])))
        :simple
        (s/and
         (s/conformer
          (fn [{:keys [pname dir]}]
            (let [f (str dir "/" pname ".el")]
              (if (file-exists? f)
                (-> f slurp edn/read-string)
                :clojure.alpha.spec/invalid))))
         :epkg.simple/reqs
         (s/conformer :deps))))

(defn epkg-dependencies [name dir]
  (let [deps
        (s/conform
         (s/and
          :epkg/reqs->deps
          (s/conformer (fn [[_ reqs]] reqs))
          :epkg/deps->name-strs)
         {:pname name :dir dir})]
    (when-not (s/invalid? deps)
      deps)))

;; Testing
;; (epkg-dependencies "magit" "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/magit/lisp")
;; (println (epkg-dependencies "dash" "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/dash"))
;; (println (epkg-dependencies "helpful" "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/helpful"))
;; (println (epkg-dependencies "evil" "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/evil"))
;; (println (epkg-dependencies "drag-stuff" "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/drag-stuff.el"))
;; (println (slurp "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/evil/evil-pkg.el"))




(s/def ::forge-repo
  (s/and
   ::str->chars
   (s/cat :user-name (s/&
                      (s/+ char?)
                      ::chars->str)
          :slash #{\/}
          :repo-name (s/&
                      (s/+ char?)
                      ::chars->str))))

(s/def ::glob string?)

(s/def ::recipe-subdirective
  (s/alt :subdir string?
         :exclude #{:exclude}))

(s/def ::recipe-defaults #{:defaults})




; TODO better sha and ref specs
(s/def :git/sha string?)
(s/def :git/ref string?)

(s/def :melpa.recipe.files/element
  (s/alt :glob ::glob
         :sublist (s/nest
                   (s/cat :subdirective ::recipe-subdirective
                          :elements (s/+ :melpa.recipe.files/element)))))
(s/def :melpa.recipe/files
  (s/cat
   :defaults (s/? ::recipe-defaults)
   :elements (s/* :melpa.recipe.files/element)))

(s/def :melpa.recipe/name symbol?)
(s/def :melpa.recipe/fetcher #{git hg github gitlab})
(s/def :melpa.recipe.vc/url string?)
(s/def :melpa.recipe.forge/repo ::forge-repo)
;; TODO nb: "commit" is used only once in all of the melpa recipes. Do doom/straight even consider it?
(s/def :melpa.recipe.git/commit (s/or :git/sha
                                      :git/ref))
(s/def :melpa.recipe.git/branch string?) ; TODO do better spec? It can be a git or hg branch, right?
;; -- originial position of :melpa.recipe/files before I moved it up --
;; TODO nb: ignoring :version-regexp and :old-names, I don't care about them, right (straight doesn't seem to)? And I'm excluding from even this validation spec stuff I don't care about, right? Or just maybe spec them but do a `s/select` that doesn't include them (or use `nospec`)? Remember to add them to :melpa.recipe/schema.

(s/def :melpa.recipe/props
  (s/schema {;; :melpa.recipe/name
             :fetcher :melpa.recipe/fetcher
             :files :melpa.recipe/files}))

(s/def :melpa.recipe/vc-props
  (s/schema {:url :melpa.recipe.vc/url}))

(s/def :melpa.recipe/forge-props
  (s/schema {:repo :melpa.recipe.forge/repo}))

(s/def :melpa.recipe/git-props
  (s/schema {:commit :melpa.recipe.git/commit
             :branch :melpa.recipe.git/branch}))

(defmulti melpa-recipe-fetcher :fetcher)

(defmethod melpa-recipe-fetcher 'git [_]
  (s/select
   (s/union :melpa.recipe/props
            :melpa.recipe/vc-props
            :melpa.recipe/git-props)
   [:url]))
(defmethod melpa-recipe-fetcher 'hg [_]
  (s/select
   (s/union :melpa.recipe/props
            :melpa.recipe/vc-props)
   [:url]))
(defmethod melpa-recipe-fetcher 'github [_]
  (s/select
   (s/union :melpa.recipe/props
            :melpa.recipe/forge-props
            :melpa.recipe/git-props)
   [:repo]))
(defmethod melpa-recipe-fetcher 'gitlab [_]
  (s/select
   (s/union :melpa.recipe/props
            :melpa.recipe/forge-props
            :melpa.recipe/git-props)
   [:repo]))

(s/def :melpa/recipe
  (s/cat
   :name (nospec :melpa.recipe/name)
   :props
   (s/&
    (s/* :elisp/form)
    #(even? (count %))
    :elisp/plist->map
    (s/multi-spec melpa-recipe-fetcher :fetcher))))

;; Testing
;; (def test-melpa-recipe '(yasnippet :repo "joaotavora/yasnippet"
;;                                    :fetcher github
;;                                    :files ("yasnippet.el" "snippets")))
;; (s/conform :melpa/recipe test-melpa-recipe)
;; (s/explain-str :melpa/recipe test-melpa-recipe)



(s/def :straight.recipe-repo/name symbol?)

(s/def :straight.recipe/name symbol?) ; Maybe spec this so I can accept the argument to `straight-use-package` (for other users who use straight): doom doesn't take this just the rest of the recipe plist. Update: also need it for :includes.
(s/def :straight.recipe/local-repo string?)
;; TODO maybe some of the sub-stuff in :straight.recipe/files should be `nospec` or have leading keywork underscores.
(s/def :straight.recipe/files
  (s/*
   (s/alt :glob ::glob
          :pair (s/cat :car string?
                       :dot #{.}
                       :cdr string?)
          :sublist (s/nest
                    (s/cat :subdirective ::recipe-subdirective
                           :elements (s/+ :straight.recipe/files)))
          :defaults ::recipe-defaults)))
(s/def :straight.recipe/flavor #{melpa})
(s/def :straight.recipe/build any?) ; TODO. Had #{nil t}, it would be better to use :elisp/t but set specs take literal, not spec, values
(s/def :straight.recipe/pre-build any?) ; TODO
(s/def :straight.recipe/post-build any?) ; TODO
(s/def :straight.recipe/type #{git built-in})
(s/def :straight.recipe/source (s/or :one :straight.recipe-repo/name
                                     :many (s/coll-of :straight.recipe-repo/name)))
(s/def :straight.recipe/includes (s/or :one :straight.recipe/name
                                       :many (s/coll-of :straight.recipe/name)))
(s/def :straight.recipe/inherit :elisp/nil-or-non-nil)
(s/def :straight.recipe.git/host #{nil github gitlab bitbucket})
(s/def :straight.recipe.git/branch string?)
(s/def :straight.recipe.git/remote string?)
(s/def :straight.recipe.git/nonrecursive :elisp/nil-or-non-nil)
(s/def :straight.recipe.git/fork any?) ; TODO
(s/def :straight.recipe.git/depth (s/or :full #{full}
                                        :n integer?))
(s/def :straight.recipe.git/protocol #{https ssh})
(s/def :straight.recipe.git/upstream any?) ; TODO


(s/def :straight.recipe/props
  (s/schema {;; :straight.recipe/name
             :local-repo :straight.recipe/local-repo
             :files :straight.recipe/files
             :flavor :straight.recipe/flavor
             :build :straight.recipe/build
             :pre-build :straight.recipe/pre-build
             :post-build :straight.recipe/post-build
             :type :straight.recipe/type
             :source :straight.recipe/source
             :includes :straight.recipe/includes
             :inherit :straight.recipe/inherit}))

(s/def :straight.recipe/git-props
  (s/schema {;; :repo :straight.recipe.git/repo
             :host :straight.recipe.git/host
             :branch :straight.recipe.git/branch
             :remote :straight.recipe.git/remote
             :nonrecursive :straight.recipe.git/nonrecursive
             :fork :straight.recipe.git/fork
             :depth :straight.recipe.git/depth
             :protocol :straight.recipe.git/protocol
             :upstream :straight.recipe.git/upstream}))


(s/def :straight/repository-url string?)

(defmulti straight-recipe-git-host :host)

(defmethod straight-recipe-git-host nil [_]
  (s/select {:repo :straight/repository-url} [:repo]))
(defmethod straight-recipe-git-host 'github [_]
  (s/select {:repo ::forge-repo} [:repo]))
(defmethod straight-recipe-git-host 'gitlab [_]
  (s/select {:repo ::forge-repo} [:repo]))
(defmethod straight-recipe-git-host 'bitbucket [_]
  (s/select {:repo ::forge-repo} [:repo]))


(def straight-default-vc 'git)

(defmulti straight-recipe-type #(get % :type straight-default-vc))

(defmethod straight-recipe-type 'git [_]
  (s/and
   (s/union :straight.recipe/props
            :straight.recipe/git-props)
   (s/multi-spec straight-recipe-git-host :host)))
(defmethod straight-recipe-type 'built-in [_]
  (s/schema {}))


(s/def :straight.recipe/props-asdf
  (s/&
   (s/* :elisp/form)
   #(even? (count %))
   :elisp/plist->map
   (s/multi-spec straight-recipe-type :type)))

;; TODO I don't think I need this for anything
(s/def :straight/recipe
  (s/cat
   :name (nospec :straight.recipe/name)
   :props :straight.recipe/props-asdf))


(s/def :doom.package/name symbol?)
(s/def :doom.package/type #{core local built-in virtual}) ; Depending on where I'm doing "checking for stuff I explicitly don't support" either remove local/built-in/(maybe)virtual here or check for them elsewhere
(s/def :doom.package/recipe :straight.recipe/props-asdf)
(s/def :doom.package/disable :elisp/t)
(s/def :doom.package/ignore :elisp/t)
(s/def :doom.package/pin :git/sha)
;; TODO nb: not speccing :modules (for now?)

(s/def :doom.package/props
  (s/schema {:type :doom.package/type
             :recipe :doom.package/recipe
             :disable :doom.package/disable
             :ignore :doom.package/ignore
             :pin :doom.package/pin}))

(s/def :doom/package
  (s/cat
   :name :doom.package/name
   :props
   (s/&
    (s/* :elisp/form)
    #(even? (count %))
    :elisp/plist->map
    :doom.package/props)))


#_(defn parse-doom-packages []
  (as-> (slurp "/home/pharcosyle/work/phrenetic/doom-packaging/my-doom-packages.el") $
    (edn/read-string $)
    (map parse-doom-package $)
    ;; TODO later: this is Doom-specific, move it out of the main "guix-emacs-generator"
    (remove #(= (:package/name %) "straight") $)
    (remove :package/deactivated? $)))



(s/def ::todo any?)

;; (s/def :fex.repo/user-name ::todo)
;; (s/def :fex.repo/repo-name ::todo)
;; (s/def :fex/repo
;;   (s/schema [:fex.repo/user-name
;;              :fex.repo/repo-name]))

(s/def :fex.package/url ::todo)
;; (s/def :fex.package/forge #{:forge/github
;;                             :forge/gitlab
;;                             ;; :forge/bitbucket
;;                             })
;; (s/def :fex.package.forge/repo :fex/repo) ; TODO maybe just use :fex/repo or ::forge-repo (and make the current ::forge-repo be ::forge-repo-str or something)
(s/def :fex.package/branch ::todo)
(s/def :fex.package/nonrecursive? #{true})
(s/def :fex.package/files :melpa.recipe/files) ; TODO This is "inheritance", maybe make this a "shared" spec like ::recipe-defaults or just allow :melpa.recipe/files as a key in :fex/package (maybe even rename it to ::melpa-style-files or something)

(s/def :fex/package
  (s/schema [:fex.package/url
             ;; :fex.package/forge
             ;; :fex.package.forge/repo
             :fex.package/branch
             :fex.package/nonrecursive?
             :fex.package/files]))





(def ^:private forge-domains
  {'github "github.com"
   'gitlab "gitlab.com"
   'bitbucket "bitbucket.com"})

(defn forge-repo-url [forge user-name repo-name]
  (str "https://" (get forge-domains forge) "/" user-name "/" repo-name ".git"))


(require '[clojure.set :refer [rename-keys]])
(defn select-and-rename-keys [m kmap]
  (as-> m $
    (select-keys $ (keys kmap))
    (rename-keys $ kmap)))






(defmacro defkmultis [& methods]
  (let [create (fn [name]
                 `(defmulti ~name ~(fn [k & _] k)))]
    `(do
       ~@(map create methods))))

(defmacro defkmethods [k & methods]
  (let [register
        (fn [[name argslist & body]]
          `(defmethod ~name ~k ~(vec (cons '_ argslist)) ~@body))]
    `(do
       ~@(map register methods))))





;; Archives
(defkmultis
  ;; has-recipe
  get-recipe) ; TODO maybe rename this get-package or something, I'm returning fex packages, not straight/melpa recipes


(defn gnu-elpa-mirror-recipe-filename [p]
  (str "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/gnu-elpa-mirror" "/" p))

(defkmethods
  :archive/gnu-elpa-mirror
  (get-recipe [p] (let [f (gnu-elpa-mirror-recipe-filename p)]
                    ;; TODO straight checks against straight-recipes-gnu-elpa-ignored-packages for this archive, I might need to do that too. There are other notes on this already.
                    (when (file-exists? f)
                      {:fex.package/url (forge-repo-url
                                         (symbol :github) "emacs-straight" p)
                       :fex.package/files {:elements [[:glob "*"]]}})))) ; TODO straight also has ~(:exclude ".git")~ here but I don't think I need that.

(defn melpa-recipe-filename [p]
  (str "/home/pharcosyle/.local/var/lib/doom-local/straight/repos/melpa/recipes" "/" p))

(defkmethods
  :archive/melpa
  ;; (has-recipe [p] (file-exists? (melpa-recipe-filename p)))
  (get-recipe [p] (let [f (melpa-recipe-filename p)]
                    (when (file-exists? f)
                      (let [text (slurp f)
                            parsed
                            (s/conform (s/and
                                        ::str->edn
                                        :melpa/recipe
                                        (s/conformer :props))
                                       text)]
                        ;; TODO check that `parsed` is not invalid?
                        ;; TODO "supported"-ness: this might be the place to check that the melpa recipe fetcher isn't 'hg. Alternatively, or perhaps preferably (it would match straight's behavior) just report there's no package if the fetcher is 'hg (or isn't 'git, 'github, or 'gitlab)
                        ;; TODO additional things straight does for this archive: adds -pkg.el to :files and sets flavor to melpa. Donno if I need these. There are other todos/notes on these already
                        (merge
                         {:fex.package/url (let [fetcher (:fetcher parsed)]
                                             (condp some #{fetcher}
                                               #{'git} (:url parsed)
                                               #{'github 'gitlab} (let [repo (:repo parsed)]
                                                                    (forge-repo-url
                                                                     fetcher
                                                                     (:user-name repo)
                                                                     (:repo-name repo)))))}
                         (select-and-rename-keys
                          parsed {:branch :fex.package/branch
                                  :files :fex.package/files})
                         ;; TODO not using, remove
                         ;; (when-let [files (:files parsed)]
                         ;;   {:fex.package/files (s/unform :melpa.recipe/files files)})
                         ))))))

;; Testing
;; (get-recipe :archive/melpa "yasnippet")

;; TODO I don't think the lisp/* bits are necessary since these already have :defaults but for now I've copied the :files over just like they are in straight.
(defkmethods
  :archive/org-elpa
  (get-recipe [p] (case p
                    "org"
                    {:fex.package/url "https://git.savannah.gnu.org/git/emacs/org-mode.git"
                     :fex.package/files {:defaults :defaults
                                         :elements [[:glob "lisp/*.el"]
                                                    [:sublist
                                                     {:subdirective [:subdir "etc/styles/"]
                                                      :elements [[:glob "etc/styles/*"]]}]]}}
                    "org-contrib"
                    {:fex.package/url "https://git.sr.ht/~bzg/org-contrib"
                     :fex.package/files {:defaults :defaults
                                         :elements [[:glob "lisp/*.el"]]}}
                    nil)))


;; TODO make this configurable (of course) and probably not global (pass it as an argument to functions that use it)
(def archives [:archive/org-elpa
               :archive/melpa
               :archive/gnu-elpa-mirror])

;; TODO probably add emacsmirror, etc archives but make all of the methods throw an exception stating that they're not implemented "yet".
;; (def archive-priority [:archive/org-elpa
;;                        :archive/melpa
;;                        :archive/gnu-elpa-mirror])

;; TODO maybe a way to get these from Doom programatically is to advise `straight-use-recipes` but then I'd have to run `doom--ensure-straight` as well
;; (def doom-recipe-repos
;;   '((org-elpa :local-repo nil)
;;     (melpa              :type git :host github
;;                         :repo "melpa/melpa"
;;                         :build nil)
;;     (gnu-elpa-mirror    :type git :host github
;;                         :repo "emacs-straight/gnu-elpa-mirror"
;;                         :build nil)
;;     (el-get             :type git :host github
;;                         :repo "dimitri/el-get"
;;                         :build nil)
;;     (emacsmirror-mirror :type git :host github
;;                         :repo "emacs-straight/emacsmirror-mirror"
;;                         :build nil)))
;; (def doom-straight-recipe-repositories
;;   '(org-elpa melpa gnu-elpa-mirror el-get emacsmirror-mirror))




(require '[clojure.java.shell :refer [sh]])
(def eb-dir "/home/pharcosyle/work/phrenetic/phrenetic")
(def guix-repl-cmd ["guix" "repl" "-L" "." "--" "phrenetic/packaging-runner.scm"])
(defn sh-call [f & args]
  (apply sh (concat guix-repl-cmd
                    [(name f)]
                    (map pr-str args)
                    [:dir eb-dir])))
;; (sh-call :guix/asdf 6)
(def get-origin-data (partial sh-call :guix/get-origin-data))







(defn get-archive-package [archives package-name]
  (first (map #(get-recipe % package-name) archives)))

(defn package-with-inheritance [package-name package]
  (merge
   (get-archive-package package-name)
   package))






(defn convert-straight-recipe-props-to-package [props]
  (let [; parsed (s/conform :straight.recipe/props-asdf props)
        parsed props]
    ;; TODO check that `parsed` is not invalid?
    ;; TODO "supported"-ness: is this the place to check that there aren't unsupported keys and provided keys have supported values (including that the :files is a valid /melpa/ :files)?
    (merge
     {:fex.package/url
      (let [{:keys [host repo]} parsed]
        (if host
          (forge-repo-url
           host
           (:user-name repo)
           (:repo-name repo))
          repo))}
     (select-and-rename-keys
      parsed {:branch :fex.package/branch})
     (when (:nonrecursive parsed)
       {:fex.package/nonrecursive? true})
     (when-let [files (:files parsed)]
       ;; TODO donno why I want to do it this convoluted way, maybe because I don't want to use the "raw" props?
       {:fex.package/files
        ;; (s/conform :melpa.recipe/files props)
        (->> files
             (s/unform :straight.recipe/files)
             (s/conform :melpa.recipe/files))}))))




;; (def my-doom-packages-test "/home/pharcosyle/work/phrenetic/doom-packaging/my-doom-packages.el")
;; (def my-doom-packages-test "/home/pharcosyle/work/phrenetic/doom-packaging/my-doom-packages-edited.el")
(def my-doom-packages-test "/home/pharcosyle/work/phrenetic/doom-packaging/my-doom-packages-small.el")

(defn test-packages []
  (let [data (-> my-doom-packages-test
                 slurp
                 edn/read-string)
        conformed (s/conform (s/coll-of :doom/package) data)]
    ;; (s/explain (s/coll-of :doom/package) data)
    (as-> conformed $
      (map #(get-in % [:props :recipe]) $)
      (map convert-straight-recipe-props-to-package $))))

;; (test-packages)





(def straight-allow-recipe-inheritance? true)

;; TODO Ideally I think I want to grab any pertinent straight settings from Doom Emacs
;; By serializing them "in the same run" as when I grab e.g `doom-packages`. Update: but wait I won't have straight installed when I do this, perhaps scrape the straight code for sexps or maybe it'll be enough to just get the ones that Doom sets itself (see core-packages.el line 78-97)
;; - default protocol, allow inheritance, the recipe repos Doom sets up, etc
;; - straight-default-vc
;; - look through straight's ~defcustom~s
(def defaults {:recipe/protocol "https"})
;; maybe?:
;; :files '("*.el" "*.el.in" "dir"
;;          "*.info" "*.texi" "*.texinfo"
;;          "doc/dir" "doc/*.info" "doc/*.texi" "doc/*.texinfo" "lisp/*.el"
;;          (:exclude ".dir-locals.el" "test.el" "tests.el" "*-test.el" "*-tests.el")

;; TODO regarding :flavor: read `straight-expand-files-directive' and see if I need this / what I should do about :files. Also read the melpa readme about the rules it has for expanding its :files property
;; - :melpa/recipe shouldn't have a flavor, right? Just straight recipes?
;; - new thoughts
;;   - I might need it to make sure template files are copied over "before build", does that make sense I can't be fucked to think through the ordering at present
;;   - If I do need to consider .el.in files perhaps I can prepreocess the :fex.package/files returned from the melpa archive (but that might not be feasable, the .el.in logic is deep in the melpa/straight files expansion logic)
;;   - The Guix elpa importer doesn't even consider .el.in files, maybe they're super rare
;;   - nb: straight recipe inheritance logic includes :flavor and I'm not presently doing that
;;   - reconcile the Guix elpa importer's file expansion logc with melpa's to make sure it's thorough (not straight's, it's different, but do look it over afterwards anyway)
;; TODO downloading to a cache like the elpa importer does would speed up successive/reattempted runs, no?
;; - assuming that is what it's doing (check). Do those repo caches stick around forever though? Will adding my own interfere with anything?
;; - if it's /really/ fast maybe I could get rid of the later-to-come bump "scripts"'s need to read an existing list of generated packges at all! I wouldn't even have to save it to disk, just the lockfile!
;;   - even if the guix git repositories cache thing is untenable maybe there's some other cache I could write the repos or the generated packages-with-hashes to, even just ~./cache. I'd like to not have to manage a generated packages file if I don't have to
;; TODO handle :host: search "bitbucket" in straight to see stuff that affects hosts. If necessary add a check to make sure a supported host is provided.
;; TODO use value of `straight-built-in-pseudo-packages' (let-alist emacs nadvice python) in addition to elpa.scm's `emacs-standard-library?'? What about `straight-recipes-gnu-elpa-ignored-packages'? What about straight--package-built-in-p and package--builtins (read its doc)?
;; - Straight claims to be able to "deal with built-in packages" even without this variable. How? Something like hlissner does when :built-in is set to 'prefer? Use one
;;   of these approaches instead of making a (brittle) list of built-in pseudo packages?
;; - Remember, sometimes even if a package is built-in it should still be installed (like org)
;; - unrelated: are there any built-in dependencies with newer upstream/external versions? Do I want them?
;;   Perhaps not even proper versions just newer commits in a git repo
;; TODO always include *pkg.el like straight.el::3168 says?
;; Is that just about making sure that dependencies get resolved? It says "linked over" though. But then why wouldn't the other `straight-recipes-REPO-retrieve' methods have it? For
;; the elpa one at least it could be because it includes everything (=:files "*"=)
;; - also see the github melpa readme: "For multi-file packages, the file <NAME>-pkg.el is automatically generated..."
;; - update: shit is the /built/ package (after the :files directive has been "applied", among other things) used for determining dependencies? That's the way straight does it, I was just going to use the "raw" cloned repo to find dependencies. Note that e.g. ghub, magit-secion have their -pkg.el files in a subfolder so assuming -pkg.el lives in the root of the unbuilt repo isn't going to work the way I have it now. Conceivably the same could be true of a regular packagename.el file: it could be in a subdirectory.
;;   - I'll probably have to build the package before I get dependencies like straight does. Is there anything else about building the package, besides doing the :files copying/linking, that could affect the packagename.el and packagename-pkg.el files and thus dependency resolution?
;; TODO do I actually need :includes / consider the org-elpa pseudo repository (look at straight-recipes-org-elpa-retrieve in particular)
;; I think the Doom package declarations of org/org-contrib are inheriting from org-elpa and all that stuff it does with :includes and maybe other stuff /does/ matter?
;; - how does Guix handle org? One package, multiple?
;; TODO consider `straight--convert-recipe'
;; TODO consider straight-built-in-pseudo-packages
;; esp. in straight--convert-recipe
;; TODO consider how straight.el recipe inheritance works
;; esp. in straight--convert-recipe

;; TODO hack
;; Wait to do this until the end when I have a concrete idea of all the stuff I'll have to read (doom packages, melpa recipes...) and how I want to do it.
;; Ideas:
;; - hack scm/edn.scm somehow?
;; - convert `doom-packages` (and melpa recipes) package names to strings on the elisp side
;;   Would be messy with melpa recipes since there's no "elisp-reading phase"
;; - elisp "parseclj"/"parseedn" are nice but they don't solve the 0x0 problem
;;   Are they worth the additional overhead of running them on the elisp side? Again, with melpa there might not /be/ an elisp side
;;   - nice to have but maybe not necessary: handling dotted pairs, t/nil become true/nil
;; - don't use the 0x0 package
(defn icky [x]
  (if (= x "0")
    "0x0" x))

;; TODO probably do this with spec, but wait until a bit later / the end
;; (if-let [unsupported (seq (filter (fn [p]
;;                                       (or (let [type (get p :doom.package/type)]
;;                                             (some (hash-set type) (vector :doom.package.type/local :doom.package.type/built-in)))
;;                                           (let [vc (get-in p (vector :package/recipe :recipe/vc))]
;;                                             (and vc (not= vc :vc/git)))
;;                                           (get-in p (vector :package/recipe :straight.recipe/protocol))
;;                                           (get-in p (vector :package/recipe :straight.recipe/source))
;;                                           (get-in p (vector :package/recipe :straight.recipe/fork))
;;                                           (get-in p (vector :package/recipe :straight.recipe/upstream))
;;                                           (get-in p (vector :package/recipe :straight.recipe/includes))))
;;                                   $))]
;;         (throw (ex-info "Package(s) with unsupported configuration" {:packages unsupported}))
;;         $)
;; TODO NEW stuff I've decided I'm /definitely/ not supporting: fork, source
;; - don't support :build. (At leat for values other than 't, which is harmless and which Doom's org package declaration uses. Maybe just override the Doom org package like I'm going to do for its :pre-build)
;; - don't support :pre-build/:post-build (Doom's org and notmuch packages use :pre-build though, so find probably override those recipes to not have :pre-build steps and make sure the Guix packages for them do what the :pre-build steps would have done).
;; - probably not supporting manually-set inherit property (and straight-allow-recipe-inheritance must be true)
;; - list of straight package props Doom actually uses
;;   host
;;   repo
;;   files
;;   nonrecursive
;;   branch
;;   local-repo
;;   - Only straight has this and it doesn't matter for me
;;   build
;;   - only org (:build t)
;;   pre-build
;;   - only org and notmuch
;;   depth
;;   - only org (:depth 1)
;; - spec that both host and repo must be specified so in inheritance one isn't overridden without the other?
#+end_src
********* deps
Had =:tangle phrenetic/deps.edn :comments link=
#+begin_src clojure :tangle no
{:paths ["src" "resources"]
 :deps {org.clojure/clojure {:mvn/version "1.11.1"}
        org.clojure/alpha.spec {:git/url "https://github.com/clojure/spec-alpha2.git"
                                :sha "99456b1856a6fd934e2c30b17920bd790dd81775"}
        babashka/fs {:mvn/version "0.1.6"}}
 :aliases
 {:run-m {:main-opts ["-m" "protostar.hickeyland"]}
  :run-x {:ns-default protostar.hickeyland
          :exec-fn greet
          :exec-args {:name "Clojure"}}
  :build {:deps {io.github.seancorfield/build-clj
                 {:git/tag "v0.6.3" :git/sha "9b8e09b"
                  ;; since we're building an app uberjar, we do not
                  ;; need deps-deploy for clojars.org deployment:
                  :deps/root "slim"}}
          :ns-default build}
  :test {:extra-paths ["test"]
         :extra-deps {org.clojure/test.check {:mvn/version "1.1.1"}
                      io.github.cognitect-labs/test-runner
                      {:git/tag "v0.5.0" :git/sha "48c3c67"}}}}}
#+end_src
******** guix part
Had =:tangle phrenetic/lokke/ns/phrenetic/packaging-wip.clj :comments link=
#+begin_src clojure :tangle no
(ns phrenetic.packaging-wip
  (:require [guile :refer [command-line]]
            [guile.guix.base32 :refer [bytevector->nix-base32-string]]
            [guile.guix.git :refer [latest-repository-commit]]
            [guile.guix.hash :refer [file-hash*]]
            [guile.guix.store :refer [with-store]]
            [guile.srfi.srfi-11 :as srfi-11]

            [guile.guix.build-system.emacs :refer [emacs-build-system]]
            [guile.guix.git-download :refer [git-fetch git-reference git-file-name]]
            [guile.guix.packages :refer [package origin content-hash]]))

(defn- pair [a b]
  (guile/cons a b))

(defmacro let-values [bindings & body]
  (let [bindings*
        (->> bindings
             (partition 2)
             (map (fn [[names expr]]
                    (list
                     (apply list names) expr))))]
    `(srfi-11/let-values ~bindings*
       ~@body)))

(defn- download-git-repo! [url [ref' ref''] recursive?]
  (let-values
   [[dir commit]
    (with-store store
      (latest-repository-commit store url
                                :ref (pair (symbol ref') ref'')
                                :recursive? recursive?))]
   {:dir dir :commit commit}))

;; (println
;;  (download-git-repo! "https://github.com/raxod502/straight.el.git" [:branch "develop"] false))
;; (println
;;  (download-git-repo! "https://github.com/minad/consult.git" '()))

(defn get-origin-data [url ref recursive?]
  (let [{:keys [dir commit]} (download-git-repo! url ref recursive?)]
   {:commit commit
    :hash (bytevector->nix-base32-string
           (file-hash* dir))}))

;; (println
;;  (get-origin-data "https://github.com/raxod502/straight.el.git" [:branch "develop"] false))





(defn fex-package [package-name url commit recursive? hash]
  (package
   (name (str "emacs-" package-name))
   (version "0.0.1")
   (source
    (origin
     (method git-fetch)
     (uri (git-reference
           (url url)
           (commit commit)
           (recursive? recursive?)))
     (file-name (git-file-name name version))
     (hash
      (content-hash hash))))
   (build-system emacs-build-system)
   ;; (arguments
   ;;  `(#:phases
   ;;    (modify-phases %standard-phases
   ;;      (add-after 'unpack 'move-source-files
   ;;        (lambda _
   ;;          (let ((el-files (find-files "./extensions" ".*\\.el$")))
   ;;            (for-each (lambda (f)
   ;;                        (rename-file f (basename f)))
   ;;                      el-files)))))))
   ;; (native-inputs
   ;;  (list texinfo))
   (home-page nil)
   (synopsis nil)
   (description nil)
   (license nil)))

;; (println
;;  (fex-package "tldr"
;;               "https://github.com/kuanyui/tldr.el"
;;               "7203d1be3dcbf12131846ffe06601933fa874d74"
;;               nil
;;               "1bw6la463l2yfm7rp76ga4makfy4kpxgwi7ni5gxk31w11g26ryk"))




;; (defn call [nm & args]
;;   (let [f (ns-resolve *ns* (symbol nm))]
;;     (apply f args)))

(defn asdf [n]
  (+ 1 n))

(when (< (count (command-line)) 1) ; temporarily let me run this file manually
  (let [f (-> (command-line) second)
        args (-> (command-line) next next)]
    (println
     (let [func
           (case f
             "asdf" asdf)]
       (apply func (map read-string args))))))
#+end_src
******** packaging runner
Had =:tangle (meta-in-dir "packaging-runner.scm")=
#+begin_src scheme :tangle no
(use-modules (lokke ns))
(require #(phrenetic.packaging-wip))
#+end_src
******** test clj
Had =:tangle phrenetic/lokke/ns/phrenetic/test-clj.clj :comments link=
#+begin_src clojure :tangle no
(ns phrenetic.test-clj
  (:require [guile.guix.gexp :as g]
            [guile.guix.packages :refer [package package-description]]))

(println
 (gexp "asdf"))

;; (println
;;  (p/package (name "asdf")))

;; (println
;;  (package-description
;;   (package
;;     (name "asdf")
;;     (version "0")
;;     (source nil)
;;     (build-system nil)
;;     (synopsis "asdf")
;;     (description "asdf3333")
;;     (home-page nil)
;;     (license nil))))

(+ 1 1)
(println 5)

#+end_src
******** test scm
Had =tangle (meta-in-dir "test-scm.scm")=
#+begin_src scheme :tangle no
(use-modules (lokke ns))
(require #(phrenetic.test-clj))
#+end_src
******** elisp
Had =:tangle (meta-in-dir "parse-doom-packages.el")=
- [2022-09-11 Sun] nb: I removed the global lexical arg to emacs-lisp code blocks. Probably doesn't matter.
#+begin_src emacs-lisp :tangle no
(defun m-slurp (f)
  (with-temp-buffer
    (insert-file-contents f)
    (buffer-string)))

(defun m-spit (f content)
  (with-temp-file f
    (insert content)))




(defun m-process ()
  (-as-> (m-slurp "~/work/phrenetic/doom-packaging/my-doom-packages.el") $
         (read $)
         (-map #'-first-item $)
         (-map #'symbol-name $)))

(defun write-doom-pkgs-txt ()
  (m-spit "doom-packaging/guix-doom-emacs-packages.txt"
          (pp (m-process))))





(defun repo-commit (r)
  (let ((default-directory (concat "~/.local/var/lib/doom-local/straight/repos/" r)))
    (straight--process-output "git" "rev-parse" "HEAD")))

(defun write-current-commits ()
  (let ((pkgs-to-repos
         (-map
          (lambda (x)
            (cons
             (-first-item x)
             (-as-> x $
                    (-fourth-item $)
                    (plist-get $ :local-repo))))
          (map-into straight--build-cache 'list))))
    (-map (lambda (x)
            (cons (car x)
                  (if-let ((y (cdr x)))
                      (if (not (equal y "/home/pharcosyle/work/dotfiles/donnager"))
                          (repo-commit y)
                        nil)
                    y)))
          pkgs-to-repos)))

;; (write-current-commits)
#+end_src
***** Doom services
****** Core
#+begin_src scheme
(define* (doom-core #:key
                    stateless?
                    evil?
                    icons?
                    email)
  (append
   (doom-general #:stateless? stateless?
                 #:evil? evil?
                 #:icons? icons?)
   (doom-user #:email email)
   (doom-keymaps)
   (doom-undo #:stateless? stateless?)
   (doom-emacs-lisp)
   (doom-markdown)))
#+end_src
******* General :bindings:
#+begin_src scheme
(define* (doom-general #:key
                       stateless?
                       evil?
                       icons?
                       (childframe? #t))
  (let ((name 'general))
    (cons
     (doom-service
      name
      #:modules
      `((#:completion
         (corfu ,@(if icons? '(+icons) '())
                +orderless
                +dabbrev)
         ;; (company ,@(if childframe? '(+childframe) '()))
         (vertico ,@(if icons? '(+icons) '())))

        (#:ui
         doom
         doom-dashboard
         (emoji +unicode)
         hl-todo
         indent-guides
         (ligatures +extra)
         modeline
         nav-flash
         ophints
         (popup +defaults +all)
         vi-tilde-fringe
         window-select
         workspaces
         zen)

        (#:editor
         ,@(if evil? '((evil +everywhere)) '())
         file-templates
         fold
         format
         lispy
         multiple-cursors
         rotate-text
         snippets
         word-wrap)

        (#:emacs
         electric
         eww
         (ibuffer ,@(if icons? '(+icons) '())))

        (#:checkers
         (syntax ,@(if icons? '(+icons) '())
                 ,@(if childframe? '(+childframe) '())))

        (#:tools
         editorconfig
         (eval +overlay)
         lookup
         (pass +auth)
         pdf
         prodigy)

        (#:config
         (default +bindings +smartparens)))

      #:packages
      '((package! expand-region :pin "e8f4e0fe9c9a80a6a26e2b438502aba9a799d580")
        (package! tldr :pin "1b09d2032491d3904bd7ee9bf5ba7c7503db6593")
        ;; (package! 0x0 :pin "63cd5eccc85e527f28e1acc89502a53245000428") ; TODO `elisp-serialize' makes the `0x0' into `#{0x0}#'.

        (package! fireplace :pin "f6c23e259349922aae25cf2898ba815a7d8f2527")

        ;; TODO TEMPORARY add this to play around with it.
        (package! org-tanglesync :pin "af83a73ae542d5cb3c9d433cbf2ce1d4f4259117"))

      #:config
      (append
       '((setq scroll-margin 10
               save-interprogram-paste-before-kill t)

         ;; I like having line numbers on but hlissner says they're slow so I might want to disable them at some point. Keep in mind I use them to determine what lines are continuation lines so I might have to make the right fringe bigger if I do this and set visual-line-fringe-indicators.
         ;; (setq display-line-numbers-type nil)

         (setq-default indent-tabs-mode t) ; Doom sets this to nil, reset it.

         ;; I'd like to have this on but in the Doom code it says it's more efficient not to.
         ;; (setq-default cursor-in-non-selected-windows t)

         (pixel-scroll-precision-mode)

         (after! bookmark
                 (setq bookmark-save-flag 1))

         (after! doom-modeline
                 ;; (setq doom-modeline-checker-simple-format nil)
                 (setq doom-modeline-major-mode-icon t)
                 (setq doom-modeline-persp-name t))

         ;; I don't want indent guides enabled automatically.
         (add-hook! '+indent-guides-inhibit-functions
                    (lambda () t))

         (use-package! lispy
                       :defer t
                       :init
                       ;; Not using lispy, remove all the Doom module's hooks.
                       (remove-hook! '(lisp-mode-hook
                                       emacs-lisp-mode-hook
                                       ielm-mode-hook
                                       scheme-mode-hook
                                       racket-mode-hook
                                       hy-mode-hook
                                       lfe-mode-hook
                                       dune-mode-hook
                                       clojure-mode-hook
                                       fennel-mode-hook)
                                     #'lispy-mode)
                       (remove-hook! 'eval-expression-minibuffer-setup-hook #'doom-init-lispy-in-eval-expression-h))

         (use-package! lispyville
                       :hook (prog-mode . lispyville-mode)
                       :init
                       (setq lispyville-key-theme nil) ; Prevent Doom module's invocation of `lispyville-set-key-theme' from doing anything.
                       :config
                       (lispyville-set-key-theme
                        '(operators
                          c-w
                          c-u
                          commentary))
                       (map! :map lispyville-mode-map
                             "C-s-j" #'lispyville-beginning-of-next-defun
                             "C-s-k" #'lispyville-beginning-of-defun
                             "C-s-," #'lispyville-end-of-defun
                             "C-s-a" #'lispyville-drag-backward
                             "C-s-g" #'lispyville-drag-forward
                             "C-s-p" #'lispyville-prettify
                             (:prefix "C-s-;"
                              "R" #'lispyville-raise-list)))

         (use-package! expand-region
                       :defer t
                       :init
                       (map! :nv "s-e" #'er/expand-region
                             :nv "s-E" #'er/contract-region)
                       :config
                       (setq expand-region-fast-keys-enabled nil) ; My mapping is conventient enough and I don't want the repeat key to conflict with anything.
                       ;; Copied from Doom config: ~/.config/emacs/modules/config/default/+emacs.el:12
                       (defadvice! biome--quit-expand-region-a (&rest _)
                         "Properly abort an expand-region region."
                         :before '(evil-escape doom/escape) ; TODO `evil-escape': maybe gate with `evil?'
                         (when (memq last-command '(er/expand-region er/contract-region))
                           (er/contract-region 0))))

         ;; REVIEW Trying out not having this so I can use avy dispatch commands.
         ;; (after! avy
         ;;   (setq avy-single-candidate-jump t))

         (after! paren
                 (setq! show-paren-delay 0))

         (add-hook! 'prog-mode-hook #'biome-sp-strict-h)

         (after! rainbow-delimiters
                 ;; Doom sets this to 4 for possible performance reasons. I like having more (and 9 is the rainbow-delimiters default). The Doom base theme defines 9 too so this should look okay on most themes (though if they define their own faces there might be some duplication/clash where their definitions stop and the base theme's start).
                 (setq rainbow-delimiters-max-face-count 9))

         (after! smartparens
                 (map! :map smartparens-mode-map
                       "C-s-h" #'sp-backward-sexp
                       "C-s-l" #'sp-forward-sexp
                       "C-s-u" #'sp-backward-up-sexp
                       "C-s-o" #'sp-up-sexp
                       :gn "C-s-m" #'sp-backward-down-sexp ; Bind in normal mode explicitly to override the Doom mapping in ~/.config/emacs/modules/config/default/config.el:447
                       "C-s-." #'sp-down-sexp
                       "C-s-c" #'sp-splice-sexp
                       "C-s-s" #'sp-splice-sexp-killing-backward
                       "C-s-f" #'sp-splice-sexp-killing-forward
                       "C-s-x" #'sp-backward-slurp-sexp
                       "C-s-v" #'sp-forward-slurp-sexp
                       "C-s-w" #'sp-backward-barf-sexp
                       "C-s-r" #'sp-forward-barf-sexp
                       (:prefix "C-s-;"
                        "(" #'sp-wrap-round
                        "[" #'sp-wrap-square
                        "{" #'sp-wrap-curly
                        "s" #'sp-split-sexp
                        "j" #'sp-join-sexp
                        "r" #'sp-raise-sexp
                        "c" #'sp-convolute-sexp
                        "w" #'sp-rewrap-sexp)))

         (defun biome-sp-strict-h ()
           (add-hook! 'smartparens-enabled-hook :local
                      #'turn-on-smartparens-strict-mode
                      (defun biome-modify-sp-strict-mode-map-h ()
                        (map! :map smartparens-strict-mode-map
                              :i "DEL" #'sp-backward-delete-char)))))

       (if evil?
           '((after! evil
                     (map! :m (vector 'C-i) nil)) ; Remove Doom's binding for `evil-jump-forward'.

             (after! evil-multiedit
                     (setq evil-multiedit-follow-matches t)))
           '())

       (wip-config))

      #:snippets
      `(("clojure-mode" (("bogus" "# -*- mode: snippet -*-\n# name: bogus\n# key: bogus\n# --\n(defn $1\n  \"$2\"$>\n  [$3]$>\n  $0)$>")))))

     (if stateless?
         (list
          (doom-service
           'bookmarks-indirection
           #:config
           ;; The Emacs bookmark package checks the modification time of the bookmarks file and offers to reload it if it changed. In the stateless case the file is a symlink and it's modified on every reconfigure (the symlink is recreated). This both breaks the funcationality (it should be checking the target file, not the symlink) and ressults in annoying prompts on reconfigure.
           '((after! bookmark
                     (setq bookmark-default-file (concat doom-data-dir "bookmarks/bookmarks")))))

          (doom-stateless-service
           name
           #:state '(((#:path . ("autosave/" #:doom-base #:cache))
                      (#:storage . #:storage/machine))
                     ((#:path . ("bookmarks/" #:doom-base #:data))
                      (#:storage . #:storage/persist))
                     ((#:path . ("recentf" #:doom-base #:cache))
                      (#:storage . #:storage/persist))
                     ((#:path . ("savehist" #:doom-base #:cache))
                      (#:storage . #:storage/persist))
                     ((#:path . ("saveplace" #:doom-base #:cache))
                      (#:storage . #:storage/persist))
                     ((#:path . ("tramp" #:doom-base #:cache))
                      (#:storage . #:storage/machine))
                     ((#:path . ("tramp-autosave/" #:doom-base #:cache))
                      (#:storage . #:storage/machine))

                     ((#:path . ("scratch/" #:doom-base #:data))
                      (#:storage . #:storage/persist))

                     ((#:path . ("projects" #:doom-base #:data))
                      (#:storage . #:storage/persist))
                     ((#:path . ("projectile.projects" #:doom-base #:cache))
                      (#:storage . #:storage/persist))
                     ((#:path . ("projectile.cache" #:doom-base #:cache))
                      (#:storage . #:storage/machine))

                     ((#:path . ("workspaces/" #:doom-base #:data))
                      (#:storage . #:storage/machine)))))
         '()))))



;; TODO WIP. Some of this stuff belongs in other components or gated.

(define (wip-config)
  '((after! emojify
            (setq emojify-display-style 'unicode))

    ;; TODO donno where this should go, ~+default-minibuffer-maps~ is a doom thing I guess
    (define-key! :keymaps +default-minibuffer-maps
      "s-J" #'scroll-up-command
      "s-K" #'scroll-down-command)

    ;; I don't think I'll ever need this with Sway. Is it worth keeping this and having an "I'm not on Sway / some WM" conditional around it?
    ;; (add-to-list 'initial-frame-alist '(fullscreen . fullboth))

    (map! "s-&" (lambda (command)
                  (interactive (list (read-shell-command "$ ")))
                  (call-process-shell-command command nil 0 nil)))

    (map! :leader
          "s-," (lookup-key doom-leader-map (kbd "<")))

    ;; (after! company
    ;;         (map! :map company-active-map
    ;;               "s-[" #'company-show-doc-buffer ; Currently opens Help, it would be better if I made it use Helpful.
    ;;               "s-]" #'company-show-location))

    (after! evil-org
            (map! :map evil-org-mode-map
                  (:prefix "g"
                   :nv "{" #'evil-backward-paragraph
                   :nv "}" #'evil-forward-paragraph)))

    ;; Doesn't work yet: you have to switch to the buffer "manually" once before it starts being treated as real
    (map! "s-d m" (cmd! (doom-set-buffer-real (current-buffer) t)))

    ;; `forward-char' in original definition is messing things up, do this for now
    ;; (defun +eshell/search-history ()
    ;;   (interactive)
    ;;   (consult-history))
    (after! esh-mode
            (map! :map eshell-mode-map
                  "C-s" #'consult-history))

    (after! vertico
            (setq vertico-count 20  ; Trying out, maybe too big.
                  vertico-scroll-margin 7))

    (map! (:leader
           "A" #'embark-dwim)
          ;; Trying out cycling (temp)
          "C-:" #'embark-act
          "s-q" #'embark-cycle)

    ;; REVIEW Might be useful if there end up being a lot more of these and they have a lot of similarities: https://www.gnu.org/software/emacs/manual/html_node/elisp/Extending-Rx.html
    ;; TODO `better-jumper-jump-backward' doesn't consider these buffers, that's probably not a problem with `doom-real-buffer-functions' but rather something I have to do specially for it.
    (use-package! s)
    (add-hook! 'doom-real-buffer-functions
               ;; (defun biome-new-buffer-p (buf)
               ;;   (s-matches?
               ;;    (rx bol "*new*"
               ;;        (* "<" (+ digit) ">")
               ;;        eol)
               ;;    (buffer-name buf)))
               ;; TODO This should be in my Org config section / module but wait to move it until I'm confident I'll be continuing with this marking-buffers-as-real approach.
               (defun biome-org-src-edit-buffer-p (buf)
                 (s-matches?
                  (rx bol "*Org Src " (+ anything) "*"
                      (* "<" (+ digit) ">")
                      eol)
                  (buffer-name buf))))

    ;;  TODO Might be easier to do this with file-local variables.
    ;; (setq biome--phrenetic-dir "~/work/phrenetic")
    ;; (add-hook! 'org-mode-hook
    ;;   (defun biome-add-org-autotangle-after-save-hook-h ()
    ;;     (add-hook! 'after-save-hook :local
    ;;       (defun biome-autotangle-h ()
    ;;         (when (file-in-directory-p buffer-file-name biome--phrenetic-dir)
    ;;           ;; TODO ensure there aren't files in the output directory that no longer correspond to the org file. Just wipe it?
    ;;           (let ((org-confirm-babel-evaluate nil))
    ;;             (org-babel-tangle)))))))

    ;; (use-package! org-tanglesync
    ;;   :hook ((org-mode . org-tanglesync-mode)
    ;;          ((prog-mode text-mode) . org-tanglesync-watch-mode))
    ;;   :config
    ;;   (setq org-tanglesync-watch-files '("/home/pharcosyle/work/phrenetic/phrenetic.org")))

    ;; Maybe `s-S' to save-and-tangle? If I don't get some sort of auto-tangling thing going
    ;; - maybe it could be "save and eval defun (C-M-x)" in lisp/programming modes?'
    ;; Maybe a hotkey that just jumps back and forth between my most recently focused browser window and eemacs?
    ;; Maybe bind `s-o' in `consult-buffer' to "close consult-buffer and open +vertico/switch-workspace-buffer"

    (map! "s-o" (lookup-key doom-leader-map (kbd "<")))
    ;; Get rid of binding for =s-r=?
    (map! "s-r" nil)

    ;; Also messes with my sexp-movement bindings
    ;; (map! "C-s-j" #'evil-scroll-down
    ;;       "C-s-k" #'evil-scroll-up)

    (after! evil
            (map! :map evil-motion-state-map
                  ;; Maybe "C-s-o" but then I'll have to change my sexp-movement command(s). There are other bindings for jump-forward though, maybe I'll just use those.
                  "C-S-o" #'evil-jump-forward))))
#+end_src
******* User
#+begin_src scheme
(define* (doom-user #:key email)
  (list
   (doom-service
    'user
    #:config
    `((setq user-mail-address ,email)))))
#+end_src
******* Keymaps :bindings:
#+begin_src scheme
(define (doom-keymaps)
  (append
   (list
    (doom-service
     'keymaps
     #:config
     '((defun biome--trans (&rest rest)
         (-each (-partition 2 rest)
                (-lambda ((to from))
                         (define-key key-translation-map (kbd to) (kbd from)))))

       (biome--trans "C-h" "DEL"
                     "C-?" "C-h"

                     "s-h" "<left>"
                     "s-j" "<down>"
                     "s-k" "<up>"
                     "s-l" "<right>")

       (setq doom-leader-alt-key "s-SPC"
             doom-localleader-key "s-m"
             doom-localleader-alt-key "s-m")

       (defalias 'original-yank-pop #'yank-pop)

       ;; REVIEW Some of these should be in `:after' (or their respective package) sections but I'm not totally certain where I want to put bindings yet and I'm lazy.
       (map! "s-V" #'original-yank-pop

             "s-SPC" doom-leader-map

             ;; Adapted from Doom macOS bindings: ~/.config/emacs/modules/config/default/config.el:263
             "s-`" #'other-frame
             "s-n" #'+default/new-buffer
             "s-z" #'undo
             "s-Z" #'redo
             "s-c" (if (featurep 'evil) #'evil-yank #'copy-region-as-kill) ; TODO If keeping this, gate with `evil?'.
             "s-v" #'yank
             "s-s" #'save-buffer
             "s-x" #'execute-extended-command
             ;; REVIEW I don't think I need this, any time I'm in visual mode I can use `evil-delete` ("d")
             ;; :v "s-x" #'kill-region
             "s-/" (cmd! (save-excursion (comment-line 1)))
             ;; TODO If keeping this, gate with `evil?'.
             :n "s-/" #'evilnc-comment-or-uncomment-lines
             :v "s-/" #'evilnc-comment-operator

             "s-t" (lookup-key doom-leader-map (kbd "`"))
             "s-f" (lookup-key doom-leader-map (kbd "s b"))
             "s-r" (lookup-key doom-leader-map (kbd "f r"))
             "s-w" (lookup-key doom-leader-map (kbd "b k"))
             "s-d w" (lookup-key doom-leader-map (kbd "w d"))
             "s-d s-w" (cmd! (kill-current-buffer)
                             (+workspace/close-window-or-workspace))
             "s-g" (lookup-key doom-leader-map (kbd "g g"))
             "s-," (lookup-key doom-leader-map (kbd "w w"))
             "s-<" (lookup-key doom-leader-map (kbd "w W"))
             "s-y" (lookup-key doom-leader-map (kbd "i y"))
             "s-{" (lookup-key doom-leader-map (kbd "b p"))
             "s-}" (lookup-key doom-leader-map (kbd "b n"))
             "s-p" (lookup-key global-map (kbd "C-~")) ; TODO if I'm keeping this, improve it to first switch focus to a/the popup window if one isn't focused already

             "s-u" (lookup-key doom-leader-map (kbd "u"))
             "s-U" #'negative-argument ; REVIEW Trying this out.
             (:map universal-argument-map
              "s-u" #'universal-argument-more)

             ;; TODO Gate with `evil?'.
             (:after evil-easymotion
              "s-a" (lookup-key evilem-map (kbd "SPC")))

             "s-." #'repeat

             ;; TODO Gate with `evil?'.
             "s-J" #'evil-scroll-down
             "s-K" #'evil-scroll-up

             (:prefix "s-d"
              "." #'repeat-complex-command

              "h" #'git-gutter:popup-hunk
              ;; "o" #'+macos/open-in-default-program ;; TODO consider a Guix alternative? Meh.
              "r" #'projectile-replace
              "t" #'tldr
              "s" #'org-save-all-org-buffers
              "a" #'link-hint-open-multiple-links
              ;; TODO Gate with `evil?'.
              ;; "b" (cmd! (evil-local-mode 'toggle)
              ;;           (when evil-local-mode (evil-normal-state)))
              (:prefix "c"
               "f" #'org-gcal-fetch
               "s" #'org-gcal-sync
               "p" #'org-gcal-post-at-point)))

       ;; TODO wip stuff
       ;; If I keep this I can get rid of the "C-_" binding I have too. Update: maybe? Some places C-_ works and some s-h does (in vertico)? What about my key translation for C-? ? Straighten all this shit out.
       ;; - update: Guile won't accept the help-char string escape the way it is so I've removed it for now:
       ;;   (setq help-char (string-to-char "\C-_"))
       (biome--trans "s-h" "C-h")
       ;; Maybe "C-s-i" but then I'll have to change my sexp-movement command(s). Maybe keep this even if I do that, for consistency.
       (biome--trans "C-S-i" "<backtab>"))))

   (doom-dash)))
#+end_src
******* Undo
#+begin_src scheme
(define* (doom-undo #:key stateless?)
  (let ((name 'undo))
    (list
     (doom-service
      name
      #:modules '((#:emacs
                   undo))
      #:config
      '((after! undo-fu
                (setq undo-fu-ignore-keyboard-quit t))))

     (when stateless?
       (doom-stateless-service
        name
        #:state '(((#:path . ("undo-fu-session/" #:doom-base #:cache))
                   (#:storage . #:storage/machine))))))))
#+end_src
****** Languages
#+begin_src scheme
(define* (doom-ts-lang lang
                       #:key
                       tree-sitter?
                       config)
  (append
   (list
    (doom-service
     lang
     #:modules `((#:lang
                  (,lang ,@(if tree-sitter? '(+tree-sitter) '()))))
     #:config (or config '())))

   (if tree-sitter?
       (doom-tree-sitter) '())))

(define (doom-tree-sitter)
  (list
   (doom-service
    'tree-sitter
    #:modules `((#:tools
                 tree-sitter)))))
#+end_src
******* Emacs Lisp
#+begin_src scheme
(define (doom-emacs-lisp)
  (list
   (doom-service
    'emacs-lisp
    #:modules `((#:lang
                 emacs-lisp))
    #:config
    '((after! elisp-mode
              (setq-hook! 'emacs-lisp-mode-hook indent-tabs-mode nil))))))
#+end_src
******* Javascript
#+begin_src scheme
(define* (doom-javascript #:key tree-sitter?)
  (append
   (doom-ts-lang 'javascript #:tree-sitter? tree-sitter?)
   (doom-ts-lang 'json #:tree-sitter? tree-sitter?)))
#+end_src
******* Markdown
#+begin_src scheme
(define (doom-markdown)
  (list
   (doom-service
    'markdown
    #:modules `((#:lang
                 markdown)))))
#+end_src
******* XML and CSV
#+begin_src scheme
(define (doom-xml+csv)
  (list
   (doom-service
    'xml+csv
    #:modules `((#:lang
                 data)))))
#+end_src
******* Web
#+begin_src scheme
(define* (doom-web #:key tree-sitter?)
  (append
   (doom-ts-lang 'web #:tree-sitter? tree-sitter?)
   (doom-javascript #:tree-sitter? tree-sitter?)

   (list
    (doom-service
     'rest
     #:modules `((#:lang
                  (rest +jq)))))))
#+end_src
****** Libraries
******* Dash
#+begin_src scheme
(define (doom-dash)
  (list
   (doom-service
    'dash
    #:packages
    '((package! dash :pin "1de9dcb83eacfb162b6d9a118a4770b1281bcd84"))
    #:config
    '((use-package! dash)))))
#+end_src
******* Transient
#+begin_src scheme
(define* (doom-transient #:key stateless?)
  (let ((name 'transient))
    (list
     (doom-service
      name
      #:config
      `((after! transient
                (setq transient-history-limit ,very-big-history))))

     (when stateless?
       (doom-stateless-service
        name
        #:state '(((#:path . ("transient/history" #:doom-base #:data))
                   (#:storage . #:storage/persist))))))))
#+end_src
***** Desktop
#+begin_src scheme
(define* (doom-desktop #:key
                       theme
                       light-colors
                       dark-colors
                       font
                       font-variable-pitch
                       font-size)
  (append
   (doom-themes #:theme theme
                #:light-colors light-colors
                #:dark-colors dark-colors)
   (doom-fonts #:font font
               #:font-variable-pitch font-variable-pitch
               #:font-size font-size)))
#+end_src
****** Themes
#+begin_src scheme
(define* (doom-themes #:key
                      theme
                      light-colors
                      dark-colors)
  (let ((light-theme-name 'doom-one-light)
        (dark-theme-name 'doom-nuclear))
    (list
     (doom-service
      'themes
      #:config
      `((setq doom-theme ',(case theme
                             ((#:theme/light) light-theme-name)
                             ((#:theme/dark) dark-theme-name))))
      #:themes
      (append
       (doom-light-theme #:name light-theme-name
                         #:colors light-colors)
       (doom-dark-theme #:name dark-theme-name
                        #:colors dark-colors))))))
#+end_src
******* Light
#+begin_src scheme
;; Nothing here yet.
(define* (doom-light-theme #:key name colors)
  `())
#+end_src
******* Dark
Some colors from the original Atom theme on which I based mine that might be useful:
- ~#363b4e~
  Dark with a bluish tint. Was previously used as the line highlight color.
- ~#666d7a~
#+begin_src scheme
(define* (doom-dark-theme #:key name colors)
  (let ((clr (lambda (color)
               (assoc-ref colors color))))
    `((,name
       ((fg        '(,(clr #:color/fg)      "#bfbfbf" "brightwhite"))
        (bg        '(,(clr #:color/bg)      "black"   "black"))

        (fg-alt    '("#63677f"              "#2d2d2d" "white"))
        (bg-alt    '("#262831"              "black"   "black"))

        (base0     '(,(clr #:color/base0)   "black"   "black"))
        (base1     '("#202229"              "#1e1e1e" "brightblack")) ; (doom-darken "#262831" 0.15)
        (base2     '("#22242c"              "#2e2e2e" "brightblack")) ; (doom-darken "#262831" 0.10)
        (base3     '("#24262e"              "#262626" "brightblack")) ; (doom-darken "#262831" 0.05)
        (base4     '("#484b5b"              "#3f3f3f" "brightblack"))
        (base5     `(,(car fg-alt)          "#525252" "brightblack"))
        (base6     '("#7c82a0"              "#6b6b6b" "brightblack")) ; (doom-darken "#939abd" 0.15)
        (base7     '("#939abd"              "#979797" "brightblack"))
        (base8     '(,(clr #:color/base8)   "#dfdfdf" "white"))

        (grey      base4)
        (red       '(,(clr #:color/red)     "#ff6655" "red"))
        (orange    '(,(clr #:color/orange)  "#dd8844" "brightred"))
        (green     '(,(clr #:color/green)   "#99bb66" "green"))
        (teal      '("#fec0cb"              "#44b9b1" "brightgreen"))
        (yellow    '(,(clr #:color/yellow)  "#ECBE7B" "yellow"))
        (blue      '(,(clr #:color/blue)    "#51afef" "brightblue" ))
        (dark-blue '("#5f68de"              "#2257A0" "blue"))
        (magenta   '(,(clr #:color/magenta) "#c678dd" "brightmagenta"))
        (violet    '(,(clr #:color/violet)  "#a9a1e1" "magenta"))
        (cyan      '(,(clr #:color/cyan)    "#46D9FF" "brightcyan"))
        (dark-cyan '("#cf8191"              "#5699AF" "cyan"))

        (highlight      ,(clr #:color/accent))
        (vertical-bar   base0)
        (selection      dark-blue)
        (builtin        blue)
        (comments       base5)
        (doc-comments   base7)
        (constants      yellow)
        (functions      blue)
        (keywords       magenta)
        (methods        teal)
        (operators      cyan)
        (type           orange)
        (strings        green)
        (variables      red)
        (numbers        dark-cyan)
        (region         `(,(doom-lighten (car bg-alt) 0.15) ,@(doom-lighten (cdr base1) 0.35)))
        (error          red)
        (warning        yellow)
        (success        green)
        (vc-modified    orange)
        (vc-added       green)
        (vc-deleted     red))

       ;; Doom base theme overrides.
       ((cursor :background "#fdd94a")
        ((font-lock-comment-delimiter-face &override) :foreground base7)
        ((font-lock-doc-face &override) :foreground violet)
        ((line-number-current-line &override) :foreground violet)
        (mode-line :background base1 :foreground fg)
        (mode-line-inactive :background base3 :foreground base6)
        (org-block :background (doom-lighten bg-alt 0.02))
        (rainbow-delimiters-depth-1-face :foreground fg)
        (rainbow-delimiters-depth-2-face :foreground magenta)
        (rainbow-delimiters-depth-3-face :foreground blue)
        (rainbow-delimiters-depth-4-face :foreground cyan)
        (rainbow-delimiters-depth-5-face :foreground green)
        (rainbow-delimiters-depth-6-face :foreground yellow)
        (rainbow-delimiters-depth-7-face :foreground orange)
        (rainbow-delimiters-depth-8-face :foreground red)
        (rainbow-delimiters-depth-9-face :foreground teal)

        ;; Custom faces.
        (clojure-character-face :foreground teal :weight 'bold)
        (doom-modeline-bar :background highlight)
        (doom-modeline-buffer-file :inherit 'mode-line-buffer-id :weight 'bold)
        (doom-modeline-buffer-path :inherit 'mode-line-emphasis :weight 'bold)
        (doom-modeline-buffer-project-root :foreground green :weight 'bold)
        (solaire-mode-line-face :inherit 'mode-line :background base0)
        (solaire-mode-line-inactive-face :inherit 'mode-line-inactive :background base2)

        ;; These are present in the `doom-one' theme on which mine is based but I'm not sure if I need or want them. I'm keeping them around for now.
        (css-proprietary-property :foreground orange)
        (css-property :foreground green)
        (css-selector :foreground blue)
        (font-latex-math-face :foreground green)
        (markdown-markup-face :foreground base5)
        (markdown-header-face :inherit 'bold :foreground red)
        ((markdown-code-face &override) :background (doom-lighten base3 0.05))
        (rjsx-tag :foreground red)
        (rjsx-attr :foreground orange))))))
#+end_src
****** Fonts
#+begin_src scheme
(define* (doom-fonts #:key
                     font
                     font-variable-pitch
                     font-size)
  (append
   (list
    (doom-service
     'fonts
     #:config
     `((defun biome--set-font-safe (sym font)
         (when (find-font font)
           (set sym font)))

       (biome--set-font-safe
        'doom-font
        (font-spec :family ,(assoc-ref font #:font/name)
                   :size ,(+ font-size 2)
                   :weight ',(if-let ((weight (assoc-ref font #:font/weight)))
                                     (font-weight->emacs-face-weight weight)
                                     'normal)))
       (biome--set-font-safe
        'doom-variable-pitch-font
        (font-spec :family ,(assoc-ref font-variable-pitch #:font/name))))))

   (doom-dash)))

(define (font-weight->emacs-face-weight weight)
  (-> weight
      string-downcase
      string->symbol))
#+end_src
**** Package management
***** Guix
#+begin_src scheme
(define* (guix-pm #:key
                  stateless?
                  doom?
                  ;; channels
                  ;; channels-file
                  )
  (append
   ;; (list
   ;;  (let ((name 'guix-add-channels))
   ;;    (cond
   ;;     (channels
   ;;      (simple-service name
   ;;                      home-channels-service-type
   ;;                      channels))
   ;;     (channels-file
   ;;      (simple-service name
   ;;                      home-xdg-configuration-files-service-type
   ;;                      `(("guix/channels.scm"
   ;;                         ,channels-file)))))))

   (if stateless?
       (let ((guix-profile ".guix-profile")
             (guix-current "guix/current"))
         (list
          (simple-service
           'guix-ensure-profiles
           home-activation-service-type
           #~(#$stateless-ensure-profiles-gexp
              (let ((user-profiles-dir (string-append "/var/guix/profiles/per-user/" (passwd:name (getpwuid (getuid))))))
                (list (cons (string-append (getenv "HOME") "/" #$guix-profile)
                            (string-append user-profiles-dir "/guix-profile"))
                      (cons (string-append (getenv "XDG_CONFIG_HOME") "/" #$guix-current)
                            (string-append user-profiles-dir "/current-guix"))))))

          (home-stateless-service
           'guix
           #:state '(((#:path . ("guix/" #:xdg-base "XDG_CACHE_HOME"))
                      (#:storage . #:storage/machine)))
           #:ignore `(((#:path . ,guix-profile))
                      ((#:path . (,guix-current #:xdg-base "XDG_CONFIG_HOME")))))))
       '())

   (guile-services #:stateless? stateless?
                   #:doom? doom?)

   (if doom?
       (doom-guix #:stateless? stateless?) '())))
#+end_src
****** Guile
#+begin_src scheme
(define* (guile-services #:key
                         stateless?
                         doom?)
  (append
   (list
    ;; Typically we would add the package to the home profile to not depend on packages being installed at the system level, however in Guile's case it will (I think?) always be installed system-level and users probably want the same version of Guile as the one on the system anyway.
    ;; (simple-service
    ;;  'guile-add-packages
    ;;  home-profile-service-type
    ;;  (list guile))

    (simple-service
     'guile-add-config
     home-files-service-type
     `((".guile"
        ,%default-dotguile)))

    (simple-service
     'guile-add-gdb-config
     home-xdg-configuration-files-service-type
     `(("gdb/gdbinit"
        ,%default-gdbinit)))

    (when stateless?
      (home-stateless-service
       'guile
       #:state '(((#:path . ".guile_history")
                  (#:storage . #:storage/persist))
                 ((#:path . ("guile/" #:xdg-base "XDG_CACHE_HOME"))
                  (#:storage . #:storage/machine))))))

   (if doom?
       (doom-guile #:stateless? stateless?) '())))
#+end_src
****** Doom Guile
#+begin_src scheme
(define* (doom-guile #:key stateless?)
  (append
   (let ((name 'guile))
     (list
      (doom-service
       name
       #:modules '((#:lang
                    (scheme +guile)))
       #:config
       '((after! scheme
                 (setq-hook! 'scheme-mode-hook indent-tabs-mode nil))

         ;; TODO Maybe do this if popping to the side is too annoying
         ;; (after! geiser-repl
         ;;   (setq geiser-repl-use-other-window nil))
         ))

      (when stateless?
        (doom-stateless-service
         name
         #:state '(((#:path . ("geiser-history.guile" #:doom-base #:cache))
                    (#:storage . #:storage/persist)))))))

   (doom-transient #:stateless? stateless?)))
#+end_src
****** Doom Guix :bindings:
#+begin_src scheme
(define* (doom-guix #:key stateless?)
  (append
   (let ((name 'guix))
     (list
      (doom-service
       name
       #:packages
       '((package! guix
                   :recipe (:fork
                            (:host nil
                             :repo "https://git.savannah.gnu.org/git/guix/emacs-guix.git"))
                   :pin "455272c5cc72ed4ba5bad13c669f024f51479a58")
         (package! build-farm :pin "5c268a3c235ace0d79ef1ec82c440120317e06f5") ; REVIEW trying out
         (package! guix-packaging ; REVIEW trying out
                   :recipe (:host github
                            :repo "ryanprior/emacs-guix-packaging"
                            :files (:defaults "snippets"))
                   :pin "5bbd1f1a268b3dfd813a75125ca88cbf0bef6529"))
       #:config
       '((after! guix
                 (set-popup-rules!
                  '(("^\\*Guix" :height 0.5))))
         (use-package! guix-devel
                       :hook (scheme-mode . guix-devel-mode))
         (use-package! guix-popup
                       :defer t
                       :init
                       (map! :leader
                             "l" #'guix))  ; REVIEW temporary binding?
         (use-package! guix-prettify
                       :hook (doom-first-buffer . global-guix-prettify-mode))
         (after! guix-pcomplete
                 (fmakunbound 'pcomplete/guix)) ; Don't use pcompletion, it doesn't work (I get an error: "Unknown # object: #~") plus my completions are already good (maybe even better than what it provides).

         (use-package! guix-packaging
                       :defer t
                       :init
                       (setq guix-packaging--data-dir (concat doom-cache-dir "guix-packaging")))

         ;; TODO Figure out how to do this with a gexp, e.g.:
         ;; #$(file-append guix-package "/etc")
         ;; and remove the inner safety `when'.
         (let ((guix-etc-dir (concat "/gnu/store/01q67ynhr3pw3gnl8pz7d8mm844hgfd5-guix-1.4.0-4.01fd830-checkout" "/etc")))
           (when (file-directory-p guix-etc-dir)
             (after! yasnippet
                     (add-to-list 'yas-snippet-dirs (concat guix-etc-dir "/snippets/yas")))
             (after! tempel
                     (unless (listp 'tempel-path)
                       (setq tempel-path (list tempel-path)))
                     (add-to-list 'tempel-path (concat guix-etc-dir "/snippets/tempel/*")))

             (load-file (concat guix-etc-dir "/copyright.el"))))

         (when (and user-full-name
                    user-mail-address)
           (setq copyright-names-regexp (format "%s <%s>" user-full-name user-mail-address)))))

      (when stateless?
        (doom-stateless-service
         name
         #:state '(((#:path . ("guix-packaging/" #:doom-base #:cache))
                    (#:storage . #:storage/machine)))))))

   (doom-guile #:stateless? stateless?)))
#+end_src
***** Nix
#+begin_src scheme
(define* (nix-pm #:key
                 stateless?
                 doom?
                 doom-tree-sitter?
                 login-shell
                 (channels `((,%nixpkgs-unstable-url . "nixpkgs")))
                 nixpkgs-config-settings
                 nixpkgs-config-expressions)
  (append
   (list
    (simple-service
     'nix-add-packages
     home-profile-service-type
     (list nix))

    (let ((name 'nix-source-profile)
          (source (mixed-text-file
                   "source-nix-profile"
                   #~(string-join
                      (list
                       "source" #$(file-append nix "/etc/profile.d/nix.sh"))))))
      (case login-shell
        ((#:shell/bash)
         (simple-service name
                         home-bash-service-type
                         (home-bash-extension
                          (bash-profile
                           (list source)))))
        ((#:shell/zsh)
         (simple-service name
                         home-zsh-service-type
                         (home-zsh-extension
                          (zprofile
                           (list source)))))))

    (simple-service
     'nix-add-channels
     home-files-service-type
     `((".nix-channels"
        ,(nix-channels-file "nix-channels" channels))))

    (simple-service
     'nix-add-nixpkgs-config
     home-xdg-configuration-files-service-type
     `(("nixpkgs/config.nix"
        ,(nixpkgs-config-file "nixpkgs-config.nix"
                              nixpkgs-config-settings
                              nixpkgs-config-expressions)))))

   (if stateless?
       (let ((nix-profile ".nix-profile")
             (nix-channels ".nix-defexpr/channels"))
         (list
          (simple-service
           'stateless-nix-ensure-profiles
           home-activation-service-type
           #~(#$stateless-ensure-profiles-gexp
              (let ((user-profiles-dir (string-append "/nix/var/nix/profiles/per-user/" (passwd:name (getpwuid (getuid))))))
                (list (cons (string-append (getenv "HOME") "/" #$nix-profile)
                            (string-append user-profiles-dir "/profile"))
                      (cons (string-append (getenv "HOME") "/" #$nix-channels)
                            (string-append user-profiles-dir "/channels"))))))

          (home-stateless-service
           'nix
           #:state '(((#:path . ("nix/" #:xdg-base "XDG_CACHE_HOME"))
                      (#:storage . #:storage/machine)))
           #:ignore `(((#:path . ,nix-profile))
                      ((#:path . ,nix-channels))))))
       '())

   (if doom?
       (doom-nix #:stateless? stateless?
                 #:tree-sitter? doom-tree-sitter?)
       '())))

(define (nix-channels-file name entries)
  (apply mixed-text-file name (nix-channels-serialize entries)))

(define (nix-channels-serialize entries)
  (append-map (match-lambda
                ((channel . name)
                 (list channel " " name "\n")))
              entries))

(define (nixpkgs-config-file name settings expressions)
  (apply mixed-text-file name
         (append
          (list "{" "\n")
          (append-map (match-lambda
                        ((n . v)
                         (list (symbol->string n)
                               " = "
                               (match v
                                 (#t "true")
                                 (#f "false")
                                 (v v))
                               ";" "\n")))
                      settings)
          (if expressions
              (list expressions) '())
          (list "}" "\n"))))

(define %nixpkgs-unstable-url "https://nixos.org/channels/nixpkgs-unstable")
#+end_src
****** Source Nix profile
#+begin_src sh :tangle (meta-in-dir "source-nix-profile")
if [ -f /run/current-system/profile/etc/profile.d/nix.sh ]; then
  . /run/current-system/profile/etc/profile.d/nix.sh
fi
#+end_src
****** Doom Nix
#+begin_src scheme
(define* (doom-nix #:key
                   stateless?
                   tree-sitter?)
  (append
   (doom-ts-lang 'nix #:tree-sitter? tree-sitter?)
   (doom-transient #:stateless? stateless?)))
#+end_src
****** Setup instructions
#+begin_src sh :tangle no
nix-channel --update

# nix-env --install google-chrome
# ...
#+end_src
***** Shared
#+begin_src scheme
(define stateless-ensure-profiles-gexp
  (with-imported-modules (source-module-closure
                          '((guix build utils)
                            (phrenetic build utils))
                          #:select? phrenetic-module-name?)
    #~(lambda (profiles)
        (use-modules ((guix build utils) #:select (mkdir-p))
                     ((phrenetic build utils) #:select (no-follow-file-exists?)))

        (for-each
         (lambda (i)
           ;; I get an error if I try to use `match-lambda', I have no idea why.
           (let ((link (car i))
                 (profile (cdr i)))
             (when (and (no-follow-file-exists? profile)
                        (not (no-follow-file-exists? link)))
               (mkdir-p (dirname link))
               (symlink profile link))))
         profiles))))
#+end_src
**** Console
***** KMonad :upstream:
#+begin_src scheme
(define* (kmonad-tool #:key
                      doom?
                      (device "/dev/input/by-id/usb-Apple_Inc._Apple_Internal_Keyboard___Trackpad-event-kbd")
                      (kbd (local-file "keyboard-config.kbd"))
                      kmonad)
  (list
   (simple-service
    'kmonad-add-packages
    home-profile-service-type
    (list kmonad))

   (simple-service
    'kmonad
    home-shepherd-service-type
    (kmonad-shepherd-service #:kbd kbd
                             #:kmonad kmonad))

   (when doom?
     (doom-service
      'kmonad
      #:packages '((package! kbd-mode
                             :recipe (:host github
                                      :repo "kmonad/kbd-mode")
                             :pin "a4c5f1c60ff392cb4037d53aeccef5163f91d91b"))))))

(define* (kmonad-shepherd-service #:key
                                  kbd
                                  kmonad)
  (list
   (shepherd-service
    (provision '(kmonad))
    (start #~(make-forkexec-constructor
              (list #$(file-append kmonad "/bin/kmonad") #$kbd)
              #:log-file #$(home-shepherd-service-log-file "kmonad.log")))
    (stop #~(make-kill-destructor)))))
#+end_src
****** Keyboard config
#+begin_src kbd :tangle (meta-in-dir "keyboard-config.kbd")
(defcfg
  input (device-file "/dev/input/by-id/usb-Apple_Inc._Apple_Internal_Keyboard___Trackpad-event-kbd")
  output (uinput-sink "My KMonad output")
  fallthrough true
  allow-cmd false)

(defalias
  cap (tap-hold-next 400 esc lctl)
  sem (tap-hold-next 400 ; rctl))

(defsrc
  esc  f1   f2   f3   f4   f5   f6   f7   f8   f9   f10  f11  f12
  grv  1    2    3    4    5    6    7    8    9    0    -    =    bspc
  tab  q    w    e    r    t    y    u    i    o    p    [    ]    \
  caps a    s    d    f    g    h    j    k    l    ;    '    ret
  lsft z    x    c    v    b    n    m    ,    .    /    rsft up
  volu lctl lalt lmet           spc            rmet ralt left down rght)

(deflayer default
  _    _    _    _    _    _    _    _    _    _    _    _    _
  _    _    _    _    _    _    _    _    _    _    _    _    _    _
  _    _    _    _    _    _    _    _    _    _    _    _    _    _
  @cap _    _    _    _    _    _    _    _    _    @sem _    _
  _    _    _    _    _    _    _    _    _    _    _    _    _
  _    _    _    _              _              _    _    _    _    _)

;; (deflayer default
;;   _    _    _    _    _    _    _    _    _    _    _    _    _
;;   _    @caps    _    _    _    _    _    _    _    _    _    _    _    _
;;   _    _    _    _    _    _    _    _    _    _    _    _    _    _
;;   _    _    _    _    _    _    _    _    _  @semi  _        _    _
;;   _    _    _    _    _    _    _    _    _    _    _    _    _
;;   _    _    _    _              _              _    _    _    _    _)


;; (defsrc
;;   esc  f1   f2   f3   f4   f5   f6   f7   f8   f9   f10  f11  f12
;;   grv  1    2    3    4    5    6    7    8    9    0    -    =    bspc
;;   tab  q    w    e    r    t    y    u    i    o    p    [    ]    \
;;   caps a    s    d    f    g    h    j    k    l    ;    '    ret
;;   lsft z    x    c    v    b    n    m    ,    .    /    rsft up
;;   fn   lctl lalt lmet           spc            rmet ralt left down rght)

;; ;; Below, I use `around' to compose `layer-toggle' with `fn' (instead
;; ;; of using `layer-toggle' directly) so that the `fn' keypress
;; ;; actually gets emitted. This matters when using an application that
;; ;; can use `fn' as a modifier (like Emacs).

;; (defalias fn (around (layer-toggle function) fn))

;; (deflayer default
;;   _    brdn brup lp   mctl bldn blup prev pp   next mute vold volu
;;   _    _    _    _    _    _    _    _    _    _    _    _    _    _
;;   _    _    _    _    _    _    _    _    _    _    _    _    _    _
;;   _    _    _    _    _    _    _    _    _    _    _    _    _
;;   _    _    _    _    _    _    _    _    _    _    _    _    _
;;   @fn  _    _    _              _              _    _    _    _    _
;; )

;; (deflayer function
;;   _    f1   f2   f3   f4   f5   f6   f7   f8   f9   f10  f11  f12
;;   _    _    _    _    _    _    _    _    _    _    _    _    _    _
;;   _    _    _    _    _    _    _    _    _    _    _    _    _    _
;;   _    _    _    _    _    _    _    _    _    _    _    _    _
;;   _    _    _    _    _    _    _    _    _    _    _    _    _
;;   _    _    _    _              _              _    _    _    _    _
;; )
#+end_src
**** Desktop
***** Media
****** Pipewire
Wireplumber does not (yet?) support seatd. At the time of this writing this only prevents bluetooth seat monitoring. See:
- [[https://pipewire.pages.freedesktop.org/wireplumber/daemon/configuration/features.html][Well-known features — WirePlumber documentation]]
- [[https://gitlab.freedesktop.org/pipewire/wireplumber/-/issues/208][Add support for seatd as an alternative to systemd|elogind? (#208) · Issues ·...]]
#+begin_src scheme
(define* (pipewire-media #:key
                         stateless?
                         pipewire
                         (pipewire-pulse? #t))
  (list
   (service home-pipewire-service-type
            (home-pipewire-configuration
             (pipewire pipewire)
             (enable-pulseaudio? pipewire-pulse?)))

   (when (and stateless? pipewire-pulse?)
     (home-stateless-service
      'pipewire-pulse
      #:state '(((#:path . ("pulse/cookie" #:xdg-base "XDG_CONFIG_HOME"))
                 (#:storage . #:storage/machine)
                 (#:parent-dir-perms . ((#:mode . #o700)))))))

   (when stateless?
     (home-stateless-service
      'wireplumber
      #:state '(((#:path . ("wireplumber/" #:xdg-base "XDG_STATE_HOME"))
                 (#:storage . #:storage/machine)
                 (#:mode . #o700)))))))
#+end_src
***** Bluetooth
#+begin_src scheme
(define (bluetooth)
  (append
   (list
    (doom-service
     'bluetooth
     #:packages
     '((package! bluetooth :pin "eaae9894353fe1bb32a276acdecb12b2d5e96ae3"))))

   (doom-dash)))
#+end_src
***** Colors
#+begin_src scheme
(define %colors
  '((#:colors/nuclear-light . ()) ; Nothing here yet.
    (#:colors/nuclear-dark . ((#:color/fg . "#dee2f8")
                              (#:color/bg . "#31343f")
                              (#:color/base0 . "#1e1f27")
                              (#:color/base8 . "#eef0fb") ; (doom-lighten "#dee2f8" 0.5)
                              (#:color/accent . "#8496ff")
                              (#:color/red . "#fb8578")
                              (#:color/orange . "#fdce5f")
                              (#:color/green . "#9fed9c")
                              (#:color/yellow . "#eddc91")
                              (#:color/blue . "#7db9fe")
                              (#:color/magenta . "#e29bf7")
                              (#:color/violet . "#aeb9f3")
                              (#:color/cyan . "#75e0f9")))))
#+end_src
***** Wallpapers
#+begin_src scheme
(define %wallpapers
  `((#:wallpaper/alucard . ,(origin
                              (method url-fetch)
                              (uri "https://i.redd.it/ba5x648wvsu21.png")
                              (sha256
                               (base32
                                "1kjpbjxsrq6671his86z4grx7z06bkbg5025sxnmnwahibdfvhc1"))
                              (file-name "alucard.png")))))
#+end_src
***** Font library
#+begin_src scheme
(define* (font-library #:key
                       stateless?
                       font-sans
                       font-serif
                       font-mono
                       extra-fonts)
  (list
   (service home-fontconfig-service-type)
   ;; (service (as-> home-fontconfig-service-type $
   ;;            (without-extensions $ home-xdg-configuration-files-service-type)
   ;;            (service-type
   ;;             (inherit $)
   ;;             (extensions
   ;;              (cons* (service-extension
   ;;                      home-xdg-configuration-files-service-type
   ;;                      (partial add-fontconfig-config font-sans font-serif font-mono))
   ;;                     (service-type-extensions $))))))

   (simple-service
    'fonts-add-packages
    home-profile-service-type
    (append
     (map (lambda (font)
            (assoc-ref font #:font/package))
          (append
           (list font-sans
                 font-serif
                 font-mono)
           extra-fonts))))

   (when stateless?
     (home-stateless-service
      'fonts
      #:state '(((#:path . ("fontconfig/" #:xdg-base "XDG_CACHE_HOME"))
                 (#:storage . #:storage/machine)))))))

;; TODO Probably give up on fonts stuff and get rid of all of this code? If not there's some useful fonts conf examples at https://gitlab.archlinux.org/archlinux/packaging/packages/noto-fonts and less useful, more complex, ones in the google noto fedora package
;; TODO [2024-05-26 Sun] There's presets in the fontconfig package, share/fontconfig/conf.avail and etc/fonts/conf.d. Consider them?
;; TODO [2024-07-19 Fri] disabling this for now for no particular reason until I get back to fonts stuff
;; TODO [2024-07-22 Mon] using liberation fonts instead of ms-core now. Consider aliasing them to the equivalent microsoft fonts. See the fedora package for liberation fonts.
;; (define (add-fontconfig-config font-sans font-serif font-mono dirs)
;;   `(("fontconfig/fonts.conf"
;;      ,(apply mixed-text-file
;;              "fonts.conf"
;;              (list "<?xml version='1.0'?>" "\n"
;;                    "<!DOCTYPE fontconfig SYSTEM 'fonts.dtd'>" "\n"
;;                    (sxml-serialize
;;                     `(fontconfig
;;                       ,@(map (lambda (dir)
;;                                `(dir ,dir))
;;                              dirs)
;;                       ,@(map (match-lambda
;;                                ((family . name)
;;                                 `(alias
;;                                   (family ,family)
;;                                   (prefer
;;                                    (family ,name)))))
;;                              `(("sans-serif" . ,(assoc-ref font-sans #:font/name))
;;                                ("serif" . ,(assoc-ref font-serif #:font/name))
;;                                ("monospace" . ,(assoc-ref font-mono #:font/name)))))))))))

;; (define (sxml-serialize tree)
;;   (call-with-output-string
;;     (lambda (port)
;;       (sxml->xml tree port)))) ; It'd be nice if this pretty-printed or if I added some code that did.

;; TODO These should really each be a function to parameterize the packages.
(define %fonts
  `((#:fonts/fira-code . ((#:font/name . "Fira Code")
                          (#:font/package . ,font-fira-code)))
    (#:fonts/gnu-unifont . ((#:font/name . "Unifont")
                            (#:font/package . ,font-gnu-unifont)))
    (#:fonts/google-noto . ((#:font/package . ,font-google-noto)))
    (#:fonts/google-noto-emoji . ((#:font/name . "Noto Emoji")
                                  (#:font/package . ,font-google-noto-emoji)))
    (#:fonts/google-noto-sans-cjk . ((#:font/package . ,font-google-noto-sans-cjk)))
    (#:fonts/google-noto-serif-cjk . ((#:font/package . ,font-google-noto-serif-cjk)))
    (#:fonts/iosevka-aile . ((#:font/name . "Iosevka Aile")
                             (#:font/package . ,font-iosevka-aile)))
    (#:fonts/iosevka-etoile . ((#:font/name . "Iosevka Etoile")
                               (#:font/package . ,font-iosevka-etoile)))
    (#:fonts/iosevka . ((#:font/name . "Iosevka")
                        (#:font/package . ,font-iosevka)))
    (#:fonts/liberation . ((#:font/package . ,font-liberation)))))
#+end_src
***** Date/time formats
#+begin_src scheme
(define %date-formats
  '((#:date-format/simple . "%a %b %-d")))

(define %time-formats
  '((#:time-format/simple . "%-I:%M %p")))
#+end_src
***** XDG
****** User directories
#+begin_src scheme
(define* (xdg-user-directories #:key
                               stateless?
                               (dirs '((#:desktop . "$HOME/desktop")
                                       (#:documents . "$HOME/docs")
                                       (#:download . "$HOME/dl")
                                       (#:music . "$HOME/music")
                                       (#:pictures . "$HOME/pics")
                                       (#:publicshare . "$HOME/public")
                                       (#:templates . "$HOME/templates")
                                       (#:videos . "$HOME/vids"))))
  (list
   (simple-service
    'xdg-user-directories-add-packages
    home-profile-service-type
    (list xdg-utils
          xdg-user-dirs ; Copied from RDE. I don't think I need this (the only reason would be if programs ever call the `xdg-user-dir' shell command and this package isn't an input to theirs).
          desktop-file-utils)) ; Copied from RDE. I don't think I need this at all but it adds elisp code (a mode for editing .desktop files). I'll keep it just in case.

   (service
    home-xdg-user-directories-service-type
    (home-xdg-user-directories-configuration
     (desktop (assoc-ref dirs #:desktop))
     (documents (assoc-ref dirs #:documents))
     (download (assoc-ref dirs #:download))
     (music (assoc-ref dirs #:music))
     (pictures (assoc-ref dirs #:pictures))
     (publicshare (assoc-ref dirs #:publicshare))
     (templates (assoc-ref dirs #:templates))
     (videos (assoc-ref dirs #:videos))))

   (when stateless?
     (home-stateless-service
      'xdg-user-directories
      #:state
      (let ((normalize
             (lambda (dir)
               (as-> dir $
                     (let ((home-prefix "$HOME/"))
                       (if (string-prefix? home-prefix $)
                           (string-drop $ (string-length home-prefix))
                           $))
                     (string-append $ "/")))))
        (append
         (map (lambda (dir)
                `((#:path . ,(normalize dir))
                  (#:storage . #:storage/persist)))
              (list (assoc-ref dirs #:desktop)
                    (assoc-ref dirs #:documents)
                    (assoc-ref dirs #:music)
                    (assoc-ref dirs #:pictures)
                    (assoc-ref dirs #:publicshare)
                    (assoc-ref dirs #:templates)
                    (assoc-ref dirs #:videos)))
         `(((#:path . ,(normalize (assoc-ref dirs #:download)))
            (#:storage . #:storage/machine)))))))))
#+end_src
***** Mesa
#+begin_src scheme
(define* (mesa #:key stateless?)
  (list
   (when stateless?
     (home-stateless-service
      'mesa
      #:state '(((#:path . ("mesa_shader_cache/" #:xdg-base "XDG_CACHE_HOME"))
                 (#:storage . #:storage/machine))
                ((#:path . ("mesa_shader_cache_db/" #:xdg-base "XDG_CACHE_HOME"))
                 (#:storage . #:storage/machine)))))))
#+end_src
***** D-Bus
#+begin_src scheme
(define (dbus-ipc)
  (list
   (service home-dbus-service-type)))
#+end_src
***** Login management
****** Login managers
******* GDM
#+begin_src scheme
(define* (gdm #:key stateless?)
  (list
   (when stateless?
     (home-stateless-service
      'gdm
      #:state '(((#:path . ("gdm/" #:xdg-base "XDG_CACHE_HOME"))
                 (#:storage . #:storage/machine)
                 (#:mode . #o700)))))))
#+end_src
****** Desktop TTY
#+begin_src scheme
(define* (desktop-tty #:key
                      sessions
                      start-cmds)
  (list
   (simple-service
    'desktop-tty-default-session-start
    home-profile-service-type
    (list (default-session-start
            (match-let (((default-session _ ...) sessions))
              (assoc-ref start-cmds default-session)))))))

(define (default-session-start cmd)
  (package
    (inherit simple-package)
    (name "default-session-start")
    (source cmd)
    (arguments
     `(#:builder
       ,#~(begin
            (let ((bin (string-append #$output "/bin")))
              (mkdir #$output)
              (mkdir bin)
              (symlink #$source (string-append bin "/default-session-start"))))))))
#+end_src
***** Sessions
****** Desktop environments
******* GNOME
#+begin_src scheme
(define* (gnome-desktop #:key stateless?)
  (list
   (simple-service
    'gnome-add-packages
    home-profile-service-type
    (list (gnome-start-package)
          (append-map package-propagated-inputs
                      (list gnome-meta-core-services
                            gnome-meta-core-shell
                            gnome-meta-core-utilities
                            gnome-essential-extras))))

   ;; (when stateless?
   ;;   (home-stateless-service
   ;;    'gnome
   ;;    #:state ...))
   ))

(define (gnome-start)
  (file-append (gnome-start-package) "/bin/" gnome-start-exe))

(define gnome-start-exe "gnome-start")

(define (gnome-start-package)
  (session-start
   gnome-start-exe
   (file-append gnome-session "/bin/gnome-session")
   #:log-file "gnome.log"
   #:pre-start (environment-variable-shell-definitions
                (list xdg-session-type-wayland-env-var))))
#+end_src
****** Window managers
******* Hyprland
#+begin_src scheme
(define* (hyprland-wm #:key
                      pipewire?
                      portal-services
                      (main-mod #:ALT)
                      input
                      output
                      external-programs
                      extra-config)
  (append
   (list
    (simple-service
     'hyprland-add-packages
     home-profile-service-type
     (list (hyprland-start-package #:pipewire? pipewire?)
           hyprland))

    (simple-service
     'hyprland-conf
     home-xdg-configuration-files-service-type
     `(("hypr/hyprland.conf"
        ,(hyprlang-file
          "hyprland-conf"
          (append
           `((#:$mod ,main-mod)

             (#:bind #:$mod #:H #:workspace "-1")
             (#:bind #:$mod #:L #:workspace "+1")
             (#:bind #:$mod+Shift #:H #:movetoworkspace "-1")
             (#:bind #:$mod+Shift #:L #:movetoworkspace "+1")

             (#:bindm #:$mod #:mouse:272 #:movewindow)
             (#:bindm #:$mod+Shift #:mouse:272 #:resizewindow)

             (#:general ((#:gaps_out 55 5 5 320)))
             (#:animations ((#:enabled #f)))
             (#:xwayland ((#:force_zero_scaling #t)))
             (#:misc ((#:force_default_wallpaper 2)))

             (#:debug:disable_logs #f))

           (hyprland-general)
           (apply hyprland-input (alist->list input))
           ;; (apply hyprland-output (alist->list output))
           (apply hyprland-external-programs (alist->list external-programs))
           ;; (hyprland-app-windows)

           (or extra-config '())))))))

   (or portal-services '())))

(define* (hyprland-start #:key pipewire?)
  (file-append (hyprland-start-package #:pipewire? pipewire?)
               "/bin/" hyprland-start-exe))

(define hyprland-start-exe "hyprland-start")

(define* (hyprland-start-package #:key pipewire?)
  (session-start
   hyprland-start-exe
   (file-append hyprland "/bin/hyprland")
   #:log-file "hyprland.log"
   ;; #:pre-start (environment-variable-shell-definitions
   ;;              (cons* (xdg-current-desktop-env-var "Hyprland")
   ;;                     xdg-session-type-wayland-env-var
   ;;                     (wayland-env-vars pipewire?)))
   ;; TODO there's some issue in session-start, work around it
   #:pre-start (environment-variable-shell-definitions
                '(("ASDFASDFASDFFF" . "bob")))))

(define (hyprland-general)
  (append
   `(;; Windows
     (#:bind #:$mod+Shift #:C #:killactive)
     ;; (bindsym $mod+Shift+f fullscreen)
     (#:bind #:$mod+Shift #:Space #:togglefloating)
     ;; (bindsym $mod+Control+space focus mode_toggle)
     (#:bind #:$mod+Control #:H #:movefocus #:l)
     (#:bind #:$mod+Control #:J #:movefocus #:d)
     (#:bind #:$mod+Control #:K #:movefocus #:u)
     (#:bind #:$mod+Control #:L #:movefocus #:r)
     ;; (bindsym $mod+Shift+h move left)
     ;; (bindsym $mod+Shift+j move down)
     ;; (bindsym $mod+Shift+k move up)
     ;; (bindsym $mod+Shift+l move right)
     )

   ;; Workspaces
   (append
    (append-map (lambda (x)
                  (let ((n (number->string (modulo x 10))))
                    `((#:bind #:$mod ,n #:workspace ,x)
                      (#:bind #:$mod+Shift ,n #:movetoworkspace ,x))))
                (iota 10 1))
    ;; `((bindsym $mod+tab workspace back_and_forth))
    )

   `(;; Scratchpad
     ;; (bindsym $mod+Shift+minus move scratchpad)
     ;; (bindsym $mod+minus scratchpad show)

     ;; Layout
     ;; (bindsym $mod+Shift+b splith)
     ;; (bindsym $mod+Shift+v splitv)
     ;; (bindsym $mod+Shift+s layout stacking)
     ;; (bindsym $mod+Shift+w layout tabbed)
     ;; (bindsym $mod+Shift+e layout toggle split)

     ;; (bindsym $mod+Shift+a focus parent)

     ;; (bindsym $mod+Shift+r reload)
     (#:bind #:$mod+Control+Shift #:Q #:exit)


     ;; (default_border pixel)
     ;; (default_floating_border pixel)
     ;; (gaps inner 8)

     ;; (floating_modifier $mod normal)
     )))

(define* (hyprland-input #:key
                         inputs
                         default-kb-repeat-delay
                         default-kb-repeat-rate
                         default-tp-tap?)

  `((#:input ((#:follow_mouse 0)
              (#:float_switch_override_focus 0)
              (#:repeat_delay ,default-kb-repeat-delay)
              (#:repeat_rate ,default-kb-repeat-rate)
              (#:kb_layout "us")
              (#:kb_model "macbook78")
              (#:touchpad ((#:natural_scroll #t)
                           (#:tap-to-click ,default-tp-tap?))))))

  ;; (append
  ;;  `((focus_follows_mouse #f)
  ;;    (input type:keyboard
  ;;           ,(append
  ;;             (if default-kb-repeat-delay
  ;;                 `((repeat_delay ,default-kb-repeat-delay)) '())
  ;;             (if default-kb-repeat-rate
  ;;                 `((repeat_rate ,default-kb-repeat-rate)) '())))
  ;;    (input type:touchpad
  ;;           ((tap ,(if default-tp-tap?
  ;;                      'enabled 'disabled)))))

  ;;  (->> (or inputs '())
  ;;       (filter (lambda (input)
  ;;                 (assoc-ref input #:keyboard/layout)))
  ;;       (map (lambda (input)
  ;;              `(input ,(string-join (list (number->string
  ;;                                           (assoc-ref input #:keyboard/vendor-id))
  ;;                                          (number->string
  ;;                                           (assoc-ref input #:keyboard/product-id))
  ;;                                          (string-replace-substring
  ;;                                           (assoc-ref input #:keyboard/name) " " "_"))
  ;;                                    ":")
  ;;                ,(let ((kb-layout (assoc-ref input #:keyboard/layout)))
  ;;                   (append
  ;;                    `((xkb_layout ,(keyboard-layout-name kb-layout)))
  ;;                    (if-let ((variant (keyboard-layout-variant kb-layout)))
  ;;                            `((xkb_variant ,variant)) '())
  ;;                    (if-let ((model (keyboard-layout-model kb-layout)))
  ;;                            `((xkb_model ,model)) '())
  ;;                    (let ((options (keyboard-layout-options kb-layout)))
  ;;                      (if (null? options)
  ;;                          '()
  ;;                          `((xkb_options ,(string-join
  ;;                                           (keyboard-layout-options kb-layout) ","))))))))))))
  )

(define* (hyprland-output #:key
                          outputs
                          default-bg-image)
  (append
   `((output *
      ,(if default-bg-image
           `((bg ,default-bg-image fill)) '())))
   ;; (map (lambda (output)
   ;;        `((output ,(as-> (list (assoc-ref output #:display/make)
   ;;                               (assoc-ref output #:display/model)) $
   ;;                         (string-join $)
   ;;                         (quoted $)))
   ;;          ;; ...
   ;;          ))
   ;;      (or outputs '()))
   ))

;; TODO Temporary
(define (gexp-cmd cmd)
  #~(string-join '#$cmd))

(define* (hyprland-external-programs #:key
                                     idle-manager
                                     screen-locker
                                     notifier
                                     power-monitor
                                     app-launcher
                                     terminal
                                     backup-terminal
                                     emacs-interface)
  (let ((executions
         (map (lambda (cmd)
                (list #:exec-once (gexp-cmd cmd)))
              (list idle-manager
                    (assoc-ref notifier #:notifier/daemon)
                    power-monitor)))

        (bindings
         (append
          `((#:bind #:$mod #:Return #:exec ,(gexp-cmd terminal))
            ,@(if backup-terminal
                  `((#:bind #:$mod+Control+Shift #:Return #:exec ,(gexp-cmd backup-terminal)))
                  '())
            (#:bind #:$mod+Shift #:D #:exec ,(gexp-cmd app-launcher))
            (#:bind #:$mod+Control+Shift #:L #:exec ,(gexp-cmd screen-locker))
            (#:bind #:$mod+Shift #:Y #:exec ,(gexp-cmd (assoc-ref emacs-interface #:emacs/program)))
            (#:bind #:$mod #:Y #:exec ,(gexp-cmd (assoc-ref emacs-interface #:emacs/new-frame))))

          (hyprland-notifications notifier)
          (hyprland-backlights)
          (hyprland-volume)
          (hyprland-player))))

    (append executions bindings)))

(define (hyprland-notifications notifier)
  `((#:bind #:$mod #:M #:exec ,(gexp-cmd (assoc-ref notifier #:notifier/dismiss)))
    (#:bind #:$mod+Shift #:M #:exec ,(gexp-cmd (assoc-ref notifier #:notifier/restore)))
    (#:bind #:$mod+Control #:M #:exec ,(gexp-cmd (assoc-ref notifier #:notifier/menu)))))

(define (hyprland-backlights)
  (let ((backlights (brightnessctl-backlights)))
    `((#:bindl "" #:XF86MonBrightnessUp #:exec ,(gexp-cmd (assoc-ref backlights #:backlight/up)))
      (#:bindl "" #:XF86MonBrightnessDown #:exec ,(gexp-cmd (assoc-ref backlights #:backlight/down))))))

(define (hyprland-volume)
  (let ((volume (pipewire-volume))) ; TODO This should be dependent on whether media is pulseaudio or pipewire.
    `((#:bindl "" #:XF86AudioRaiseVolume #:exec ,(gexp-cmd (cmd-chain (assoc-ref volume #:volume/up))))
      (#:bindl "" #:XF86AudioLowerVolume #:exec ,(gexp-cmd (cmd-chain (assoc-ref volume #:volume/down))))
      (#:bindl "" #:XF86AudioMute #:exec ,(gexp-cmd (assoc-ref volume #:volume/mute-unmute)))
      (#:bindl "" #:XF86AudioMicMute #:exec ,(gexp-cmd (assoc-ref volume #:volume/mic-mute-unmute))))))

;; TODO I don't know how I want to handle "multi-commands" yet, just do this for the ones I know that are for now. However at least in this case I do like the idea of doing "&&" between them rather than, say, comma-separating them like Sway allows because in the general case if one of the commands fails it's probably best not to run any that would come after.
(define (cmd-chain cs)
  (->> cs
       (interpose (list "&&"))
       (apply append)))

(define (hyprland-player)
  (let ((player (playerctl-player)))
    `((#:bindl "" #:XF86AudioPlay #:exec ,(gexp-cmd (assoc-ref player #:player/play-pause)))
      (#:bindl "" #:XF86AudioPrev #:exec ,(gexp-cmd (assoc-ref player #:player/previous)))
      (#:bindl "" #:XF86AudioNext #:exec ,(gexp-cmd (assoc-ref player #:player/next))))))

(define* (hyprland-app-windows #:key (props (list emacs-modal-window-props
                                                  ;; ...
                                                  )))
  (map (lambda (p)
         (let ((commands (append (list (if (assoc-ref p #:window-prop/floating?)
                                           '((floating enable)) '())
                                       ;; ...
                                       ))))
           (if (not (null? commands))
               (append
                ;; Andrew Tropin says there's a bug in Sway that could affect this (https://github.com/swaywm/sway/issues/6950). I haven't experienced it but it's something to consider if I have issues.
                `(for_window ,(as-> (append
                                     (if-let ((title (assoc-ref p #:window-prop.criteria/title)))
                                             `(("title" . ,title)) '())
                                     ;; ...
                                     ) $
                                (map (match-lambda
                                       ((k . v)
                                        (string-append k "=" (quoted v))))
                                     $)
                                (string-join $)
                                (string-append "[" $ "]")))
                commands)
               '())))
       props))
#+end_src
******* Sway
#+begin_src scheme
(define* (sway-wm #:key
                  sway
                  pipewire?
                  doom?
                  portal-services
                  (xwayland? #t)
                  (sway-mod 'Mod1)
                  input
                  output
                  external-programs
                  extra-config)
  (append
   (list
    (simple-service
     'sway-add-packages
     home-profile-service-type
     ;; TODO [2024-06-16 Sun] RDE added `dconf' here because "It's needed to persist setting for gtk apps.", see https://github.com/abcdw/rde/commit/13c528ad6e2602284a77ab141391be0573778297
     ;; - does it belong here or in gtk-services?
     ;;   Possibly Andrew Tropin would have put it in his home-gtk3-service-type or feature-gtk3 if it weren't sway or wayland-specific
     (list (sway-start-package #:sway sway
                               #:pipewire? pipewire?)
           sway))

    (simple-service
     'sway-config
     home-xdg-configuration-files-service-type
     `(("sway/config"
        ,(apply
          mixed-text-file
          "sway-config"
          (serialize-sway-config
           (append
            `((xwayland ,(if xwayland? 'enable 'disable))
              ;; Some of these might not be necessary. To be safe I'm using a combination of those in RDE and suggested here:
              ;; - https://github.com/swaywm/sway/wiki#gtk-applications-take-20-seconds-to-start
              ;; - https://lists.sr.ht/~abcdw/rde-discuss/%3C87bku5ozzn.fsf%40bruun.xyz%3E
              ;; - https://github.com/emersion/xdg-desktop-portal-wlr#running
              (exec ,(file-append dbus "/bin/dbus-update-activation-environment")
                    DISPLAY WAYLAND_DISPLAY XDG_CURRENT_DESKTOP SWAYSOCK)
              (set $mod ,sway-mod))

            (sway-general)
            (apply sway-input (alist->list input))
            (apply sway-output (alist->list output))
            (apply sway-external-programs (alist->list external-programs))
            (sway-app-windows)
            (or extra-config '())))))))

    ;; (simple-service
    ;;  'sway-reload-config-on-change
    ;;  home-run-on-change-service-type
    ;;  `((,(string-append home-files-directory "/" xdg-configuration-files-directory "/sway/config")
    ;;     ,#~(system* #$(file-append sway "/bin/swaymsg") "reload"))))

    (when doom?
      (doom-service
       'sway
       #:packages '((package! i3wm-config-mode :pin "188e3978807ec39eba3cb69d973c0062af324215")))))

   (or portal-services '())))

(define* (sway-start #:key
                     sway
                     pipewire?)
  (file-append (sway-start-package #:sway sway
                                   #:pipewire? pipewire?)
               "/bin/" sway-start-exe))

(define sway-start-exe "sway-start")

(define* (sway-start-package #:key
                             sway
                             pipewire?)
  (session-start
   sway-start-exe
   (file-append sway "/bin/sway")
   #:log-file "sway.log"
   #:pre-start (environment-variable-shell-definitions
                (cons* (xdg-current-desktop-env-var "sway")
                       xdg-session-type-wayland-env-var ; Seems to be set even without this but relying on that might be a brittle, see https://www.reddit.com/r/swaywm/comments/skdt2b/comment/hvk8m8o
                       (wayland-env-vars pipewire?)))))
#+end_src
******** General
#+begin_src scheme
(define (sway-general)
  (append
   `(;; Windows
     (bindsym $mod+Shift+c kill)
     (bindsym $mod+Shift+f fullscreen)
     (bindsym $mod+Shift+space floating toggle)
     (bindsym $mod+Control+space focus mode_toggle)
     (bindsym $mod+h focus left)
     (bindsym $mod+j focus down)
     (bindsym $mod+k focus up)
     (bindsym $mod+l focus right)
     (bindsym $mod+Shift+h move left)
     (bindsym $mod+Shift+j move down)
     (bindsym $mod+Shift+k move up)
     (bindsym $mod+Shift+l move right))

   ;; Workspaces
   (append
    (append-map (lambda (x)
                  (let ((n (number->string (modulo x 10))))
                    `((bindsym ,(string-append "$mod+" n)
                       workspace number ,x)
                      (bindsym ,(string-append "$mod+Shift+" n)
                               move container to workspace number ,x))))
                (iota 10 1))
    `((bindsym $mod+tab workspace back_and_forth)))

   `(;; Scratchpad
     (bindsym $mod+Shift+minus move scratchpad)
     (bindsym $mod+minus scratchpad show)

     ;; Layout
     (bindsym $mod+Shift+b splith)
     (bindsym $mod+Shift+v splitv)
     (bindsym $mod+Shift+s layout stacking)
     (bindsym $mod+Shift+w layout tabbed)
     (bindsym $mod+Shift+e layout toggle split)

     (bindsym $mod+Shift+a focus parent)

     (bindsym $mod+Shift+r reload)
     (bindsym $mod+Control+Shift+q exit)


     (default_border pixel)
     (default_floating_border pixel)
     (gaps inner 8)

     (floating_modifier $mod normal))))
#+end_src
******** Input/output
#+begin_src scheme
(define* (sway-input #:key
                     inputs
                     default-kb-repeat-delay
                     default-kb-repeat-rate
                     default-tp-tap?)
  (append
   `((focus_follows_mouse #f)
     (input type:keyboard
      ,(append
        (if default-kb-repeat-delay
            `((repeat_delay ,default-kb-repeat-delay)) '())
        (if default-kb-repeat-rate
            `((repeat_rate ,default-kb-repeat-rate)) '())))
     (input type:touchpad
            ((tap ,(if default-tp-tap?
                       'enabled 'disabled)))))

   (->> (or inputs '())
        (filter (lambda (input)
                  (assoc-ref input #:keyboard/layout)))
        (map (lambda (input)
               `(input ,(string-join (list (number->string
                                            (assoc-ref input #:keyboard/vendor-id))
                                           (number->string
                                            (assoc-ref input #:keyboard/product-id))
                                           (string-replace-substring
                                            (assoc-ref input #:keyboard/name) " " "_"))
                                     ":")
                 ,(let ((kb-layout (assoc-ref input #:keyboard/layout)))
                    (append
                     `((xkb_layout ,(keyboard-layout-name kb-layout)))
                     (if-let ((variant (keyboard-layout-variant kb-layout)))
                             `((xkb_variant ,variant)) '())
                     (if-let ((model (keyboard-layout-model kb-layout)))
                             `((xkb_model ,model)) '())
                     (let ((options (keyboard-layout-options kb-layout)))
                       (if (null? options)
                           '()
                           `((xkb_options ,(string-join
                                            (keyboard-layout-options kb-layout) ",")))))))))))))

(define* (sway-output #:key
                      outputs
                      default-bg-image)
  (append
   `((output *
      ,(if default-bg-image
           `((bg ,default-bg-image fill)) '())))
   ;; (map (lambda (output)
   ;;        `((output ,(as-> (list (assoc-ref output #:display/make)
   ;;                               (assoc-ref output #:display/model)) $
   ;;                         (string-join $)
   ;;                         (quoted $)))
   ;;          ;; ...
   ;;          ))
   ;;      (or outputs '()))
   ))
#+end_src
******** External programs
#+begin_src scheme
(define* (sway-external-programs #:key
                                 sway
                                 idle-manager
                                 screen-locker
                                 notifier
                                 power-monitor
                                 app-launcher
                                 terminal
                                 backup-terminal
                                 emacs-interface)
  (let ((executions
         (map (lambda (cmd)
                (cons "exec" cmd))
              (list idle-manager
                    (assoc-ref notifier #:notifier/daemon)
                    power-monitor)))

        (bindings
         (append
          `((bindsym $mod+Return exec ,@terminal)
            ,@(if backup-terminal
                  `((bindsym $mod+Control+Shift+Return exec ,@backup-terminal))
                  '())
            (bindsym $mod+Shift+d exec ,@app-launcher)
            (bindsym $mod+Control+Shift+l exec ,@screen-locker)
            (bindsym $mod+Shift+y exec ,@(assoc-ref emacs-interface #:emacs/program))
            (bindsym $mod+y exec ,@(assoc-ref emacs-interface #:emacs/new-frame)))

          (sway-notifications notifier)
          (sway-screenshot #:sway sway)
          (sway-backlights)
          (sway-volume)
          (sway-player))))

    (append executions bindings)))

(define (sway-notifications notifier)
  `((bindsym $mod+m exec ,@(assoc-ref notifier #:notifier/dismiss))
    (bindsym $mod+Shift+m exec ,@(assoc-ref notifier #:notifier/restore))
    (bindsym $mod+Control+m exec ,@(assoc-ref notifier #:notifier/menu))))

(define (sway-backlights)
  (let ((backlights (brightnessctl-backlights)))
    (bindsym-controls
     `(("XF86MonBrightnessUp" . ,(assoc-ref backlights #:backlight/up))
       ("XF86MonBrightnessDown" . ,(assoc-ref backlights #:backlight/down))))))

(define (sway-volume)
  (let ((volume (pipewire-volume))) ; TODO This should be dependent on whether media is pulseaudio or pipewire.
    (bindsym-controls
     `(("XF86AudioRaiseVolume" . ,(cmd-chain (assoc-ref volume #:volume/up)))
       ("XF86AudioLowerVolume" . ,(cmd-chain (assoc-ref volume #:volume/down)))
       ("XF86AudioMute" . ,(assoc-ref volume #:volume/mute-unmute))
       ("XF86AudioMicMute" . ,(assoc-ref volume #:volume/mic-mute-unmute))))))

;; TODO I don't know how I want to handle "multi-commands" yet, just do this for the ones I know that are for now. However at least in this case I do like the idea of doing "&&" between them rather than, say, comma-separating them like Sway allows because in the general case if one of the commands fails it's probably best not to run any that would come after.
(define (cmd-chain cs)
  (->> cs
       (interpose (list "&&"))
       (apply append)))

(define (sway-player)
  (let ((player (playerctl-player)))
    (bindsym-controls
     `(("XF86AudioPlay" . ,(assoc-ref player #:player/play-pause))
       ("XF86AudioPrev" . ,(assoc-ref player #:player/previous))
       ("XF86AudioNext" . ,(assoc-ref player #:player/next))))))

(define* (sway-screenshot #:key sway)
  `((bindsym $mod+grave exec ,(shot-output #:sway sway))
    (bindsym $mod+Control+grave exec ,swappy-clipboard)
    (bindsym $mod+Shift+grave exec ,(shot-window-or-selection #:sway sway))))


(define (bindsym-controls bs)
  (map (match-lambda
         ((key . cmd)
          (append
           (list "bindsym" "--locked" key "exec")
           cmd)))
       bs))
#+end_src
********* Screenshot
#+begin_src scheme
(define* (subject-output #:key sway)
  #~(format #f "~a -t get_outputs | ~a -r '.[] | select(.focused) | .name'"
            #$(file-append sway "/bin/swaymsg")
            #$(file-append jq "/bin/jq")))

(define* (subject-window-or-selection #:key sway)
  #~(format #f "~a -t get_tree | ~a -r '.. | select(.pid? and .visible?) \
| .rect | \"\\(.x),\\(.y) \\(.width)x\\(.height)\"' | ~a -b ~a -B ~a"
            #$(file-append sway "/bin/swaymsg")
            #$(file-append jq "/bin/jq")
            #$(file-append slurp "/bin/slurp")
            "303030AA"
            "303030AA"))

(define* (shot-script subject #:key output geom (file "-"))
  (program-file
   (string-append "sway-shot-" subject)
   #~(system
      (format #f "~a ~a~a~a | ~a"
              #$(file-append grim "/bin/grim")
              #$(if output #~(string-append "-o \"$(" #$output ")\" ") "")
              #$(if geom #~(string-append "-g \"$(" #$geom ")\" ") "")
              #$file
              #$(file-append wl-clipboard "/bin/wl-copy")))))

(define* (shot-output #:key sway)
  (shot-script "output" #:output (subject-output #:sway sway)))

(define* (shot-window-or-selection #:key sway)
  (shot-script "window-or-selection" #:geom (subject-window-or-selection #:sway sway)))

(define swappy-clipboard
  (program-file
   "sway-swappy-clipboard"
   #~(system
      (format #f "~a | ~a -f -"
              #$(file-append wl-clipboard "/bin/wl-paste")
              #$(file-append swappy "/bin/swappy")))))
#+end_src
******** App windows
- TODO Ideally the inclusions here would be gated but that would require a flag for every application so just add them all.
#+begin_src scheme
(define* (sway-app-windows #:key (props (list emacs-modal-window-props
                                              ;; ...
                                              )))
  (map (lambda (p)
         (let ((commands (append (list (if (assoc-ref p #:window-prop/floating?)
                                           '((floating enable)) '())
                                       ;; ...
                                       ))))
           (if (not (null? commands))
               (append
                ;; Andrew Tropin says there's a bug in Sway that could affect this (https://github.com/swaywm/sway/issues/6950). I haven't experienced it but it's something to consider if I have issues.
                `(for_window ,(as-> (append
                                     (if-let ((title (assoc-ref p #:window-prop.criteria/title)))
                                             `(("title" . ,title)) '())
                                     ;; ...
                                     ) $
                                (map (match-lambda
                                       ((k . v)
                                        (string-append k "=" (quoted v))))
                                     $)
                                (string-join $)
                                (string-append "[" $ "]")))
                commands)
               '())))
       props))
#+end_src
******* Pieces
******** Screen lockers
********* Hyprlock
#+begin_src scheme
(define* (hyprlock-wm-piece #:key
                            colors
                            font
                            font-size
                            time-format
                            date-format
                            image
                            extra-config)
  (list
   (simple-service
    'hyprlock-add-packages
    home-profile-service-type
    (list hyprlock))

   (simple-service
    'hyprlock-conf
    home-xdg-configuration-files-service-type
    `(("hypr/hyprlock.conf"
       ,(hyprlang-file
         "hyprlock-conf"
         (let ((font (assoc-ref font #:font/name)))
           (append
            `((#:grace 5)
              (#:background ,(append
                              ;; TODO blur is enabled by default, yes?
                              ;; Any additional blur settings
                              (if image
                                  `((#:path ,image))
                                  '())))
              ;; Widgets
              (#:label ((#:font_family ,font)
                        (#:font_size ,(* font-size 3))
                        ;; TODO remove halign/valign everywhere if they're the default / unnecessary
                        (#:halign "center")
                        (#:valign "center")
                        (#:position 0 300)
                        ;; (#:color ,(hex->rgb (assoc-ref colors #:color/violet)))
                        (#:text ,(string-append "cmd[update:1000] echo \"$(date +\"" time-format "\")\""))))
              (#:label ((#:font_family ,font)
                        (#:font_size ,(* font-size 2))
                        (#:halign "center")
                        (#:valign "center")
                        (#:position 0 100)
                        ;; (#:color ,(hex->rgb (assoc-ref colors #:color/violet)))
                        (#:text ,(string-append "cmd[update:1000] echo \"$(date +\"" date-format "\")\""))))
              (#:input-field ((#:font_family ,font)
                              (#:font_size ,font-size)
                              (#:halign "center")
                              (#:valign "center")
                              (#:position 0 -100)
                              ;; (#:text_color ,(hex->rgb (assoc-ref colors #:color/fg)))
                              ;; (#:inner_color ,(string-append (hex->rgb (assoc-ref colors #:color/bg)) ", 0.5"))
                              ;; (#:check_color ,(hex->rgb (assoc-ref colors #:color/blue)))
                              ;; (#:fail_color ,(hex->rgb (assoc-ref colors #:color/red)))
                              )))
            (or extra-config '())))))))))

(define* (hyprlock-screen-locker)
  (let ((hyprlock-bin (file-append hyprlock "/bin/hyprlock")))
    `((#:screen-locker/lock . ,(list hyprlock-bin))
      (#:screen-locker/lock-immediately . ,(list hyprlock-bin
                                                 "--immediate")))))
#+end_src
********* Swaylock
#+begin_src scheme
(define* (swaylock-wm-piece #:key
                            colors
                            font
                            time-format
                            date-format
                            image
                            effects?
                            extra-config
                            swaylock
                            swaylock-effects)

  (list
   (simple-service
    'swaylock-add-packages
    home-profile-service-type
    (list (get-swaylock #:effects? effects?
                        #:swaylock swaylock
                        #:swaylock-effects swaylock-effects)))

   (simple-service
    'swaylock-config
    home-xdg-configuration-files-service-type
    `(("swaylock/config"
       ,(apply
         mixed-text-file
         "swaylock-config"
         (serialize-swaylock-config
          (let ((clr (lambda* (color #:optional alpha)
                       (as-> color $
                             (assoc-ref colors $)
                             (string-drop $ 1)
                             (string-append $ (or alpha "")))))
                (alpha "7f")) ; 50%
            (append
             `((daemonize)

               (font . ,(assoc-ref font #:font/name))

               (indicator-idle-visible)
               (indicator-caps-lock)
               (indicator-radius . "150")
               (indicator-thickness . "10")

               (key-hl-color . ,(clr #:color/green))
               (bs-hl-color . ,(clr #:color/yellow))
               (inside-color . ,(clr #:color/bg alpha))

               (ring-color . ,(clr #:color/bg))
               (ring-clear-color . ,(clr #:color/bg alpha))
               (ring-ver-color . ,(clr #:color/bg alpha))
               (ring-wrong-color . ,(clr #:color/bg alpha))

               (text-clear-color . ,(clr #:color/orange))
               (text-ver-color . ,(clr #:color/blue))
               (text-wrong-color . ,(clr #:color/red))
               (inside-clear-color . ,(clr #:color/orange))
               (inside-ver-color . ,(clr #:color/blue))
               (inside-wrong-color . ,(clr #:color/red))

               (text-color . ,(clr #:color/violet))
               (separator-color . "00000000")
               (line-uses-ring))

             (if image
                 (list #~(string-append "image=" #$image)) ; HACK `serialize-swaylock-config' doesn't allow gexp terms (it probably should). Ideally this line would be `(image . ,image)'. Maybe upstream a patch.
                 '())

             (if effects?
                 `((indicator)

                   (effect-blur . 7x5)

                   (clock)
                   (timestr . ,time-format)
                   (datestr . ,date-format))
                 '())

             (or extra-config '()))))))))))

(define* (swaylock-screen-locker #:key
                                 effects?
                                 swaylock
                                 swaylock-effects)
  (let ((swaylock-bin (file-append (get-swaylock #:effects? effects?
                                                 #:swaylock swaylock
                                                 #:swaylock-effects swaylock-effects)
                                   "/bin/swaylock")))
    `((#:screen-locker/lock . ,(append
                                (list swaylock-bin)
                                (if effects?
                                    (let ((grace-period "5"))
                                      (list (string-append "--grace=" grace-period)
                                            (string-append "--fade-in=" grace-period))) ; This is "pretty much broken" (I think just in terms of not being very pretty), see https://github.com/jirutka/swaylock-effects/commit/89daa14763.
                                    '())))
      (#:screen-locker/lock-immediately . ,(list swaylock-bin)))))

(define* (get-swaylock #:key
                       effects?
                       swaylock
                       swaylock-effects)
  (if effects?
      swaylock-effects
      swaylock))
#+end_src
******** Idle managers
- TODO Figure out what the macOS defaults are and use those. Does it turn off the display (not dim it) /before/ locking the screen? I don't think so, but if I went with this approach (if it's even possible) would that obviate the need for a swaylock grace period?
- TODO [2024-07-21 Sun](from seatd switch notes, might not be relevant now that I'm back on elogind)
  Commented the "lock" and "before-sleep" parts, they wont work with seatd (or rather, without elogind). Come to think of it, why should those commented things be swayidle's responsibilities? Can I do the same thing in an init-system agnostic way?
  - "I'm putting the `before-sleep`..."
    [[https://forum.artixlinux.org/index.php/topic,3599.0.html][Broken suspend with `loginctl suspend` only when Sway is used.]]
********* Hypridle
#+begin_src scheme
(define* (hypridle-wm-piece #:key
                            session
                            screen-locker
                            (lock-timeout 600)
                            extra-config)
  (list
   (simple-service
    'hypridle-add-packages
    home-profile-service-type
    (list hypridle))

   (simple-service
    'hypridle-conf
    home-xdg-configuration-files-service-type
    `(("hypr/hypridle.conf"
       ,(hyprlang-file
         "hypridle-conf"
         (append
          `((#:listener ((#:timeout ,lock-timeout)
                         (#:on-timeout "echo 'Timed out'")
                         (#:on-resume "echo 'Welcome back'"))))
          (or extra-config '()))))))))

(define (hypridle-idle-manager)
  (list
   (file-append hypridle "/bin/hypridle")))
#+end_src
********* Swayidle
#+begin_src scheme
(define* (swayidle-wm-piece #:key
                            session
                            sway
                            screen-locker
                            (lock-timeout 600)
                            extra-config
                            swayidle)
  (list
   (simple-service
    'swayidle-add-packages
    home-profile-service-type
    (list swayidle))

   (simple-service
    'swayidle-config
    home-xdg-configuration-files-service-type
    `(("swayidle/config"
       ,(apply
         mixed-text-file
         "swayidle-config"
         (serialize-sway-config
          (append
           (if screen-locker
               (let ((lock-cmd-quoted #~(format #f "'~a'" (string-join '#$screen-locker))))
                 `(;(lock ,lock-cmd-quoted)
                                        ;(before-sleep ,lock-cmd-quoted)
                   (timeout ,lock-timeout ,lock-cmd-quoted)))
               '())
           (or extra-config '())))))))

   ;; (case session
   ;;   ((#:session/sway)
   ;;    (let* ((swaymsg (file-append sway "/bin/swaymsg"))
   ;;           (swaymsg-cmd (lambda (cmd)
   ;;                          #~(format #f "'~a \"~a\"'" #$swaymsg #$cmd)))
   ;;           (idle-timeout (+ lock-timeout 300)))
   ;;      (simple-service
   ;;       'swayidle-add-sway-power
   ;;       home-swayidle-service-type
   ;;       `((timeout ,idle-timeout ,(swaymsg-cmd "output * power off") resume ,(swaymsg-cmd "output * power on")))))))
   ))

(define* (swayidle-idle-manager #:key swayidle)
  (list
   (file-append swayidle "/bin/swayidle")
   "-w"))
#+end_src
******** Notification daemons
********* Mako
#+begin_src scheme
(define* (mako-wm-piece #:key
                        colors
                        font
                        font-size)
  (list
   (simple-service
    'mako-add-packages
    home-profile-service-type
    (list mako))

   (simple-service
    'mako-config
    home-xdg-configuration-files-service-type
    `(("mako/config"
       ,(ini-file
         "mako-config"
         (let ((clr (lambda* (color #:optional alpha)
                      (as-> color $
                            (assoc-ref colors $)
                            (string-append $ (or alpha ""))
                            (string->symbol $)))))
           `((global ((font . ,(string->symbol (pango-font-description font font-size)))
                      (max-icon-size . 32)
                      (text-color . ,(clr #:color/fg))
                      (background-color . ,(clr #:color/bg "e6")) ; 90% alpha
                      (border-color . ,(clr #:color/accent))
                      (border-size . 2)
                      (border-radius . 8)))
             (urgency=low ((border-color . ,(clr #:color/green))))
             (urgency=high ((border-color . ,(clr #:color/red))))))
         #:ini-serialize
         (lambda (config)
           (ini-serialize config #:equal-string "="))))))))

(define (mako-notifier menu)
  (let ((makoctl (file-append mako "/bin/makoctl")))
    `((#:notifier/daemon . ,(list (file-append mako "/bin/mako")))
      (#:notifier/dismiss . ,(list makoctl
                                   "dismiss"))
      (#:notifier/restore . ,(list makoctl
                                   "restore"))
      (#:notifier/menu . ,(append
                           (list makoctl "menu")
                           menu
                           (list (quoted "Notification action")))))))
#+end_src
******** Power monitors
- TODO this requires ~upower~ (so ~upower-service-type~) and a notification daemon (such as mako), make those dependencies explicit? At least the upower one? Meh.
********* Poweralertd
#+begin_src scheme
(define* (poweralertd-wm-piece)
  (list
   (simple-service
    'poweralertd-add-packages
    home-profile-service-type
    (list poweralertd))))

(define* (poweralertd-monitor #:key (ignore-types '("line power")))
  (append
   (list
    (file-append poweralertd "/bin/poweralertd")
    "-s")
   (append-map (lambda (t)
                 `("-i" ,(if (string-contains t " ")
                             (quoted t) t)))
               (or ignore-types '()))))
#+end_src
******** Display configuration
********* Kanshi
- TODO this is the only wm-peice daemon with a shepherd service. Just run it in the Sway config with ~exec~ like everything else for consistency?
#+begin_src scheme
;; (define* (kanshi-wm-piece #:key
;;                           outputs
;;                           extra-config)
;;   (list
;;    (service
;;     home-kanshi-service-type
;;     (home-kanshi-configuration
;;      (config
;;       ;; Not done yet.
;;       (or extra-config '()))))))
#+end_src
******** Controls
********* Backlights
********** Brightnessctl
#+begin_src scheme
(define* (brightnessctl-backlights #:key (step 10))
  (let ((cmd (lambda (op)
               (list (file-append brightnessctl "/bin/brightnessctl")
                     "--quiet" ; There's a big status report after every invocation that pollutes the logs.
                     "set"
                     (step-pct step op #:suffix)))))
    `((#:backlight/up . ,(cmd #:up))
      (#:backlight/down . ,(cmd #:down)))))
#+end_src
********* Volume
********** PulseAudio
#+begin_src scheme
(define* (pulseaudio-volume #:key (step 5))
  (let* ((pactl (file-append pulseaudio "/bin/pactl"))
         (sink "@DEFAULT_SINK@")
         (source "@DEFAULT_SOURCE@")
         (unmute (list pactl "set-sink-mute" sink "false")))
    `((#:volume/up . ,(list unmute
                            (list pactl "set-sink-volume" sink (step-pct step #:up #:prefix))))
      (#:volume/down . ,(list unmute
                              (list pactl "set-sink-volume" sink (step-pct step #:down #:prefix))))
      (#:volume/mute-unmute . ,(list pactl "set-sink-mute" sink "toggle"))
      (#:volume/mic-mute-unmute . ,(list pactl "set-source-mute" source "toggle")))))
#+end_src
********** Pipewire
#+begin_src scheme
(define* (pipewire-volume #:key (step 5))
  (let* ((wpctl (file-append wireplumber "/bin/wpctl"))
         (sink "@DEFAULT_AUDIO_SINK@")
         (source "@DEFAULT_AUDIO_SOURCE@")
         (unmute (list wpctl "set-mute" sink "0")))
    `((#:volume/up . ,(list unmute
                            (list wpctl "set-volume" "--limit" "1" sink (step-pct step #:up #:suffix))))
      (#:volume/down . ,(list unmute
                              (list wpctl "set-volume" sink (step-pct step #:down #:suffix))))
      (#:volume/mute-unmute . ,(list wpctl "set-mute" sink "toggle"))
      (#:volume/mic-mute-unmute . ,(list wpctl "set-mute" source "toggle")))))
#+end_src
********* Player
********** Playerctl
#+begin_src scheme
(define* (playerctl-player)
  (let ((cmd (lambda (action)
               (list (file-append playerctl "/bin/playerctl")
                     action))))
    `((#:player/play-pause . ,(cmd "play-pause"))
      (#:player/previous . ,(cmd "previous"))
      (#:player/next . ,(cmd "next")))))
#+end_src
********* Shared
#+begin_src scheme
(define (step-pct n op fix)
  (let ((percent (string-append (number->string n) "%"))
        (sign (case op
                ((#:up) "+")
                ((#:down) "-"))))
    (case fix
      ((#:prefix) (string-append sign percent))
      ((#:suffix) (string-append percent sign)))))
#+end_src
****** Shared
#+begin_src scheme
(define* (session-start exe
                        session-cmd
                        #:key
                        log-file
                        session-args
                        pre-start)
  (package
    (inherit simple-package)
    (name (string-append "session-" exe))
    (source (apply mixed-text-file exe
                   (append
                    (or (list pre-start) '())
                    (list
                     #~(string-join
                        (list
                         "exec" #$session-cmd #$@(or session-args '()) "$@"
                         (string-join
                          (list ">>"
                                (string-append
                                 "$" #$(assoc-ref log-home #:xdg-base) "/" #$(assoc-ref log-home #:path) "/" #$log-file)))
                         "2>&1"))))))
    (arguments
     `(#:builder
       ,#~(begin
            (let* ((bin (string-append #$output "/bin"))
                   (f (string-append bin "/" #$exe)))
              (mkdir #$output)
              (mkdir bin)
              (copy-file #$source f)
              (chmod f #o555)))))))

(define (xdg-current-desktop-env-var val)
  `("XDG_CURRENT_DESKTOP" . ,val)) ; "Normally" provided by a login manager.

(define xdg-session-type-wayland-env-var
  '("XDG_SESSION_TYPE" . "wayland")) ; "Normally" provided by a login manager.

;; I think these should really be set in packages / package program wrappers but this is easier and Andrew Tropin does it this way so I'll leave it as-is for now.
(define (wayland-env-vars pipewire?)
  ;; Copied from RDE: I don't know what all of these do. For some explanation see https://github.com/swaywm/sway/wiki/Running-programs-natively-under-Wayland and https://wiki.archlinux.org/title/Wayland#GUI_libraries.
  (append
   '(("SDL_VIDEODRIVER" . "wayland")
     ("CLUTTER_BACKEND" . "wayland")
     ("ELM_ENGINE" . "wayland_egl")
     ("ECORE_EVAS_ENGINE" . "wayland-egl")
     ("QT_QPA_PLATFORM" . "wayland-egl") ; Might not be necessary since I set `XDG_SESSION_TYPE=wayland', see https://github.com/swaywm/sway/wiki/Running-programs-natively-under-Wayland#qt5
     ("_JAVA_AWT_WM_NONREPARENTING" . "1"))
   (if pipewire?
       '(("RTC_USE_PIPEWIRE" . "true")) '()))) ; No idea what this is for. I thought it was equivalent to toggling on chrome://flags/#enable-webrtc-pipewire-capturer but it's not. The `rtc_use_pipewire=true' in the ungoogled-chromium configure flags is a separate issue too (it only builds Chromium with support for pipewire, it still has to be turned on in the settings or with a flag). [2024-07-14 Sun] update: possibly relevant?: https://github.com/emersion/xdg-desktop-portal-wlr/wiki/Screencast-Compatibility#webrtc-aka-firefoxchromium
#+end_src
***** Flatpak
I might need to run apps specially in Wayland, with =--socket=wayland= and =--enable-features=UseOzonePlatform --ozone-platform=wayland= (if the app is based on Electron). See [[https://github.com/swaywm/sway/wiki/Running-programs-natively-under-Wayland#flatpak][Running programs natively under Wayland · swaywm/sway Wiki · GitHub (Flatpak)]]
#+begin_src scheme
(define* (flatpak-apps #:key
                       stateless?
                       portal-services)
  (append
   (list
    (simple-service
     'flatpak-add-packages
     home-profile-service-type
     (list flatpak))

    (simple-service
     'flatpak-exports
     home-environment-variables-service-type
     `(("XDG_DATA_DIRS" . "$XDG_DATA_DIRS${XDG_DATA_DIRS:+:}$XDG_DATA_HOME/flatpak/exports/share")))

    (when stateless?
      (home-stateless-service
       'flatpak
       #:state '(((#:path . ("flatpak/" #:xdg-base "XDG_DATA_HOME"))
                  (#:storage . #:storage/machine)
                  (#:mode . #o700))))))

   (or portal-services '())))
#+end_src
****** Setup instructions
#+begin_src sh :tangle no
flatpak remote-add --user --if-not-exists flathub https://flathub.org/repo/flathub.flatpakrepo
# flatpak remote-add --user --if-not-exists flathub-beta https://flathub.org/beta-repo/flathub-beta.flatpakrepo

# flatpak install --user flathub com.discordapp.Discord
# flatpak install --user flathub-beta com.obsproject.Studio
# ...
#+end_src
***** Portals
#+begin_src scheme
(define (portal-services/gtk)
  (list
   (simple-service
    'gtk-portal-add-packages
    home-profile-service-type
    (list xdg-desktop-portal
          xdg-desktop-portal-gtk))))

(define (portal-services/wlr)
  (list
   (simple-service
    'wlr-portal-add-packages
    home-profile-service-type
    (list xdg-desktop-portal
          xdg-desktop-portal-wlr))

   (simple-service
    'wlr-portal-config
    home-multi-xdg-configuration-files-service-type
    `(("xdg-desktop-portal-wlr/config"
       ,(ini-file
         "xdg-desktop-portal-wlr-config"
         `((screencast ((chooser_cmd . ,#~(string-append #$(file-append slurp "/bin/slurp")
                                                         " -f %o -or -c ff0000"))
                        (chooser_type . simple))))
         #:ini-serialize
         (lambda (config)
           (ini-serialize config #:equal-string "=")))))))) ; Donno if this is necessary (the examples don't have spaces around the equals), let's be safe.

(define (portal-services/hyprland)
  (list
   (simple-service
    'hyprland-portal-add-packages
    home-profile-service-type
    (list xdg-desktop-portal
          xdg-desktop-portal-hyprland/simple))

   ;; Example. We're not configuring anthing at the moment (also there's not really anthing to configure, 'max_fps' is the only option at time of writing).
   ;; (simple-service
   ;;  'hyprland-portal-config
   ;;  home-multi-xdg-configuration-files-service-type
   ;;  `(("xdg-desktop-portal-hyprland/config"
   ;;     ,(hyprlang-file
   ;;       "xdg-desktop-portal-hyprland-config"
   ;;       `((#:screencopy ((#:max_fps 120))))))))
   ))

(define* (portal-config-services #:key
                                 xdg-current-desktop
                                 preferred)
  (list
   (simple-service
    (symbol-append (string->symbol xdg-current-desktop)
                   '-portals-config)
    home-multi-xdg-configuration-files-service-type
    `((,(string-append "xdg-desktop-portal/" xdg-current-desktop "-portals.conf")
       ,(ini-file
         (string-append "xdg-desktop-portal-" xdg-current-desktop "-portals")
         `((preferred ((default . ,(string-join preferred ";")))))
         #:ini-serialize
         (lambda (config)
           (ini-serialize config #:equal-string "=")))))))) ; Donno if this is necessary (the examples don't have spaces around the equals), let's be safe.
#+end_src
***** Shared
#+begin_src scheme
(define* (pango-font-description font #:optional size)
  (string-join
   (append
    (list
     (assoc-ref font #:font/name))
    (if size
        (list (number->string size)) '()))))
#+end_src
**** Virtualization
#+begin_src scheme
(define (virtualization)
  (list
   (simple-service
    'virtualization-add-packages
    home-profile-service-type
    (list ;; qemu ; QEMU is kind of a fatty, maybe don't keep it installed all the time.
          ))))
#+end_src
**** Programs
***** Calendars
****** Doom calendar
#+begin_src scheme
(define* (doom-calendar-prog #:key
                             stateless?
                             org?)
  (append
   (list
    (doom-service
     'calendar
     #:modules '((#:app
                  calendar))))

   (if org?
       (doom-org-gcal #:stateless? stateless?) '())))

(define* (doom-org-gcal #:key stateless?)
  (append
   (let ((name 'org-gcal))
     (list
      (doom-service
       name
       #:modules '((#:app
                    calendar))
       #:config
       '((after! org-gcal
                 (setq org-gcal-client-id "446729771716-pp79934q99aro2h8v3iki1fejcodbdoo.apps.googleusercontent.com"
                       org-gcal-client-secret (-> (auth-source-search :host org-gcal-client-id) car (plist-get :secret) funcall)
                       org-gcal-recurring-events-mode 'nested))))

      (when stateless?
        (doom-stateless-service
         name
         #:state '(((#:path . ("org-gcal/token.gpg" #:doom-base #:cache))
                    (#:storage . #:storage/machine))
                   ((#:path . ("persist/org-gcal--sync-tokens" #:doom-base #:data))
                    (#:storage . #:storage/machine)))))))

   (doom-dash)))

;; TODO
;; - This comonent no longers depens on doom-user so don't rely on user-mail-address?
;; - nb: also it uses `org-directory'
;; '((after! org-gcal
;;           (setq ;; TODO `elisp-serialize' doesn't like the unquotes.
;;                 ;; org-gcal-fetch-file-alist (let ((cal-dir concat org-directory "/cal"))
;;                 ;;                             `((user-mail-address . ,(concat cal-dir "/" user-mail-address ".org"))
;;                 ;;                               ("addressbook%23contacts@group.v.calendar.google.com" . ,(concat cal-dir "/contacts.org"))
;;                 ;;                               ("en.usa%23holiday@group.v.calendar.google.com" . ,(concat cal-dir "/holidays.org"))))
;;                 )))
#+end_src
***** Development
****** AWS
#+begin_src scheme
(define (aws-prog)
  (list
   (simple-service
    'aws-add-packages
    home-profile-service-type
    (list awscli))))
#+end_src
****** Clojure
#+begin_src scheme
(define* (clojure-prog #:key
                       stateless?
                       doom?
                       doom-tree-sitter?
                       (jdk (list openjdk-lts "jdk")))
  (append
   (list
    (simple-service
     'clojure-add-packages
     home-profile-service-type
     (list clojure-tools
           jdk
           (@ (nongnu packages clojure) clj-kondo))) ; TODO Update with respect to nonphrenetic.

    (when stateless?
      (home-stateless-service
       'clojure
       #:state '(((#:path . ".m2/")
                  (#:storage . #:storage/machine))))))

   (if doom?
       (doom-clojure #:stateless? stateless?
                     #:tree-sitter? doom-tree-sitter?)
       '())))
#+end_src
******* Doom Clojure
#+begin_src scheme
(define* (doom-clojure #:key
                       stateless?
                       tree-sitter?)
  (append
   (let ((name 'clojure))
     (append
      (doom-ts-lang
       name
       #:tree-sitter? tree-sitter?
       #:config
       `((use-package! clojure-mode
                       :defer t
                       :init
                       (setq clojure-refactor-map-prefix (kbd "s-M r")) ; Has to be set before clojure-mode loads. ; REVIEW temporary binding
                       :config
                       (set-ligatures! 'clojure-mode :lambda "fn"))

         (use-package! cider
                       :defer t
                       :init
                       (-each '((cider-preferred-build-tool symbolp)
                                (cider-default-cljs-repl symbolp)
                                (cider-shadow-default-options stringp)
                                (cider-offer-to-open-cljs-app-in-browser booleanp)
                                (cider-clojure-cli-global-options stringp)
                                (cider-clojure-cli-global-options booleanp))
                              (-lambda ((sym f))
                                       (put sym 'safe-local-variable f)))
                       :config
                       (setq cider-repl-history-size ,very-big-history))

         ;; REVIEW make sure this is still working after nesting in `after!'
         (after! cider-repl
                 (add-hook! 'cider-repl-mode-hook
                            #'goto-address-prog-mode
                            #'highlight-numbers-mode
                            #'rainbow-delimiters-mode
                            #'yas-minor-mode-on
                            #'biome-sp-strict-h))

         (after! clj-refactor
                 (cljr-add-keybindings-with-prefix "s-M R")))) ; REVIEW temporary binding

      (if stateless?
          (list
           (doom-stateless-service
            'clojure
            #:state '(((#:path . ("cider-repl-history" #:doom-base #:cache))
                       (#:storage . #:storage/persist)))))
          '())))

   (doom-xml+csv)
   (doom-dash)))
#+end_src
****** Node
#+begin_src scheme
(define* (node-prog #:key
                    stateless?
                    doom?
                    doom-tree-sitter?)
  (append
   (list
    (simple-service
     'node-add-packages
     home-profile-service-type
     (list node-lts))

    ;; (when stateless?
    ;;   (home-stateless-service
    ;;    'node
    ;;    #:state '(((#:path . ".npm/")
    ;;               (#:storage . #:storage/machine)))))
    )

   (if doom?
       (doom-javascript #:tree-sitter? doom-tree-sitter?) '())))
#+end_src
***** Notes
****** Doom org :bindings:
#+begin_src scheme
(define* (doom-org-prog #:key
                        (org-dir "org")
                        stateless?
                        evil?)
  (append
   (doom-org #:stateless? stateless?
             #:evil? evil?
             #:org-dir org-dir)

   (list
    (when stateless?
      (home-stateless-service
       'org
       #:state `(((#:path . ,(string-append org-dir "/"))
                  (#:storage . #:storage/persist))))))))

(define* (doom-org #:key
                   stateless?
                   evil?
                   (pretty? #t)
                   org-dir)
  (append
   (let ((name 'org))
     (list
      (doom-service
       name
       #:modules '((#:lang
                    (org +journal)))
       #:packages
       (if pretty?
           '((package! org-modern :pin "f619912e55b409a8a3ecb807a8c2a35faa0e482d")
             (package! org-modern-indent
                       :recipe (:host github
                                :repo "jdtsmith/org-modern-indent")
                       :pin "f2b859bc53107b2a1027b76dbf4aaebf14c03433")
             (package! org-appear :pin "32ee50f8fdfa449bbc235617549c1bccb503cb09"))
           '())

       #:config
       (append
        `((use-package! org
                        :defer t
                        :init
                        (setq org-directory ,(string-append "~/" org-dir))
                        :config
                        (setq org-log-done 'time
                              org-priority-lowest ?E
                              org-priority-default ?C
                              org-priority-faces
                              (-map (-lambda ((priority . color))
                                             (cons priority (doom-color color)))
                                    '((?A . red)
                                      (?B . orange)
                                      (?C . yellow)
                                      (?D . magenta)
                                      (?E . cyan)))))

          (after! ob
                  (setq org-babel-noweb-error-all-langs t)))

        (if evil?
            '((after! evil-org
                      (map! :map evil-org-mode-map
                            :nv "C-j" #'outline-forward-same-level
                            :nv "C-k" #'outline-backward-same-level)))
            '())

        (if pretty?
            '((after! org
                      (setq org-hide-emphasis-markers t
                            org-pretty-entities t
                            ;; org-ellipsis "…"
                            ))

              (use-package! org-appear
                            :hook (org-mode . org-appear-mode))

              (use-package! org-modern
                            :hook
                            (org-mode . org-modern-mode)
                            (org-agenda-finalize . org-modern-agenda)
                            :config
                            (setq org-modern-fold-stars '(("▶" . "▼") ("▷" . "▽") ("▹" . "▿") ("▸" . "▾")) ; HACK: remove a symbol pair that renders with a different line hight (at least in Fira Code).
                                  org-modern-hide-stars nil ; You still can't see them because `org-hide-leading-stars' is true but this way the indentation is retained (otherwise there's some extra and the amount grows each level down).
                                  org-modern-todo-faces
                                  (-map (-lambda ((kw . face))
                                                 `(,kw :inverse-video t :inherit ,face))
                                        org-todo-keyword-faces)
                                  org-modern-priority
                                  '((?A . "🔥") ; ❢
                                    (?B . "⚠") ; ⚑
                                    (?C . "●")
                                    (?D . "◆")
                                    (?E . "■"))
                                  org-modern-priority-faces
                                  (-map (-lambda ((priority . color))
                                                 `(,priority :foreground ,color))
                                        org-priority-faces))
                            (when (not line-spacing)
                              (setq org-modern-label-border 0.3))) ; Chosen arbitrarily. Looks good.

              (use-package! org-modern-indent
                            :hook (org-mode . org-modern-indent-mode)
                            :config
                            ;; Square brackets instead of rounded.
                            (setq org-modern-indent-begin (propertize "┌" 'face 'org-modern-indent-bracket-line)
                                  org-modern-indent-end (propertize "└" 'face 'org-modern-indent-bracket-line))
                            ;; TODO These should maybe be in my theme(s).
                            (custom-set-faces! '(org-modern-indent-bracket-line :inherit org-block-begin-line)
                                               '(org-block :background unspecified)))) ; Get rid of any special org block background, we have the block bracket to delineate them. The Doom themes base in particular sets a background.
            '())))

      (when stateless?
        (doom-stateless-service
         name
         #:state '(((#:path . ("org-clock-save.el" #:doom-base #:data))
                    (#:storage . #:storage/persist))
                   ((#:path . ("org/persist/" #:doom-base #:cache))
                    (#:storage . #:storage/machine)))))))

   (doom-dash)))
#+end_src
***** File managers
****** Doom dired
#+begin_src scheme
(define* (doom-dired-prog #:key
                          stateless?
                          icons?
                          (dirvish? #t)
                          desktop?
                          doom-ui?
                          emacs-handler)
  (let ((name 'dired))
    (append
     (list
      (doom-service
       name
       #:modules `((#:emacs
                    (dired ,@(if icons? '(+icons) '())
                           ,@(if dirvish? '(+dirvish) '())))))

      (when (and stateless? dirvish?)
        (doom-stateless-service
         name
         #:state '(((#:path . ("dirvish/" #:doom-base #:cache))
                    (#:storage . #:storage/machine))))))

     (if dirvish?
         (doom-transient) '())

     (if (and desktop? doom-ui?)
         (list
          (emacs-xdg-service name
                             "file"
                             (emacs-handler
                              "dired"
                              '((dired (car args))))
                             #:default-for '(inode/directory)))
         '()))))
#+end_src
***** Shell utils
****** Direnv
#+begin_src scheme
(define* (direnv-prog #:key
                      doom?
                      shells)
  (append
   (list
    (simple-service
     'direnv-add-packages
     home-profile-service-type
     (list direnv))

    (simple-service
     'direnv-rc
     home-xdg-configuration-files-service-type
     `(("direnv/direnvrc" ,(local-file "direnvrc")))))

   (map (lambda (shell)
          (let ((direnv-hook
                 (lambda (shell-name)
                   (mixed-text-file
                    "direnv-hook"
                    (let ((direnv-bin (file-append direnv "/bin/direnv")))
                      #~(let ((quoted-subshell (lambda (command)
                                                 (string-append "\"$(" (string-join command) ")\""))))
                          (string-join
                           (list
                            "command" "-v" #$direnv-bin "> /dev/null"
                            "&&"
                            "eval" (quoted-subshell (list
                                                     #$direnv-bin "hook" #$shell-name))))))))))
            (case shell
              ((#:shell/bash) (simple-service
                               'direnv-bash-hook
                               home-bash-service-type
                               (home-bash-extension
                                (bashrc
                                 (list (direnv-hook "bash"))))))
              ((#:shell/zsh) (simple-service
                              'direnv-zsh-hook
                              home-zsh-service-type
                              (home-zsh-extension
                               (zshrc
                                (list (direnv-hook "zsh")))))))))
        shells)

   (list
    (when doom?
      (doom-service
       'direnv
       #:modules '((#:tools
                    direnv)))))))
#+end_src
******* Direnvrc
#+begin_src sh :tangle (meta-in-dir "direnvrc")
use_guixs() {
	LOCK_FILE=channels-lock

	if [ -f $LOCK_FILE ]; then
		eval "$(guix time-machine --channels=$LOCK_FILE -- shell --search-paths "$@")"
	else
		eval "$(guix shell --search-paths "$@")"
	fi
}
#+end_src
******* Whitelist service
#+begin_src scheme
(define direnv-whitelist-service-type
  (service-type
   (name 'direnv-whitelist)
   (extensions
    (list (service-extension home-xdg-configuration-files-service-type
                             (lambda (whitelist-entries)
                               `(("direnv/direnv.toml"
                                  ,(toml-file
                                    "direnv-config"
                                    (if (null? whitelist-entries)
                                        '()
                                        `((whitelist ((exact . ,(serialize-toml-array whitelist-entries)))))))))))))
   (compose concatenate)
   (extend (lambda (_ whitelist-entries)
             whitelist-entries))
   (default-value #f)
   (description "Whitelist for Direnv.")))
#+end_src
***** SSH
#+begin_src scheme
(define (ssh-prog)
  (list
   (service home-openssh-service-type)))
#+end_src
***** Text editors
****** Nano
- TODO The Guix skeleton =nanorc= points to the system installed nano, it should be changed to =~/.guix-home= or the used Nano package directly with a gexp. Update: I think I had this commented just because it was a WIP.
#+begin_src scheme
;; (define (nano-prog)
;;   (list
;;    (simple-service
;;     'nano-add-packages
;;     home-profile-service-type
;;     (list nano))

;;    (simple-service
;;     'nano-add-config
;;     home-xdg-configuration-files-service-type
;;     `(("nano/nanorc"
;;        ,%default-nanorc)))))
#+end_src
***** Trash
****** Doom trash
#+begin_src scheme
(define (doom-trash-prog)
  (list
   (doom-service
    'trash
    #:packages
    '((package! trashed :pin "52a52a363ce53855790e7a59aed6976eec18c9ea")))))
#+end_src
***** Version control
****** Git
#+begin_src scheme
(define* (git-prog #:key
                   stateless?
                   doom?
                   email
                   sign-commits? ; TODO make this (sign-commits? #t) once I have my gpg stuff set up and I'm passing a gpg-sign-key.
                   gpg-sign-key
                   ;; git-send-email?
                   extra-config)
  (append
   (list
    ;; (when git-send-email?
    ;;   (simple-service
    ;;    'git-send-email-package
    ;;    home-profile-service-type
    ;;    (list (list git "send-email"))))
    (service
     home-git-service-type
     (home-git-configuration
      (config
       (append
        `((user
           ((email . ,email)
            ,@(if sign-commits?
                  `((signingkey . ,gpg-sign-key)) '())))
          ;; TODO stuff from feature-git, figure it out later
          ;; (merge
          ;;  ;; diff3 makes it easier to solve conflicts with smerge, zdiff3
          ;;  ;; should make a conflict scope smaller, but guile-git fails if
          ;;  ;; this option is set.
          ;;  ((conflictStyle . diff3)))
          ;; (diff
          ;;  ;; histogram should be smarter about diff generation.
          ;;  ((algorithm . histogram)))
          (commit
           (,@(if sign-commits?
                  '((gpgsign . #t)) '())))
          ;; (sendemail
          ;;  ((annotate . #t)))
          ;;  TODO these two (http and gpg) sections were in the RDE example home environment (but notably not in the rde feature-git). Figure out what they're for after I do gpg.
          ;; (http "https://weak.example.com"
          ;;       ((ssl-verify . #f)))
          ;; (gpg
          ;;  ((program . ,(file-append gnupg "/bin/gpg"))))
          )
        (or extra-config '()))))))

   (if doom?
       (doom-git #:stateless? stateless?) '())))
#+end_src
******* Doom Git
#+begin_src scheme
(define* (doom-git #:key stateless?)
  (append
   (doom-version-control)

   (let ((name 'git))
     (list
      (doom-service
       name
       #:modules '((#:tools
                    (magit +forge)))
       #:config
       '((after! magit
                 (setq git-commit-style-convention-checks '(non-empty-second-line))
                 (setq magit-revision-show-gravatars '("^Author:     " . "^Commit:     ")))))

      (when stateless?
        (doom-stateless-service
         name
         #:state '(((#:path . ("forge/forge-database.sqlite" #:doom-base #:data))
                    ;; TODO Not sure this should necessarily be :persist and not :machine, can't be bothered to figure it out right now so let's be safe.
                    (#:storage . #:storage/persist)))))))

   (doom-transient #:stateless? stateless?)))
#+end_src
******** Doom version control
#+begin_src scheme
(define (doom-version-control)
  (list
   (doom-service
    'version-control
    #:modules '((#:emacs
                 vc)
                (#:ui
                 (vc-gutter +pretty)))
    #:config
    '((use-package! diff-hl
                    :defer t
                    :init
                    (remove-hook! 'diff-hl-mode-hook #'diff-hl-flydiff-mode))))))
#+end_src
***** VPN
****** Proton VPN CLI
#+begin_src scheme
(define* (protonvpn-prog #:key stateless?)
  (list
   (simple-service
    'protonvpn-add-packages
    home-profile-service-type
    (list protonvpn-cli))

   (when stateless?
     (home-stateless-service
      'protonvpn
      #:state '(((#:path . ".pvpn-cli/")
                 (#:storage . #:storage/machine)))))))
#+end_src
***** Miscellaneous programs
#+begin_src scheme
;; (define (misc-progs)
;;   (list
;;    (simple-service
;;     'misc-progs-add-packages
;;     home-profile-service-type
;;     (list curl
;;           ;; lm-sensors
;;           unzip
;;           zip))))
#+end_src
**** Apps
***** Audio
****** PulseAudio Volume Control
#+begin_src scheme
(define* (pavucontrol-app #:key
                          stateless?
                          gtk-services)
  (append
   (list
    (simple-service
     'pavucontrol-add-packages
     home-profile-service-type
     (list pavucontrol))

    (when stateless?
      (home-stateless-service
       'pavucontrol
       #:ignore '(((#:path . ("pavucontrol.ini" #:xdg-base "XDG_CONFIG_HOME"))))))) ; Pavucontrol overwrites the current file (or a symlink) so we can't store this. Let's just ignore it.

   (or gtk-services '())))
#+end_src
***** Fonts
****** Font Manager
#+begin_src scheme
(define* (font-manager-app #:key
                           stateless?
                           gtk-services)
  (append
   (list
    (simple-service
     'font-manager-add-packages
     home-profile-service-type
     (list fontmanager-no-googlefonts))

    (when stateless?
      (home-stateless-service
       'font-manager
       #:state '(((#:path . ("font-manager/" #:xdg-base "XDG_CACHE_HOME"))
                  (#:storage . #:storage/machine))
                 ((#:path . ("font-manager/" #:xdg-base "XDG_CONFIG_HOME"))
                  (#:storage . #:storage/persist))))))

   (or gtk-services '())))
#+end_src
***** Menus
****** Doom menu
#+begin_src scheme
;; Emacs already "has a menu" in the form of `completing-read', all we need is something to serve the role of application launcher.
(define (doom-menu-app)
  (list
   (doom-service
    'menu
    #:packages
    '((package! app-launcher
                :recipe (:host github
                         :repo "SebastienWae/app-launcher")
                :pin "d5015e394b0a666a8c7c4d4bdf786266e773b145")))))

(define (doom-menu emacs-handler)
  `((#:menu/menu . ,(list
                     (emacs-handler
                      "menu"
                      '((completing-read (concat (car args) ": ") (split-string input "\n") nil t))
                      #:modal? #t
                      #:modal-title "Menu"
                      #:minibuffer? #t
                      #:input? #t)))
    (#:menu/app-launcher . ,(list
                             (emacs-handler
                              "app-launcher"
                              '((app-launcher-run-app))
                              #:modal? #t
                              #:modal-title "App Launcher"
                              #:minibuffer? #t)))))
#+end_src
******* TODO [#C] Emacs =app-launcher= improvements
- [ ] show [[https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-latest.html#extra-actions][application actions]]
- [ ] display icons
  Issue requesting it and a possible approach: [[https://github.com/SebastienWae/app-launcher/issues/3][SebastienWae/app-launcher#3 Icons Support]]
****** Rofi
#+begin_src scheme
(define* (rofi-app #:key
                   stateless?
                   wayland?
                   colors
                   font
                   font-size)
  (list
   (simple-service
    'rofi-add-packages
    home-profile-service-type
    (list (get-rofi #:wayland? wayland?)))

   (simple-service
    'rofi-config
    home-xdg-configuration-files-service-type
    `(("rofi/config.rasi"
       ,(apply
         mixed-text-file
         "rofi-config.rasi"
         (serialize-rasi-config
          (append
           ;; Using Andrew Tropin's / RDE's confguration for now, revisit later.
           `((configuration
              ((modi . "run,ssh,drun")
               (drun-show-actions . #t)
               (show-icons . #t)
               (font . ,(pango-font-description font font-size))

               (kb-element-next . "")
               (kb-row-select . "Tab,Control+i")
               (kb-secondary-paste . "Control+y")
               (kb-remove-word-forward . "Alt+d")
               (kb-remove-word-back . "Control+w,Control+BackSpace")
               (kb-clear-line . "Control+slash")
               (kb-page-next . "Control+v")
               (kb-page-prev . "Alt+v"))))


           ;; Not done yet: configure Rofi to look pretty and use `colors' argument.
           ;; (list #~#$(string-append "@theme" " " (quoted "paper-float")))
           ;; (let ((clr (lambda* (color #:optional alpha)
           ;;              (as-> color $
           ;;                    (assoc-ref colors $)
           ;;                    (string-append $ (or alpha ""))))))
           ;;   `((*
           ;;      (;; (white . ,(clr #:color/fg))
           ;;       ;; (black . ,(clr #:color/bg))
           ;;       ;; (grey . ,(clr #:color/...))
           ;;       ;; (blue . ,(clr #:color/blue))
           ;;       (background . "#000000BF")))))
           ;; `((window
           ;;    ((transparency . "real"))))
           ))))))

   (when stateless?
     (home-stateless-service
      'rofi
      #:state '(((#:path . ("rofi3.druncache" #:xdg-base "XDG_CACHE_HOME"))
                 (#:storage . #:storage/machine)))))))

(define* (rofi-menu #:key wayland?)
  (let ((rofi-bin (file-append (get-rofi #:wayland? wayland?) "/bin/rofi")))
    `((#:menu/menu . ,(list rofi-bin "-dmenu" "-p"))
      (#:menu/app-launcher . ,(list rofi-bin "-show" "drun")))))

(define* (get-rofi #:key wayland?)
  (if wayland?
      rofi-wayland
      rofi))
#+end_src
***** Image processing
****** GIMP
#+begin_src scheme
(define* (gimp-app #:key
                   stateless?
                   gtk-services)
  (append
   (list
    (simple-service
     'gimp-add-packages
     home-profile-service-type
     (list gimp))

    (when stateless?
      (home-stateless-service
       'gimp
       #:state '(((#:path . ("gimp/" #:xdg-base "XDG_CACHE_HOME"))
                  (#:storage . #:storage/machine))
                 ((#:path . ("GIMP/" #:xdg-base "XDG_CONFIG_HOME"))
                  (#:storage . #:storage/machine))))))

   (or gtk-services '())))
#+end_src
***** Terminals
****** Alacritty
#+begin_src scheme
(define* (alacritty-app #:key
                        colors
                        font
                        font-size)
  (list
   (simple-service
    'alacritty-add-packages
    home-profile-service-type
    (list alacritty))

   (simple-service
    'alacritty-config
    home-xdg-configuration-files-service-type
    `(("alacritty/alacritty.toml"
       ,(toml-file
         "alacritty-config.toml"
         (append
          `((window ((opacity . 0.75)))
            (window.padding ((x . 5)
                             (y . 5))))
          (if font
              `((font ((size . ,(- font-size 1))))
                (font.normal ,(append
                               `((family . ,(assoc-ref font #:font/name)))
                               (if-let ((weight (assoc-ref font #:font/weight)))
                                       `((style . ,(font-weight->alacritty-style weight))) '()))))
              '())
          (let ((clr (lambda (color)
                       (assoc-ref colors color))))
            `((colors.primary ((background . ,(clr #:color/bg))
                               (foreground . ,(clr #:color/fg))))
              (colors.normal ((black . ,(clr #:color/base0))
                              (white . ,(clr #:color/base8))
                              (red . ,(clr #:color/red))
                              (green . ,(clr #:color/green))
                              (yellow . ,(clr #:color/yellow))
                              (blue . ,(clr #:color/blue))
                              (magenta . ,(clr #:color/magenta))
                              (cyan . ,(clr #:color/cyan)))))))))))))

(define (font-weight->alacritty-style weight)
  (->> weight
       (string-delete #\-)
       string-downcase
       string-capitalize))

(define (alacritty-terminal)
  (list
   (file-append alacritty "/bin/alacritty")))
#+end_src
****** Doom vterm
Does this belong in [[*Apps][Apps]]?
#+begin_src scheme
(define* (doom-vterm-app #:key setup-zsh?)
  (list
   (doom-service
    'vterm
    #:modules '((#:term
                 vterm)))

   (when setup-zsh?
     (simple-service
      'doom-vterm-zsh
      home-zsh-service-type
      (home-zsh-extension
       (zshrc
        (list (local-file "zsh-vterm"))))))))

(define (doom-vterm-terminal emacs-handler)
  (list
   (emacs-handler
    "vterm"
    '((+vterm/here nil)))))
#+end_src
******* Configure zsh for vterm
- TODO Changed the org source block type to "org" from "sh" because there's a fontification error. Maybe use zsh as the babel language instead of sh/bash, if it exists?
#+begin_src org :tangle (meta-in-dir "zsh-vterm")
vterm_printf(){
    if [ -n "$TMUX" ] && ([ "${TERM%%-*}" = "tmux" ] || [ "${TERM%%-*}" = "screen" ] ); then
        # Tell tmux to pass the escape sequences through
        printf "\ePtmux;\e\e]%s\007\e\\" "$1"
    elif [ "${TERM%%-*}" = "screen" ]; then
        # GNU screen (screen, screen-256color, screen-256color-bce)
        printf "\eP\e]%s\007\e\\" "$1"
    elif ([ "${TERM%%-*}" = "eterm" ] || [ "${TERM%%-*}" = "dumb" ]); then
        # Do nothing for Emacs' term and ansi-term, and other dumb terminals.
    else
        printf "\e]%s\e\\" "$1"
    fi
}

vterm_prompt_end() {
    # USERNAME=$(whoami)
    # HOSTNAME=$(hostname)
    vterm_printf "51;A$USER@$HOST:$(pwd)";
}
setopt PROMPT_SUBST
PROMPT=$PROMPT'%{$(vterm_prompt_end)%}'
#+end_src
***** Web browsers
****** Chromium
******* Ungoogled Chromium
#+begin_src scheme
(define* (ungoogled-chromium-app #:key
                                 stateless?
                                 toolkits
                                 wayland?
                                 pipewire?
                                 theme
                                 gtk-services
                                 qt-services
                                 (ungoogled-chromium ungoogled-chromium))
  (append
   (list
    (simple-service
     'ungoogled-chromium-add-packages
     home-profile-service-type
     ;; At the time of writing, ungoogled-chromium doesn't offer GTK 4 or QT 6 so just ignore the toolkits option.
     (list (chromium-wrapper ungoogled-chromium wayland? pipewire? theme)
           ublock-origin/chromium))

    (when stateless?
      (home-stateless-service
       'ungoogled-chromium
       #:state '(((#:path . ("chromium/" #:xdg-base "XDG_CACHE_HOME"))
                  (#:storage . #:storage/machine)
                  (#:mode . #o700))
                 ((#:path . ("chromium/" #:xdg-base "XDG_CONFIG_HOME"))
                  (#:storage . #:storage/machine)
                  (#:mode . #o700))
                 ((#:path . ".pki/nssdb/")
                  (#:storage . #:storage/machine)
                  (#:mode . #o700)
                  (#:parent-dir-perms . ((#:mode . #o700))))))))

   (or gtk-services '())
   (or qt-services '())))
#+end_src
******* Shared
- TODO chromium-wrapper
  - "Not done yet" bit at the bottom.
  - [2024-06-16 Sun] an alternative to consider: =chromium-flags.conf= / =chrome-flags.conf=
    See [[https://wiki.archlinux.org/title/chromium][Chromium - ArchWiki (2.3 Making flags persistent)]].
#+begin_src scheme
(define* (chromium-wrapper package wayland? pipewire? theme
                           #:key gtk4?)
  ;; (let ((flags (append
  ;;               (if gtk4?
  ;;                   '((#:switches . '("--gtk-version=4"))) '())
  ;;               (if wayland?
  ;;                   '((#:switches . '("--ozone-platform-hint=auto"))) '())
  ;;               (if pipewire?
  ;;                   '((#:features . '("WebRTCPipeWireCapturer"))) '())
  ;;               ;; Currently Chromium doesn't detect the light/dark-ness of the GTK theme for the `prefers-color-scheme' media query: https://bugs.chromium.org/p/chromium/issues/detail?id=998903
  ;;               (if (equal? theme #:theme/dark)
  ;;                   '((#:switches . '("--force-dark-mode"))
  ;;                     (#:features . '("WebUIDarkMode")))
  ;;                   '()))))
  ;;   (as-> flags $
  ;;         (apply merge-with append $)
  ;;         (let ((switches-args
  ;;                (apply append (assoc-ref $ #:switches)))
  ;;               (features-arg
  ;;                (let ((features (assoc-ref $ #:features)))
  ;;                  (when features
  ;;                    (string-append "--enable-features="
  ;;                                   (string-join features ","))))))
  ;;           (append switches-args
  ;;                   (or (list features-arg) '())))
  ;;         (string-join $)
  ;;         ;; Not done yet. This is where I'd add the command line args to a package wrapper like e.g. `ungoogled-chromium/wayland' does.
  ;;         ))
  package)
#+end_src
******** Setup instructions
It might be possible to configure some of these in a file (perhaps =master-preferences.json=, changing which would require modifying and thus rebuilding the chromium package). Ungoogled Chromium -specific features might not be configurable the same way as Chromium ones, if at all.
********* Chromium
- Settings > Appearance > Use GTK/QT theme
  Depending on which toolkit(s) are available and preferred.
- Settings > On startup, check "Continue where you left off"
- Right-click on the Bookmarks bar and uncheck "Show bookarks bar"
********** Ungoogled Chromium
- Settings > Manage search engines, make google the default
  It might not appear under "Other Search Engines" until you search something on google.com
- chrome://settings/cookies > uncheck "Clear cookies and site data when you close all windows"
********* uBlock extension
chrome://extensions > uBlock Origin > Details > Allow in Incognito
****** Mozilla
It might be possible to statically configure Icecat/Firefox, check out the Icecat profiles in RDE [[https://github.com/abcdw/rde/blob/793c0c667d556c33d4554fd585c2512d4d912f0f/src/gnu/home-services/web-browsers.scm][web-browsers.scm]].
******* Icecat
#+begin_src scheme
(define* (icecat-app #:key
                     stateless?
                     gtk-services)
  (append
   (list
    (simple-service
     'icecat-add-packages
     home-profile-service-type
     (list icecat))

    (when stateless?
      (home-stateless-service
       'icecat
       #:state '(((#:path . ("mozilla/icecat/" #:xdg-base "XDG_CACHE_HOME"))
                  (#:storage . #:storage/machine)
                  (#:mode . #o700)
                  (#:parent-dir-perms . ((#:mode . #o700))))
                 ((#:path . ".mozilla/icecat")
                  (#:storage . #:storage/machine)
                  (#:mode . #o700)
                  (#:parent-dir-perms . ((#:mode . #o700))))
                 ((#:path . ".mozilla/extensions")
                  (#:storage . #:storage/machine)
                  (#:mode . #o700)
                  (#:parent-dir-perms . ((#:mode . #o700))))))))

   (or gtk-services '())))
#+end_src
****** Nyxt
- TODO Add ~gtk-services~ param if Nyxt uses gtk settings (font, light/dark theme).
#+begin_src scheme
(define* (nyxt-app #:key
                   stateless?
                   doom?)
  (list
   (simple-service
    'nyxt-add-packages
    home-profile-service-type
    (list nyxt
          gst-libav
          gst-plugins-base
          gst-plugins-good
          gst-plugins-bad
          gst-plugins-ugly))

   (when stateless?
     (home-stateless-service
      'nyxt
      #:state '(((#:path . ("nyxt/" #:xdg-base "XDG_CACHE_HOME"))
                 (#:storage . #:storage/machine))
                ((#:path . ("webkitgtk/" #:xdg-base "XDG_DATA_HOME"))
                 (#:storage . #:storage/machine)))))

   (when doom?
     (doom-service
      'nyxt
      #:modules '((#:lang
                   common-lisp))))))
#+end_src
****** Tor browser
- TODO update stateless directories
  The Nix package put everything in a fake Home directory under =~/.local/share/tor-browser=, the Guix one might not?
- TODO Add ~gtk-services~ param if Tor browser uses gtk settings (font, light/dark theme). In the Nix version there's was a =.config/glib-2.0=, so it might not be possible (or even just advisable?) to use the global gtk settings. Screw it if so.
#+begin_src scheme
(define* (tor-browser-app #:key stateless?)
  (list
   (simple-service
    'tor-browser-add-packages
    home-profile-service-type
    (list torbrowser))

   (when stateless?
     (home-stateless-service
      'tor-browser
      #:state '(((#:path . ("tor-browser/" #:xdg-base "XDG_DATA_HOME"))
                 (#:storage . #:storage/machine)))))))
#+end_src
***** Video
****** VLC
#+begin_src scheme
(define* (vlc-app #:key
                  stateless?
                  qt-services)
  (append
   (list
    (simple-service
     'vlc-add-packages
     home-profile-service-type
     (list vlc))

    (when stateless?
      (home-stateless-service
       'vlc
       #:state '(((#:path . ("vlc/" #:xdg-base "XDG_CONFIG_HOME"))
                  (#:storage . #:storage/machine))
                 ((#:path . ("vlc/" #:xdg-base "XDG_DATA_HOME"))
                  (#:storage . #:storage/machine))))))

   (or qt-services '())))
#+end_src
***** Graphical toolkits
****** GTK
It's not totally clear what parts of this are Wayland-specific or if it's necessary to put e.g. ~gtk-theme-name~ in =settings.ini= for non-Wayland (see [[https://github.com/swaywm/sway/wiki/GTK-3-settings-on-Wayland][GTK 3 settings on Wayland · swaywm/sway Wiki · GitHub]].
#+begin_src scheme
(define* (gtk-services #:key
                       stateless?
                       theme
                       font
                       font-monospace
                       font-size)
  (list
   (simple-service
    'gtk-add-packages
    home-profile-service-type
    (list ;; arc-theme ; TODO Remove temporarily, it requires frequent rebuilds and I'm probably going to be changing it anyway. Also commented "gtk-theme" setting below.
          ;; I copied the following from Andrew Tropin's config. I'm not sure why I'd need or want all of them (perhaps as fallbacks and in the case of `gnome-themes-extra' as a fallback GTK 2 theme?). I might get rid of some of them later but for now I'll try having more than less.
          hicolor-icon-theme ; Andrew Tropin indicates (in abcdw/rde@3a8ea85f) that this is needed for network manager applet icons. [2024-07-20 Sat] update: deleted applets, do I still want this?
          adwaita-icon-theme
          ;; papirus-icon-theme ; TODO Remove for now, it massively increases guix build time. Why? Update: the situation may be better now: https://github.com/guix-mirror/guix/commit/aed385e18ec7b68a0bc1bb4b173aeadc9cd97245
          ;; gnome-themes-extra ; TODO Remove for now so I can avoid building its GTK 2 dependency.
          ))

   (simple-service
    'gtk-settings-and-dconf
    home-multi-xdg-configuration-files-service-type
    `(("gtk-3.0/settings.ini"
       ,(ini-file
         "gtk-3.0-settings.ini"
         `((Settings ((gtk-application-prefer-dark-theme . ,(equal? theme #:theme/dark)))))))
      ("gtk-4.0/settings.ini"
       ,(ini-file
         "gtk-4.0-settings.ini"
         `((Settings ((gtk-application-prefer-dark-theme . ,(equal? theme #:theme/dark)))))))
      ("dconf/user"
       ,(dconf-db
         "dconf-user"
         `((org/gnome/desktop/interface
            (;; (gtk-theme . ,(quoted-symbol
             ;;                (case theme
             ;;                  ((#:theme/light) "Arc")
             ;;                  ((#:theme/dark) "Arc-Dark"))))
             (font-name . ,(quoted-symbol
                            (pango-font-description font font-size)))
             (monospace-font-name . ,(quoted-symbol
                                      (pango-font-description font-monospace font-size))))))))))

   (when stateless?
     (home-stateless-service
      'gtk
      #:state '(((#:path . ("recently-used.xbel" #:xdg-base "XDG_DATA_HOME"))
                 (#:storage . #:storage/machine)))))))

(define (dconf-db name settings)
  (computed-file
   name
   (with-imported-modules '((guix build utils))
     #~(begin
         (use-modules ((guix build utils) #:select (invoke)))
         (invoke
          #$(file-append dconf "/bin/dconf")
          "compile"
          #$output
          #$(file-union ; Target of `compile` must be a directory.
             "dconf-keyfiledir"
             `(("dconf-keyfile"
                ,(ini-file
                  "dconf-keyfile"
                  settings)))))))))

(define (quoted-symbol s)
  (-> s single-quoted string->symbol))
#+end_src
****** Qt
#+begin_src scheme
(define* (qt-services #:key
                      stateless?
                      wayland?)
  (list
   (simple-service
    'qt-add-packages
    home-profile-service-type
    (if wayland?
        ;; Don't install qtwayland 6 for now since Guix doesn't allow multiple versions of a package in a profile (see https://issues.guix.gnu.org/65508). This is fine for the time being since most QT apps, at least in Guix, use QT 5.
        (list ;; qtwayland
              qtwayland-5)
        '()))

   (when stateless?
     (home-stateless-service
      'qt
      #:state '(((#:path . ("QtProject.conf" #:xdg-base "XDG_CONFIG_HOME"))
                 (#:storage . #:storage/machine)))))))
#+end_src
**** Work
#+begin_src scheme
(define* (work #:key
               stateless?
               (work-dir "work")
               projects)
  (append
   (if projects
       (append-map
        (match-lambda
          ((dir . opts)
           (let* ((dir* (string-append "/.persist/home/pharcosyle" "/" "work_for_now" "/" dir))
                  ;; (dir* (string-append (getenv "HOME") "/" work-dir "/" dir))
                  (proj-file (string-append dir* "/project.scm")))
             (if (file-exists? proj-file)
                 ;; TODO figure out the "add declarative" warning. Maybe rewrite to use `add-to-load-path'.
                 (apply (load proj-file) (->> opts
                                              (acons #:dir dir*)
                                              alist->list))
                 '()))))
        projects)
       '())

   (list
    (when stateless?
      (home-stateless-service
       'projects
       #:state `(((#:path . ,(string-append work-dir "/"))
                  (#:storage . #:storage/persist))))))))
#+end_src
***** Project helpers
#+begin_src scheme
(define (services-change-packages f svcs)
  (map (lambda (s)
         (and (service? s) ; Only here because I allow home components with #f not filtered out, see `create-he'.
              (service (f (service-kind s) home-profile-service-type)
                       (service-value s))))
       svcs))

(define services-only-packages
  (partial services-change-packages only-extensions))

(define services-sans-packages
  (partial services-change-packages without-extensions))
#+end_src
**** Shared
#+begin_src scheme
(define without-profile-extension
  (rpartial without-extensions home-profile-service-type))

(define home-multi-xdg-configuration-files-service-type
  (service-type
   (inherit home-xdg-configuration-files-service-type)
   (compose
    (lambda (exts)
      (as-> exts $
            (delete-duplicates $ (lambda (a b)
                                   (equal? (car a) (car b))))
            (apply append $))))))

(define log-home
  '((#:path . "log")
    (#:xdg-base . "XDG_STATE_HOME")))

(define (home-shepherd-service-log-file file)
  #~(string-append
     (getenv #$(assoc-ref log-home #:xdg-base))
     "/"
     #$(assoc-ref log-home #:path)
     "/"
     #$file))

(define very-big-history 1000000)
#+end_src
***** Serialization
#+begin_src scheme
(define* (ini-file name config
                   #:key (ini-serialize ini-serialize))
  (apply mixed-text-file name (ini-serialize config)))

;; TOML is pretty close to (RDE's idea of) INI so just piggyback off of that until I have more sophisticated needs.
(define (toml-file name config)
  (ini-file name config))

;; TODO This should be part of `toml-file' eventually.
(define (serialize-toml-array elements)
  (as-> elements $
        (map quoted $)
        (string-join $ ", ")
        (string-append "[ " $ " ]")
        (string->symbol $)))

(define (serialize-hyprlang form)

  (define* (serialize-tree tree)
    (->> tree
         (map serialize-expr)
         (apply append)))

  (define* (serialize-expr expr
                           #:optional
                           (nesting-level 0))
    (append (list (aligner nesting-level))
            (let ((head (car expr))
                  (tail (cdr expr)))
              (append (list (serialize-term head))
                      (if (and (= (length tail) 1)
                               (tree? (car tail)))
                          (serialize-subtree (car tail) nesting-level)
                          (serialize-arguments tail))))
            (list "\n")))

  (define (serialize-subtree subtree nesting-level)
    (append (list " {" "\n")
            (->> subtree
                 (map (lambda (expr)
                        (serialize-expr expr (1+ nesting-level))))
                 (apply append))
            (list (aligner nesting-level)
                  "}")))

  (define (serialize-arguments arguments)
    (cons " = "
          (->> arguments
               (map serialize-term)
               (interpose ", "))))

  (define (serialize-term term)
    (match term
      (#t "true")
      (#f "false")
      ((? keyword? e) (-> e keyword->symbol symbol->string))
      ((? number? e) (number->string e))
      ((? string? e) e)
      (e e)))

  (define (aligner nesting-level)
    (apply string-append
           (map (const "    ") (iota nesting-level))))

  (define (expr? x)
    (list? x))

  (define (tree? x)
    (and (list? x) (every expr? x)))

  (serialize-tree form))

(define* (hyprlang-file name body)
  (apply mixed-text-file name (serialize-hyprlang body)))
#+end_src
*** Composite components
**** System features
#+begin_src scheme
(define* (system-features #:key
                          stateless?
                          stateless-storage-paths
                          login-shell
                          doom?
                          doom-flags
                          package-managers
                          nix-nixpkgs-config-settings
                          console?
                          kmonad?
                          kmonad
                          desktop?
                          pipewire?
                          pipewire
                          bluetooth?
                          login-manager
                          desktop-tty-start-cmds
                          sessions
                          hyprland-environment
                          sway-environment
                          virtualization?)
  (append
   (if stateless?
       (stateless #:storage-paths stateless-storage-paths) '())
   (if (member #:pm/guix (or package-managers '()))
       (guix-pm #:stateless? stateless?
                #:doom? doom?)
       '())
   (if (member #:pm/nix (or package-managers '()))
       (nix-pm #:stateless? stateless?
               #:doom? doom?
               #:doom-tree-sitter? (assoc-ref doom-flags #:doom/tree-sitter?)
               #:login-shell login-shell
               #:nixpkgs-config-settings nix-nixpkgs-config-settings)
       '())
   (if console?
       (if kmonad?
           (kmonad-tool #:doom? doom?
                        #:kmonad kmonad)
           '())
       '())
   (if desktop?
       (append
        (if pipewire?
            (pipewire-media #:stateless? stateless?
                            #:pipewire pipewire)
            '())
        (if bluetooth?
            (bluetooth) '())
        (dbus-ipc)
        (if login-manager
            (case login-manager
              ((#:lm/gdm) (gdm #:stateless? stateless?)))
            (desktop-tty #:sessions sessions
                         #:start-cmds desktop-tty-start-cmds))
        (if (member #:session/gnome (or sessions '()))
            (gnome-desktop #:stateless? stateless?) '())
        (if (member #:session/hyprland (or sessions '()))
            hyprland-environment '())
        (if (member #:session/sway (or sessions '()))
            sway-environment '()))
       '())
   (if virtualization?
       (virtualization) '())))
#+end_src
***** Sessions
****** Hyprland environment
#+begin_src scheme
(define* (hyprland-environment #:key
                               pipewire?
                               doom?
                               input
                               output
                               portal-services
                               colors
                               wallpaper
                               font-variable-pitch
                               base-font-size
                               date-format
                               time-format
                               external-programs
                               (screen-locker (hyprlock-screen-locker)))
  (let ((session #:session/hyprland))
    (append
     (hyprland-wm #:pipewire? pipewire?
                  #:portal-services portal-services
                  #:input input
                  #:output output
                  #:external-programs
                  (append
                   `((#:idle-manager . ,(hypridle-idle-manager))
                     (#:screen-locker . ,(assoc-ref screen-locker #:screen-locker/lock-immediately)))
                   external-programs))
     (hyprlock-wm-piece #:colors colors
                        #:image wallpaper
                        #:font font-variable-pitch
                        #:font-size base-font-size
                        #:date-format date-format
                        #:time-format time-format)
     (hypridle-wm-piece #:session session
                        #:screen-locker (assoc-ref screen-locker #:screen-locker/lock))
     (mako-wm-piece #:colors colors
                    #:font font-variable-pitch
                    #:font-size base-font-size)
     (poweralertd-wm-piece))))
#+end_src
****** Sway environment
#+begin_src scheme
(define* (sway-environment #:key
                           sway
                           pipewire?
                           doom?
                           input
                           output
                           portal-services
                           colors
                           wallpaper
                           font-variable-pitch
                           base-font-size
                           date-format
                           time-format
                           external-programs
                           swaylock-effects?
                           swaylock
                           swaylock-effects
                           swayidle
                           (screen-locker (swaylock-screen-locker #:effects? swaylock-effects?
                                                                  #:swaylock swaylock
                                                                  #:swaylock-effects swaylock-effects)))
  (let ((session #:session/sway))
    (append
     (sway-wm #:sway sway
              #:pipewire? pipewire?
              #:doom? doom?
              #:portal-services portal-services
              #:input input
              #:output output
              #:external-programs
              (append
               `((#:sway . ,sway)
                 (#:idle-manager . ,(swayidle-idle-manager #:swayidle swayidle))
                 (#:screen-locker . ,(assoc-ref screen-locker #:screen-locker/lock-immediately)))
               external-programs))
     (swaylock-wm-piece #:colors colors
                        #:image wallpaper
                        #:font font-variable-pitch
                        #:date-format date-format
                        #:time-format time-format
                        #:effects? swaylock-effects?
                        #:swaylock swaylock
                        #:swaylock-effects swaylock-effects)
     (swayidle-wm-piece #:session session
                        #:sway sway
                        #:screen-locker (assoc-ref screen-locker #:screen-locker/lock)
                        #:swayidle swayidle)
     ;; TODO Omit dup with hyprland
     ;; (mako-wm-piece #:colors colors
     ;;                #:font font-variable-pitch
     ;;                #:font-size base-font-size)
     ;; (poweralertd-wm-piece)
     ;; (kanshi-wm-piece #:outputs outputs)
     )))
#+end_src
**** Programs
#+begin_src scheme
(define* (programs #:key
                   stateless?
                   interactive-shells
                   doom?
                   doom-flags
                   doom-ui?
                   email
                   desktop?
                   emacs-interface)
  (append
   (direnv-prog #:doom? doom?
                #:shells interactive-shells)
   ;; (protonvpn-prog #:stateless? stateless?)
   ;; (ssh-prog)
   (git-prog #:stateless? stateless?
             #:doom? doom?
             #:email email)
   (if doom?
       (append
        (if (assoc-ref doom-flags #:doom/calendar?)
            (doom-calendar-prog #:stateless? stateless?
                                #:org? (assoc-ref doom-flags #:doom/org?))
            '())
        (if (assoc-ref doom-flags #:doom/org?)
            (doom-org-prog #:stateless? stateless?
                           #:evil? (assoc-ref doom-flags #:doom/evil?))
            '())
        (doom-dired-prog #:stateless? stateless?
                         #:icons? (assoc-ref doom-flags #:doom/icons?)
                         #:desktop? desktop?
                         #:doom-ui? doom-ui?
                         #:emacs-handler (assoc-ref emacs-interface #:emacs/handler))
        (if doom-ui?
            (doom-trash-prog)
            '()))
       '()) ; Maybe have some alternatives for non-Doom here: Some file manager, trash-cli...
   ;; (misc-progs)
   ))
#+end_src
**** Apps
#+begin_src scheme
;; TODO Update with respect to nonphrenetic.
(use-modules ((nonphrenetic home) #:select (zoom-app google-chrome-app firefox-app)))

(define* (apps #:key
               stateless?
               pipewire?
               doom?
               doom-ui?
               theme
               colors
               font-variable-pitch
               font-mono
               base-font-size
               wayland?
               make-google-chrome)
  (let ((gtk (gtk-services #:stateless? stateless?
                           #:theme theme
                           #:font font-variable-pitch
                           #:font-monospace font-mono
                           #:font-size base-font-size))
        ;; (qt (qt-services #:stateless? stateless?
        ;;                  #:wayland? wayland?))
        )
    (append
     ;; (pavucontrol-app #:stateless? stateless?
     ;;                  #:gtk-services gtk)
     (font-manager-app #:stateless? stateless?
                       #:gtk-services gtk)
     (if doom-ui?
         (doom-menu-app)
         (rofi-app #:stateless? stateless?
                   #:wayland? wayland?
                   #:colors colors
                   #:font font-variable-pitch
                   #:font-size base-font-size))
     ;; (zoom-app #:stateless? stateless?
     ;;           #:qt-services qt)
     ;; (gimp-app #:stateless? stateless?
     ;;           #:gtk-services gtk)
     (alacritty-app #:colors colors
                    #:font font-mono
                    #:font-size base-font-size)
     (if doom-ui?
         (doom-vterm-app #:setup-zsh? #t
                         ;; TODO
                         ;; #:setup-zsh? (member #:shell/zsh interactive-shells)
                         )
         '())
     (google-chrome-app #:stateless? stateless?
                        #:toolkits '(#:chromium.toolkit/gtk4)
                        #:wayland? wayland?
                        #:pipewire? pipewire?
                        #:theme theme
                        #:gtk-services gtk
                        ;; #:qt-services qt
                        #:make-google-chrome make-google-chrome)
     ;; (firefox-app #:stateless? stateless?
     ;;              #:gtk-services gtk)
     ;; (nyxt-app #:stateless? stateless?
     ;;           #:doom? doom?)
     ;; (tor-browser-app #:stateless? stateless?)
     ;; (vlc-app #:stateless? stateless?
     ;;          #:qt-services qt)
     )))
#+end_src
**** Entire
#+begin_src scheme
;; TODO Update with respect to nonphrenetic.
(use-modules ((nonphrenetic home) #:select (%fonts) #:prefix nonphrenetic:))

(define* (he-entire #:key
                    stateless?
                    stateless-storage-paths
                    login-shell
                    (interactive-shells '(#:shell/zsh))
                    (wayland? #t)
                    emacs-pgtk
                    (emacs-interface (emacs-interface #:wayland? wayland?
                                                      #:emacs-pgtk emacs-pgtk))
                    doom?
                    doom-flags
                    doom-ui?
                    package-managers
                    nix-nixpkgs-config-settings
                    console?
                    kmonad?
                    kmonad
                    desktop?
                    media
                    media-pipewire
                    bluetooth?
                    (theme #:theme/dark)
                    (light-colors (assoc-ref %colors #:colors/nuclear-light))
                    (dark-colors (assoc-ref %colors #:colors/nuclear-dark))
                    (colors dark-colors)
                    (font-sans (assoc-ref nonphrenetic:%fonts #:fonts/apple-sf-pro))
                    (font-serif (assoc-ref nonphrenetic:%fonts #:fonts/apple-new-york))
                    (font-mono (assoc-ref %fonts #:fonts/fira-code))
                    (font-variable-pitch font-sans)
                    (base-font-size 10)
                    ;; TODO Temporarily remove until I figure out conflicting portal setups with multiple desktops.
                    ;; (portal-services ...)
                    login-manager
                    sessions
                    sessions-inputs
                    sessions-outputs
                    sessions-swaylock-effects?
                    sessions-swaylock
                    sessions-swaylock-effects
                    sessions-swayidle
                    virtualization?
                    email
                    projects
                    apps-make-google-chrome)
  (let ((pipewire? (equal? media #:media/pipewire)))
    (let ((he-base
           (lambda ()
             (append
              (let* ((wallpaper (assoc-ref %wallpapers #:wallpaper/alucard))
                     (input `((#:inputs . ,sessions-inputs)
                              (#:default-kb-repeat-delay . 200)
                              (#:default-kb-repeat-rate . 40)
                              (#:default-tp-tap? . #t)))
                     (output `((#:outputs . ,sessions-outputs)
                               (#:default-bg-image . ,wallpaper)))
                     (date-format (assoc-ref %date-formats #:date-format/simple))
                     (time-format (assoc-ref %time-formats #:time-format/simple))
                     (external-programs
                      (let ((menu (if doom-ui?
                                      (doom-menu (assoc-ref emacs-interface #:emacs/handler))
                                      (rofi-menu #:wayland? #t))))
                        `((#:notifier . ,(mako-notifier (assoc-ref menu #:menu/menu)))
                          (#:power-monitor . ,(poweralertd-monitor))
                          (#:app-launcher . ,(assoc-ref menu #:menu/app-launcher))
                          (#:terminal . ,(if doom-ui?
                                             (doom-vterm-terminal (assoc-ref emacs-interface #:emacs/handler))
                                             (alacritty-terminal)))
                          (#:backup-terminal . ,(if doom-ui?
                                                    (alacritty-terminal)
                                                    #f))
                          (#:emacs-interface . ,emacs-interface)))))
                (system-features #:stateless? stateless?
                                 #:stateless-storage-paths stateless-storage-paths
                                 #:login-shell login-shell
                                 #:doom? doom?
                                 #:doom-flags doom-flags
                                 #:package-managers package-managers
                                 #:nix-nixpkgs-config-settings nix-nixpkgs-config-settings
                                 #:console? console?
                                 #:kmonad? kmonad?
                                 #:kmonad kmonad
                                 #:desktop? desktop?
                                 #:pipewire? pipewire?
                                 #:pipewire media-pipewire
                                 #:bluetooth? bluetooth?
                                 #:login-manager login-manager
                                 #:desktop-tty-start-cmds `((#:session/gnome . ,(gnome-start))
                                                            (#:session/hyprland . ,(hyprland-start #:pipewire? pipewire?))
                                                            (#:session/sway . ,(sway-start #:sway sway
                                                                                           #:pipewire? pipewire?)))
                                 #:sessions sessions
                                 #:hyprland-environment (hyprland-environment #:pipewire? pipewire?
                                                                              #:doom? doom?
                                                                              #:input input
                                                                              #:output output
                                                                              #:portal-services (append
                                                                                                 (portal-config-services #:xdg-current-desktop "hyprland"
                                                                                                                         #:preferred '("hyprland" "gtk"))
                                                                                                 (portal-services/hyprland)
                                                                                                 (portal-services/gtk))
                                                                              #:colors colors
                                                                              #:wallpaper wallpaper
                                                                              #:font-variable-pitch font-variable-pitch
                                                                              #:base-font-size base-font-size
                                                                              #:date-format date-format
                                                                              #:time-format time-format
                                                                              #:external-programs external-programs)
                                 #:sway-environment (sway-environment #:sway sway
                                                                      #:pipewire? pipewire?
                                                                      #:doom? doom?
                                                                      #:input input
                                                                      #:output output
                                                                      #:portal-services (append
                                                                                         (portal-config-services #:xdg-current-desktop "sway"
                                                                                                                 #:preferred '("wlr" "gtk"))
                                                                                         (portal-services/wlr)
                                                                                         (portal-services/gtk))
                                                                      #:colors colors
                                                                      #:wallpaper wallpaper
                                                                      #:font-variable-pitch font-variable-pitch
                                                                      #:base-font-size base-font-size
                                                                      #:date-format date-format
                                                                      #:time-format time-format
                                                                      #:external-programs external-programs
                                                                      #:swaylock-effects? sessions-swaylock-effects?
                                                                      #:swaylock sessions-swaylock
                                                                      #:swaylock-effects sessions-swaylock-effects
                                                                      #:swayidle sessions-swayidle)
                                 #:virtualization? virtualization?))
              (shells #:stateless? stateless?
                      #:doom? doom?
                      #:doom-tree-sitter? (assoc-ref doom-flags #:doom/tree-sitter?)
                      #:login-shell login-shell
                      #:interactive-shells interactive-shells)
              (xdg-base-directories)
              (xdg-trash #:stateless? stateless?)
              (emacs-editor #:wayland? wayland?
                            #:emacs-pgtk emacs-pgtk)
              (if (or doom? doom-ui?)
                  (append
                   (doom #:stateless? stateless?
                         #:services (doom-core #:stateless? stateless?
                                               #:evil? (assoc-ref doom-flags #:doom/evil?)
                                               #:icons? (assoc-ref doom-flags #:doom/icons?)
                                               #:email email))
                   (if desktop?
                       (doom-desktop #:theme theme
                                     #:light-colors light-colors
                                     #:dark-colors dark-colors
                                     #:font font-mono
                                     #:font-variable-pitch font-variable-pitch
                                     #:font-size base-font-size)
                       '()))
                  '())
              (if desktop?
                  (append
                   (font-library #:stateless? stateless?
                                 #:font-sans font-sans
                                 #:font-serif font-serif
                                 #:font-mono font-mono
                                 #:extra-fonts (list (assoc-ref %fonts #:fonts/google-noto)
                                                     (assoc-ref %fonts #:fonts/liberation)
                                                     (assoc-ref nonphrenetic:%fonts #:fonts/apple-color-emoji)
                                                     (assoc-ref nonphrenetic:%fonts #:fonts/apple-sf-compact)
                                                     (assoc-ref nonphrenetic:%fonts #:fonts/apple-sf-arabic)
                                                     (assoc-ref %fonts #:fonts/google-noto-sans-cjk)
                                                     (assoc-ref %fonts #:fonts/google-noto-serif-cjk)
                                                     (assoc-ref nonphrenetic:%fonts #:fonts/apple-symbols)))
                   (xdg-user-directories #:stateless? stateless?)
                   (mesa #:stateless? stateless?)
                   (flatpak-apps #:stateless? stateless?
                                 ;; TODO Temporarily remove until I figure out conflicting portal setups with multiple desktops.
                                 ;; #:portal-services portal-services
                                 ))
                  '())
              (work #:stateless? stateless?
                    #:projects projects))))
          (he-programs
           (lambda ()
             (programs #:stateless? stateless?
                       #:interactive-shells interactive-shells
                       #:doom? doom?
                       #:doom-flags doom-flags
                       #:doom-ui? doom-ui?
                       #:email email
                       #:desktop? desktop?
                       #:emacs-interface emacs-interface)))
          (he-apps
           (lambda ()
             (apps #:stateless? stateless?
                   #:pipewire? pipewire?
                   #:doom? doom?
                   #:doom-ui? doom-ui?
                   #:theme theme
                   #:colors colors
                   #:font-variable-pitch font-variable-pitch
                   #:font-mono font-mono
                   #:base-font-size base-font-size
                   #:wayland? wayland?
                   #:make-google-chrome apps-make-google-chrome))))
      (append
       (he-base)
       (he-programs)
       (if desktop?
           (he-apps) '())))))
#+end_src
** Common
*** Stateless
:PROPERTIES:
:header-args+: :tangle (meta-in-dir "stateless.scm")
:END:
#+begin_src scheme
(define-module (phrenetic stateless)
  #:use-module (guix gexp)
  #:use-module ((guix modules) #:select (source-module-closure))
  #:use-module (guix packages)
  #:use-module (gnu services)
  #:use-module (phrenetic modules)
  #:use-module (phrenetic utils)
  #:export (service-fn
            extend-proc
            tool-package))
#+end_src
**** Service
***** Service extension
#+begin_src scheme
(define (service-fn service-type)
  (lambda* (name #:key state ignore)
    (simple-service
     (symbol-append name '-stateless)
     service-type
     `((#:state . ,state)
       (#:ignore . ,ignore)))))
#+end_src
***** Extend procedure
#+begin_src scheme
(define (extend-proc config exts)
  (let ((exts* (apply merge-with append exts)))
    (->> (apply list->alist config)
         (acons #:state (assoc-ref exts* #:state))
         (acons #:ignore (assoc-ref exts* #:ignore)))))
#+end_src
**** Tool
#+begin_src scheme
(define* (tool-package bin-name #:rest opts)
  (package
    (inherit simple-package)
    (name "stateless")
    (source (tool-program opts))
    (arguments
     `(#:builder
       ,#~(begin
            (let ((bin (string-append #$output "/bin")))
              (mkdir #$output)
              (mkdir bin)
              (symlink #$source (string-append bin "/" #$bin-name))))))))

(define (tool-program opts)
  (program-file
   "stateless"
   (with-imported-modules (source-module-closure
                           '((phrenetic build stateless))
                           #:select? phrenetic-module-name?)
     #~(begin
         (use-modules ((phrenetic build stateless) #:select (tool)))
         (apply tool '#$opts)))))
#+end_src
**** Build
:PROPERTIES:
:header-args+: :tangle (meta-in-dir "build/stateless.scm")
:END:
#+begin_src scheme
(define-module (phrenetic build stateless)
  #:use-module ((guix build utils) #:select (copy-recursively delete-file-recursively find-files mkdir-p store-file-name? symbolic-link?))
  #:use-module (phrenetic build utils)
  #:use-module ((ice-9 ftw) #:select (file-system-fold))
  #:use-module ((srfi srfi-1) #:select (any))
  #:use-module ((ice-9 match) #:select (match-lambda))
  #:export (activate
            tool))
#+end_src
***** Activate
#+begin_src scheme
(define (activate state
                  backup-base-dir
                  storage-paths)
  (define (run)
    (for-each process-state-entry state))

  (define (process-state-entry i)
    (let* ((path (assoc-ref i #:path))
           (directory-target? (string-suffix? "/" path))
           (target (if directory-target?
                       (string-drop-right path 1) path))
           (storage-dir (assoc-ref storage-paths (assoc-ref i #:storage))))
      (let ((parent-dir (dirname path))
            (parent-dir-perms (assoc-ref i #:parent-dir-perms)))
        (mkdirp-perms (string-append storage-dir parent-dir) parent-dir-perms)
        (mkdirp-perms parent-dir parent-dir-perms))
      (let ((state-file (string-append storage-dir target)))
        (cleanup-and-migrate target state-file storage-dir)
        (when directory-target?
          (mkdirp-perms state-file i))
        (when (or (no-follow-file-exists? state-file)
                  (assoc-ref i #:preemptively?))
          (symlink state-file target)))))

  (define (cleanup-and-migrate target state-file storage-dir)
    (let ((migrate-file
           (lambda (source dest)
             (copy-recursively source dest)
             (delete-file-recursively source)))
          (backup-file
           (lambda (file)
             (let* ((backup-dir (string-append
                                 storage-dir
                                 backup-base-dir
                                 "/stateless-backup-" (number->string timestamp)))
                    (backup-file (string-append
                                  backup-dir "/"
                                  (let* ((string-drop-prefix (lambda (s prefix)
                                                               (string-drop s (string-length prefix))))
                                         (without-storage-dir (lambda (file)
                                                                (string-drop-prefix file storage-dir)))
                                         (without-base-dir (lambda (file)
                                                             (string-drop-prefix file backup-base-dir))))
                                    ((compose without-base-dir
                                              without-storage-dir)
                                     file)))))
               (mkdir-p (dirname backup-file))
               (rename-file file backup-file)))))
      (when (no-follow-file-exists? target)
        (if ((symlink-to-storage? (map (match-lambda ((_ . dir) dir))
                                       storage-paths))
             target)
            (delete-file target)
            (begin
              (when (no-follow-file-exists? state-file)
                (if (nil? (find-files state-file)) ; TODO did I have `nil?` instead of `null?` for some reason or was it just an accident? Update: remember nil? and null? are different (empyt list and #f ar false vs just the empty list)
                    (delete-file-recursively state-file)
                    (backup-file state-file)))
              (migrate-file target state-file))))))

  (define (mkdirp-perms dir perms)
    (mkdir-p dir)
    (chown dir
           (let ((user (assoc-ref perms #:user)))
             (if user
                 (passwd:uid (getpwnam user)) -1))
           (let ((group (assoc-ref perms #:group)))
             (if group
                 (group:gid (getgrnam group)) -1)))
    (let ((mode (assoc-ref perms #:mode)))
      (when mode
        (chmod dir mode))))

  (define timestamp (current-time))

  (run))
#+end_src
***** Tool
#+begin_src scheme
;;;;;;;;;; TODO TEMPORRARY REMOVE ME
;; (define-module (phrenetic build stateless)
;;   #:use-module ((guix build utils) #:select (copy-recursively delete-file-recursively find-files mkdir-p store-file-name? symbolic-link?))
;;   #:use-module (phrenetic build utils)
;;   #:use-module ((ice-9 ftw) #:select (file-system-fold))
;;   #:use-module ((srfi srfi-1) #:select (any))
;;   #:export (activate
;;             tool))
;;;;;;;

(use-modules ;; ((guix build utils) #:select (find-files))
 ((srfi srfi-1) #:select (append-map every partition))
 ((srfi srfi-11) #:select (let-values))
 ((ice-9 ftw) #:select (scandir))
 ((ice-9 match) #:select (match match-lambda))
 ((ice-9 textual-ports) #:select (get-string-all)))


(define* (tool state
               ignore
               base-dir
               storage-paths)
  (let ((state* (normalize-entries state))
        (all-ignore (normalize-entries ignore)))
    (for-each
     (lambda (path)
       (display (string-append path "\n")))
     (case (run-mode)
       ((active) (diff-live state*
                            (filter (lambda (entry)
                                      (not (assoc-ref entry #:storage)))
                                    all-ignore)
                            base-dir
                            storage-paths))
       ((storage) (diff-storage (map (match-lambda ((_ . dir) dir))
                                     storage-paths)
                                state*
                                (filter (lambda (entry)
                                          (assoc-ref entry #:storage))
                                        all-ignore)
                                base-dir
                                storage-paths))))))

(define (run-mode)
  (string->symbol
   (or
    (false-if-exception (cadr (command-line)))
    ;; "active"
    "storage" ; TODO temporary for testing
    )))

(define (diff-live state
                   ignore
                   base-dir
                   storage-paths)
  (let-values (((ignore-files ignore-dirs) (files+dirs ignore)))
    (diff base-dir
          (append (state->known-symlinks state storage-paths)
                  (ignore->known ignore-files))
          (ignore->known ignore-dirs)
          #:omit-empty-dirs? #t)))

(define (normalize-entries entries)
  (map (lambda (entry)
         (let ((path (assoc-ref entry #:path)))
           (if (string-suffix? "/" path)
               (->> entry
                    (acons #:directory? #t)
                    (acons #:path (string-drop-right path 1)))
               entry)))
       entries))

;; TODO probably just do two filter statements instad of this.
(define (files+dirs entries)
  (partition (lambda (entry)
               (not (assoc-ref entry #:directory?)))
             entries))

(define (state->known-symlinks state storage-paths)
  (map (lambda (entry)
         (let ((path (assoc-ref entry #:path)))
           (cons path `((#:symlink-to ,(string-append
                                        (assoc-ref storage-paths (assoc-ref entry #:storage))
                                        path))))))
       state))

(define (ignore->known ignore)
  (map (lambda (entry)
         (cons (assoc-ref entry #:path)
               (or (assoc-ref entry #:preds)
                   '())))
       ignore))


;; (define (file-entries entries)
;;   (filter (lambda (entry)
;;                (not (assoc-ref entry #:directory?)))
;;              entries))

(define (storage-entries storage entries)
  (filter (lambda (entry)
            (equal? (assoc-ref entry #:storage) storage))
          entries))

(define (entries-with-storage-dir storage-dir entries)
  (map (lambda (entry)
         (acons #:path (string-append storage-dir (assoc-ref entry #:path)) entry))
       entries))

(define (diff-storage storages
                      state
                      ignore
                      base-dir
                      storage-paths)
  (let ((diff* ; TODO rename this
         (lambda (storage)
           (let ((storage-dir (assoc-ref storage-paths storage)))
             (let-values (((state-files state-dirs) (files+dirs state))
                          ((ignore-files ignore-dirs) (files+dirs ignore)))
               (diff (string-append storage-dir base-dir)
                     (append (->> state-files
                                  (storage-entries storage)
                                  (entries-with-storage-dir storage-dir)
                                  (map (lambda (entry)
                                         (cons (assoc-ref entry #:path) '()))))
                             (->> ignore-files
                                  (storage-entries storage)
                                  (entries-with-storage-dir storage-dir)
                                  ignore->known))
                     (append (->> state-dirs
                                  (storage-entries storage)
                                  (entries-with-storage-dir storage-dir)
                                  (map (lambda (entry)
                                         (cons (assoc-ref entry #:path) '()))))
                             (->> ignore-dirs
                                  (storage-entries storage)
                                  (entries-with-storage-dir storage-dir)
                                  ignore->known))))))))
    (append-map diff* storages)))

(define* (diff directory known-files known-dirs #:key omit-empty-dirs?)
  (as-> directory $
        (let* ((test (lambda (path known)
                       (let ((cand (assoc path known)))
                         (and cand
                              (every (match-lambda
                                       ((pred-name args ...)
                                        (apply (assoc-ref predicates pred-name) (cons path args))))
                                     (match cand ((_ . preds) preds))))))))
          (file-system-fold
           (let ((known-paths (map (match-lambda ((path . _) path))
                                   (append known-files known-dirs)))
                 (known-dir-paths (map (match-lambda ((path . _) path))
                                       known-dirs)))
             (fn (lambda (dir _ _*)
                   (and (not (member dir known-dir-paths))
                        (any (lambda (known-path)
                               (string-prefix? dir known-path))
                             known-paths)))))
           (fn (lambda (file _ res)
                 (if (test file known-files)
                     res
                     (cons file res))))
           (fn (lambda (_ _* res)
                 res))
           (fn (lambda (_ _* res)
                 res))
           (fn (lambda (dir _ res)
                 (if (or (test dir known-dirs)
                         (and omit-empty-dirs?
                              (null? (scandir-no-implied dir))))
                     res
                     (cons (string-append dir "/") res))))
           (lambda (path _ errno res) ; TODO use `fn' for this.
             (format (current-error-port) "~a: ~a~%" path (strerror errno))
             res)
           '()
           $))
        (sort $ string<?)))

(define (fn f)
  (lambda (path _ res)
    (let ((asdf (if (string-prefix? "//" path)
                    (string-drop path 1)
                    path)))
      (f asdf _ res))))

(define (scandir-no-implied dir)
  (scandir dir (negate dot-or-dot-dot?)))

(define (dot-or-dot-dot? file)
  (member file '("." "..")))

(define predicates
  `((#:symlink-to . ,(lambda (path to)
                       (and (symbolic-link? path)
                            (equal? (readlink path) to))))
    (#:symlink-to-store . ,(lambda (path)
                             (and (symbolic-link? path)
                                  (store-file-name? (readlink path)))))
    (#:empty-file . ,(lambda (path)
                       (zero? (-> path stat stat:size))))
    (#:empty-dir . ,(lambda (path)
                      (null? (scandir-no-implied path))))
    (#:file-content . ,(lambda (path content)
                         (let ((cont (false-if-exception
                                      (call-with-input-file path
                                        get-string-all))))
                           (and cont
                                (equal? cont content)))))))

(define test-state '(((#:path . "/etc/NetworkManager/system-connections/")
                      (#:storage . #:storage/machine))
                     ((#:path . "/var/lib/NetworkManager/")
                      (#:storage . #:storage/machine)
                      (#:mode . 448))
                     ((#:path . "/etc/machine-id")
                      (#:storage . #:storage/machine))
                     ((#:path . "/var/lib/upower/")
                      (#:storage . #:storage/machine))
                     ((#:path . "/root/.cache/nix/")
                      (#:storage . #:storage/machine))
                     ((#:path . "/etc/guix/signing-key.pub")
                      (#:storage . #:storage/machine)
                      (#:parent-dir-perms
                       (#:mode . 73)))
                     ((#:path . "/etc/guix/signing-key.sec")
                      (#:storage . #:storage/machine)
                      (#:parent-dir-perms
                       (#:mode . 73)))
                     ((#:path . "/root/.cache/guix/")
                      (#:storage . #:storage/machine))
                     ((#:path . "/var/lib/random-seed")
                      (#:storage . #:storage/machine))
                     ((#:path . "/var/db/nscd/")
                      (#:storage . #:storage/machine))
                     ((#:path . "/.lastweek")
                      (#:storage . #:storage/machine))))
(define test-ignore '(((#:path . "nix/")
                       (#:storage . #:storage/machine))
                      ((#:path . "/.machine/.swap")
                       (#:storage . #:storage/machine))
                      ((#:path . "/nix/store/"))
                      ((#:path . "/nix/var/nix/"))
                      ((#:path . "/nix/var/log/nix/"))
                      ((#:path . "/var/guix/"))
                      ((#:path . "/etc/guix/acl")
                       (#:preds
                        (#:symlink-to-store)))
                      ((#:path . "/etc/resolv.conf"))
                      ((#:path . "/etc/resolv.conf.bak"))
                      ((#:path . "/bin/sh")
                       (#:preds
                        (#:symlink-to-store)))
                      ((#:path . "/usr/bin/env")
                       (#:preds
                        (#:symlink-to-store)))
                      ((#:path . "/dev/"))
                      ((#:path . "/proc/"))
                      ((#:path . "/run/"))
                      ((#:path . "/sys/"))
                      ((#:path . "/tmp/"))
                      ((#:path . "/var/lock/"))
                      ((#:path . "/var/run/"))
                      ((#:path . "/etc/group"))
                      ((#:path . "/etc/passwd"))
                      ((#:path . "/etc/shadow"))
                      ((#:path . "/etc/.pwd.lock"))
                      ((#:path . "/etc/mtab")
                       (#:preds
                        (#:symlink-to "/proc/self/mounts")))
                      ((#:path . "/etc/ssl")
                       (#:preds
                        (#:symlink-to "/run/current-system/profile/etc/ssl")))
                      ((#:path . "/etc/static")
                       (#:preds
                        (#:symlink-to-store)))))
(define (test)
  (tool test-state
        test-ignore
        "/"
        `((#:storage/machine . "/.machine")
          (#:storage/persist . "/.persist"))))
;; (test)
#+end_src
***** Shared
#+begin_src scheme
;; TODO Just used in `activate` now
(define (symlink-to-storage? storage-dirs)
  (lambda (file)
    (and (symbolic-link? file)
         (any (lambda (storage-dir)
                (string-prefix? storage-dir (readlink file)))
              storage-dirs))))
#+end_src
** Modules
#+begin_src scheme :tangle (meta-in-dir "modules.scm")
(define-module (phrenetic modules)
  #:use-module ((guix modules) #:select (guix-module-name?))
  #:use-module (ice-9 match)
  #:export (phrenetic-module-name?))

(define (phrenetic-module-name? name)
  (or (guix-module-name? name)
      (match name
        (('phrenetic _ ...) #t)
        (_ #f))))
#+end_src
** Utils
*** Host
:PROPERTIES:
:header-args+: :tangle (meta-in-dir "utils.scm")
:END:
#+begin_src scheme
(define-module (phrenetic utils)
  #:use-module (guix build-system trivial)
  #:use-module (guix git-download)
  #:use-module (guix packages)
  #:use-module (gnu services)
  #:use-module (phrenetic common utils)
  #:use-module ((srfi srfi-1) #:select (remove))
  #:export (simple-package
            with-git-url
            with-git-version
            with-git-commit
            remove-services-by-types
            only-extensions
            without-extensions))

(re-export-public-interface (phrenetic common utils))
#+end_src
***** Packages
#+begin_src scheme
(define simple-package
  (package
    (name #f)
    (version "0")
    (source #f)
    (build-system trivial-build-system)
    (synopsis #f)
    (description #f)
    (home-page #f)
    (license #f)))
#+end_src
****** Git
#+begin_src scheme
(define (with-git-url pkg url)
  (package
    (inherit pkg)
    (source
     (origin
       (inherit (package-source pkg))
       (uri (git-reference
             (inherit (-> pkg package-source origin-uri))
             (url url)))))))

(define* (with-git-version pkg
                           #:key
                           version
                           commit-proc
                           hash)
  (with-git pkg
            #:upstream-version version
            #:commit (if commit-proc
                         (commit-proc version)
                         version)
            #:hash hash))

(define* (with-git-commit pkg
                          #:key
                          upstream-version
                          (revision "0")
                          commit
                          hash)
  (with-git pkg
            #:upstream-version upstream-version
            #:revision revision
            #:commit commit
            #:hash hash))

(define* (with-git pkg
                   #:key
                   upstream-version
                   revision
                   commit
                   hash)
  (package
    (inherit pkg)
    (version (if revision
                 (git-version upstream-version revision commit)
                 upstream-version))
    (source
     (origin
       (inherit (package-source pkg))
       (uri (git-reference
             (inherit (-> pkg package-source origin-uri))
             (commit commit)))
       (sha256
        (base32
         hash))
       (file-name (git-file-name (package-name pkg) version))))))
#+end_src
***** Services
#+begin_src scheme
(define* (remove-services-by-types services #:rest kinds)
  (remove (lambda (s)
            (member (service-kind s) kinds))
          services))

(define* (change-extensions f st #:rest exts)
  (service-type
   (inherit st)
   (extensions
    (f (lambda (candidate)
         (member (service-extension-target candidate) exts))
       (service-type-extensions st)))))

(define only-extensions
  (partial change-extensions filter))

(define without-extensions
  (partial change-extensions remove))
#+end_src
*** Build
:PROPERTIES:
:header-args+: :tangle (meta-in-dir "build/utils.scm")
:END:
#+begin_src scheme
(define-module (phrenetic build utils)
  #:use-module ((guix build syscalls) #:select (mkdtemp!))
  #:use-module ((guix build utils) #:select (delete-file-recursively))
  #:use-module (phrenetic common utils)
  #:export (no-follow-file-exists?
            call-with-temporary-directory))

(re-export-public-interface (phrenetic common utils))


(define (no-follow-file-exists? f)
  (false-if-exception (lstat f)))

;; Copied from (guix utils). Notably (gnu build linux-container) copies this function in like this too.
(define (call-with-temporary-directory proc)
  "Call PROC with a name of a temporary directory; close the directory and
delete it when leaving the dynamic extent of this call."
  (let* ((directory (or (getenv "TMPDIR") "/tmp"))
         (template  (string-append directory "/guix-directory.XXXXXX"))
         (tmp-dir   (mkdtemp! template)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (proc tmp-dir))
      (lambda ()
        (false-if-exception (delete-file-recursively tmp-dir))))))
#+end_src
*** Common
:PROPERTIES:
:header-args+: :tangle (meta-in-dir "common/utils.scm")
:END:
#+begin_src scheme
(define-module (phrenetic common utils)
  #:use-module ((ice-9 match) #:select (match-lambda))
  #:use-module ((srfi srfi-1) #:select (append-map fold fold-right take drop))
  #:export (re-export-public-interface
            when-let
            if-let
            when-not
            if-not
            partial
            rpartial
            ->
            ->>
            as->
            list->alist
            alist->list
            merge
            merge-with
            select-keys
            update-keys
            update-vals
            interpose
            around
            quoted
            single-quoted
            KiB
            MiB
            GiB))

;; Copied this from the "Guile CV" project. The gnu.scm file has something like this too.
(define-macro (re-export-public-interface . args)
  "Re-export the public interface of a module or modules. Invoked as
@code{(re-export-public-interface (mod1) (mod2)...)}."
  (if (null? args)
      '(if #f #f)
      `(begin
         ,@(map (lambda (mod)
                  (or (list? mod)
                      (error "Invalid module specification" mod))
                  `(module-use! (module-public-interface (current-module))
                    (resolve-interface ',mod)))
                args))))
#+end_src
**** Branching
#+begin_src scheme
(define-syntax when-let
  (syntax-rules ()
    ((_ ((var expr)) body ...)
     (let ((var expr))
       (when var body ...)))))

(define-syntax if-let
  (syntax-rules ()
    ((_ ((var expr)) then else)
     (let ((var expr))
       (if var then else)))))

(define-syntax when-not
  (syntax-rules ()
    ((_ test body ...)
     (when (not test) body ...))))

(define-syntax if-not
  (syntax-rules ()
    ((_ test then else)
     (if (not test) then else))))
#+end_src
**** Functions
#+begin_src scheme
(define* (partial f #:rest args)
  (lambda* (#:rest more)
    (apply f (append args more))))

(define* (rpartial f #:rest args)
  (lambda* (#:rest more)
    (apply f (append more args))))
#+end_src
***** Threading
#+begin_src scheme
(define-syntax ->
  (syntax-rules ()
    ((_ x) x)
    ((_ x (f args ...) expr ...) (-> (f x args ...) expr ...))
    ((_ x f expr ...) (-> (f x) expr ...))))

(define-syntax ->>
  (syntax-rules ()
    ((_ x) x)
    ((_ x (f args ...) expr ...) (->> (f args ... x) expr ...))
    ((_ x f expr ...) (->> (f x) expr ...))))

(define-syntax as->
  (lambda (x)
    (syntax-case x ()
      ((_ exp name) #'exp)
      ((_ exp name form form* ...)
       (with-syntax ((x (datum->syntax #'form (syntax->datum #'name))))
         #'(let ((x exp))
             (as-> form name form* ...)))))))
#+end_src
**** Alists
#+begin_src scheme
(define* (list->alist #:rest kvs)
  (let loop ((res '())
             (more kvs))
    (if (null? more)
        res
        (loop (cons (as-> more $
                          (take $ 2)
                          (apply cons $))
                    res)
              (drop more 2)))))

(define (alist->list alist)
  (append-map
   (match-lambda
     ((k . v)
      (list k v)))
   alist))

(define* (merge #:rest alists)
  (apply merge-with
         (match-lambda
           ((_ . latter) latter))
         alists))

(define* (merge-with f #:rest alists)
  (fold
   (lambda (a res)
     (map
      (lambda (k)
        (cons k
              (let ((res-v (assoc-ref res k))
                    (v (assoc-ref a k)))
                (if (and res-v v)
                    (f res-v v)
                    (or res-v v)))))
      (let ((keys (lambda (alist)
                    (map car alist))))
        (append (keys res)
                (filter (lambda (k)
                          (not (member k (keys res))))
                        (keys a))))))
   '()
   alists))

(define (select-keys alist ks)
  (filter (match-lambda
            ((k . v)
             (member k ks)))
          alist))

(define (update-keys alist f)
  (map (match-lambda
         ((k . v)
          (cons (f k) v)))
       alist))

(define (update-vals alist f)
  (map (match-lambda
         ((k . v)
          (cons k (f v))))
       alist))
#+end_src
**** Lists
#+begin_src scheme
(define (interpose sep lst)
  (fold-right (lambda (e acc)
                (cons e
                      (if (null? acc)
                          acc
                          (cons sep acc))))
              '() lst))
#+end_src
**** Misc
#+begin_src scheme
(define (around s x)
  (string-append x s x))

(define (quoted s)
  (string-append "\"" s "\""))

(define (single-quoted s)
  (string-append "'" s "'"))

(define KiB (expt 2 10))
(define MiB (expt 2 20))
(define GiB (expt 2 30))
#+end_src
* Nonphrenetic
:PROPERTIES:
:meta-dir+: nonphrenetic
:END:
** System
:PROPERTIES:
:header-args+: :tangle (meta-in-dir "system.scm")
:END:
#+begin_src scheme
(define-module (nonphrenetic system)
  #:use-module (guix gexp)
  #:use-module (gnu services)
  #:use-module ((gnu services linux) #:select (kernel-module-loader-service-type))
  #:use-module (gnu system)
  #:use-module ((nongnu packages firmware) #:select (facetimehd-calibration facetimehd-firmware nouveau-firmware))
  #:use-module ((nongnu packages linux) #:select (linux linux-firmware linux-xanmod-version linux-xanmod-revision linux-xanmod-source broadcom-bt-firmware broadcom-sta facetimehd))
  #:use-module ((nongnu system linux-initrd) #:select (microcode-initrd))
  #:use-module (phrenetic system)
  #:use-module (phrenetic utils)
  #:use-module (nonphrenetic io-devices)
  #:use-module ((srfi srfi-1) #:select (any))
  #:export (%nonguix-authorized-keys
            %nonguix-substitute-urls
            linux-kernel
            apple-macbook
            with-macbook-hardware))

(define make-linux-xanmod (@@ (nongnu packages linux) make-linux-xanmod))
#+end_src
*** Components
**** Package management
***** Guix
****** Nonguix substitutes
#+begin_src scheme
(define nonguix-public-key
  '((#:public-key/type . #:public-key.type/ecc)
    (#:public-key.ecc/curve . "Ed25519")
    (#:public-key.ecc/q . "C1FD53E5D4CE971933EC50C9F307AE2171A2D3B52C804642A7A35F84F3A4EA98")))

(define %nonguix-authorized-keys
  (list (plain-file "substitutes.nonguix.org.pub"
                    (public-key-serialize nonguix-public-key))))

(define %nonguix-substitute-urls
  (list "https://substitutes.nonguix.org"))
#+end_src
**** Hardware-specific
***** Linux
#+begin_src scheme
(define-system-comp (linux-kernel #:key
                                  system
                                  xanmod?
                                  xanmod-config-version
                                  linux-customization-params)
  (kernel (linux-with-customizations (get-linux #:system system
                                                #:xanmod? xanmod?
                                                #:xanmod-config-version xanmod-config-version)
                                     linux-customization-params))
  (initrd (if (member system '("x86_64-linux" "i686-linux"))
              (lambda* (file-systems #:rest rest)
                (apply microcode-initrd file-systems
                       #:initrd (operating-system-initrd os)
                       rest))
              (operating-system-initrd os)))
  (firmware (append
             (operating-system-firmware os)
             (list linux-firmware))))

(define* (get-linux #:key
                    system
                    xanmod?
                    xanmod-config-version)
  (or (assoc-ref `(;; ("aarch64-linux" . linux-arm64-generic)
                   ;; ...
                   )
                 system)
      (if xanmod?
          (make-linux-xanmod linux-xanmod-version
                             linux-xanmod-revision
                             linux-xanmod-source
                             #:xanmod-defconfig
                             (string-append "config_x86-64-v"
                                            xanmod-config-version))
          linux)))
#+end_src
***** Vendor-specific
****** Apple
#+begin_src scheme
(define* (apple-macbook os #:key bluetooth?)
  (-> os
      (apple-broadcom-wireless #:bluetooth? bluetooth?)
      apple-facetime-camera))
#+end_src
******* Wireless
#+begin_src scheme
(define-system-comp (apple-broadcom-wireless #:key bluetooth?)
  (kernel-loadable-modules (cons* broadcom-sta
                                  (operating-system-kernel-loadable-modules os)))
  (kernel-arguments (add-or-update-kernel-argument
                     (operating-system-user-kernel-arguments os)
                     "modprobe.blacklist"
                     '("b43" "b43legacy" "ssb" "bcm43xx" "brcm80211" "brcmfmac" "brcmsmac" "bcma")))
  (firmware (append
             (operating-system-firmware os)
             (if bluetooth?
                 (list broadcom-bt-firmware) '()))))
#+end_src
******* Camera
#+begin_src scheme
(define-system-comp (apple-facetime-camera)
  (kernel-loadable-modules (cons* facetimehd
                                  (operating-system-kernel-loadable-modules os)))
  (kernel-arguments (add-or-update-kernel-argument
                     (operating-system-user-kernel-arguments os)
                     "modprobe.blacklist"
                     '("bdc_pci")))
  (firmware (cons* facetimehd-firmware
                   facetimehd-calibration
                   (operating-system-firmware os)))
  (services
   (cons* (simple-service 'facetimehd
                          kernel-module-loader-service-type
                          '("facetimehd"))
          (operating-system-user-services os))))
#+end_src
******* Shared
#+begin_src scheme
(define (add-or-update-kernel-argument kargs param-name vs)
  (let ((param? (lambda (p)
                  (and (string? p)
                       (string-prefix? param-name p))))
        (vs* (string-join vs ",")))
    (if (any param? kargs)
        (map (lambda (p)
               (if (param? p)
                   (string-append p "," vs*)
                   p))
             kargs)
        (cons (string-append param-name "=" vs*)
              kargs))))
#+end_src
****** Nvidia
******* Graphics cards
Only for Tesla-Kepler chipsets, see [[https://nouveau.freedesktop.org/FeatureMatrix.html][FeatureMatrix · freedesktop.org]].
#+begin_src scheme
(define-system-comp (nvidia-graphics)
  (firmware (cons* nouveau-firmware
                   (operating-system-firmware os))))
#+end_src

*** Composite components
**** Macbook hardware
#+begin_src scheme
(define* (with-macbook-hardware os
                                #:key
                                efi-label
                                xanmod?
                                (xanmod-config-version "3")
                                virtualization-kvm-users
                                virtualization-binfmt-platforms
                                (console-input %macbook-keyboard)
                                (console-output %macbook-display)
                                number-of-ttys
                                bluetooth?
                                stateless?)
  (as-> os $
    (grub-efi-boot $ #:label efi-label
                   #:stateless? stateless?)
    (linux-kernel $ #:system "x86_64-linux"
                    #:xanmod? xanmod?
                    #:xanmod-config-version xanmod-config-version)
    (virtualization $ #:kvm-support? #t
                    #:kvm-users virtualization-kvm-users
                    #:native-platform "x86_64"
                    #:binfmt-platforms virtualization-binfmt-platforms)
    (console-keyboard-layouts $ #:kb-layout (assoc-ref console-input #:keyboard/layout))
    (console-fonts $ #:number-of-ttys number-of-ttys
                   #:hidpi? (assoc-ref console-output #:display/hidpi?))
    (apple-macbook $ #:bluetooth? bluetooth?)
    (nvidia-graphics $)))
#+end_src
** Home
:PROPERTIES:
:header-args+: :tangle (meta-in-dir "home.scm")
:END:
#+begin_src scheme
(define-module (nonphrenetic home)
  #:use-module (gnu home services)
  #:use-module ((gnu packages browser-extensions) #:select (ublock-origin/chromium))
  #:use-module (gnu services)
  #:use-module ((nongnu packages chrome) #:select ((make-google-chrome-stable . make-google-chrome)))
  #:use-module ((nongnu packages databases) #:select (datomic-cli-tools))
  #:use-module ((nongnu packages fonts) #:select (font-apple-sf-pro font-apple-sf-compact font-apple-sf-mono font-apple-sf-arabic font-apple-new-york font-apple-color-emoji font-apple-symbols))
  #:use-module ((nongnu packages messaging) #:select (zoom))
  #:use-module ((nongnu packages mozilla) #:select (firefox))
  ;; #:use-module ((chromium chromium) #:select (chromium chromium+drm))
  #:use-module (phrenetic home)
  #:use-module (phrenetic utils)
  #:export (%nixpkgs-allow-unfree
            %fonts
            datomic-prog
            zoom-app
            ;; chromium-app
            google-chrome-app
            firefox-app))
#+end_src
*** Components
**** Package management
***** Nix
#+begin_src scheme
(define %nixpkgs-allow-unfree
  '((allowUnfree . #t)))
#+end_src
**** Desktop
***** Font library
#+begin_src scheme
;; TODO These should really each be a function to parameterize the packages.
(define %fonts
  `((#:fonts/apple-sf-pro . ((#:font/name . "SF Pro")
                             (#:font/package . ,font-apple-sf-pro)))
    (#:fonts/apple-sf-compact . ((#:font/name . "SF Compact")
                                 (#:font/package . ,font-apple-sf-compact)))
    (#:fonts/apple-sf-mono . ((#:font/name . "SF Mono")
                              (#:font/package . ,font-apple-sf-mono)))
    (#:fonts/apple-sf-arabic . ((#:font/name . "SF Arabic")
                                (#:font/package . ,font-apple-sf-arabic)))
    (#:fonts/apple-new-york . ((#:font/name . "New York")
                               (#:font/package . ,font-apple-new-york)))
    (#:fonts/apple-color-emoji . ((#:font/name . "Apple Color Emoji")
                                  (#:font/package . ,font-apple-color-emoji)))
    (#:fonts/apple-symbols . ((#:font/name . "Apple Symbols")
                              (#:font/package . ,font-apple-symbols)))))
#+end_src
**** Programs
***** Development
****** Datomic
#+begin_src scheme
(define (datomic-prog)
  (list
   (simple-service
    'datomic-add-packages
    home-profile-service-type
    (list datomic-cli-tools))))
#+end_src
**** Apps
***** Messaging
****** Zoom
Doesn't work for me at the moment. As of this writing the package is brand new so wait a while and see if there any developments/updates/fixes (though I suspect the issue(s) lie with me, I was getting errors, possibly similar ones, when I tried to install Zoom through Nix).
#+begin_src scheme
(define* (zoom-app #:key
                   stateless?
                   qt-services)
  (append
   (list
    (simple-service
     'zoom-add-packages
     home-profile-service-type
     (list zoom))

    ;; (when stateless?
    ;;   (home-stateless-service
    ;;    'zoom
    ;;    #:state '(((#:path . ("zoom/" #:xdg-base "XDG_CONFIG_HOME"))
    ;;               (#:storage . #:storage/machine))
    ;;              ((#:path . ("zoom/" #:xdg-base "XDG_DATA_HOME"))
    ;;               (#:storage . #:storage/machine)))))
    )

   (or qt-services '())))
#+end_src
***** Web browsers
****** Chromium
******* Chromium
#+begin_src scheme
;; (define* (chromium-app #:key
;;                        stateless?
;;                        toolkits
;;                        wayland?
;;                        pipewire?
;;                        theme
;;                        gtk-services
;;                        qt-services
;;                        drm?
;;                        (chromium chromium)
;;                        (chromium+drm chromium+drm))
;;   (append
;;    (list
;;     (simple-service
;;      'chromium-add-packages
;;      home-profile-service-type
;;      ;; Chromium inherits from ungoogled-chromium and at the time of writing, ungoogled-chromium doesn't offer GTK 4 or QT 6 so just ignore the toolkits option.
;;      (list (chromium-wrapper (if drm?
;;                                  chromium+drm
;;                                  chromium)
;;                              wayland? pipewire? theme)
;;            ublock-origin/chromium))

;;     (when stateless?
;;       (home-stateless-service
;;        'chromium
;;        #:state '(((#:path . ("chromium/" #:xdg-base "XDG_CACHE_HOME"))
;;                   (#:storage . #:storage/machine)
;;                   (#:mode . #o700))
;;                  ((#:path . ("chromium/" #:xdg-base "XDG_CONFIG_HOME"))
;;                   (#:storage . #:storage/machine)
;;                   (#:mode . #o700))
;;                  ((#:path . ".pki/nssdb/")
;;                   (#:storage . #:storage/machine)
;;                   (#:mode . #o700)
;;                   (#:parent-dir-perms . ((#:mode . #o700))))))))

;;    (or gtk-services '())
;;    (or qt-services '())))
#+end_src
******* Google Chrome
#+begin_src scheme
(define* (google-chrome-app #:key
                            stateless?
                            toolkits
                            wayland?
                            pipewire?
                            theme
                            gtk-services
                            qt-services
                            (make-google-chrome make-google-chrome)
                            (release-channel #:chrome.channel/stable))
  (append
   (list
    (simple-service
     'google-chrome-add-packages
     home-profile-service-type
     (list (chromium-wrapper (make-google-chrome
                              #:toolkits (map (lambda (toolkit)
                                                (case toolkit
                                                  ((#:chromium.toolkit/gtk3) 'gtk3)
                                                  ((#:chromium.toolkit/gtk4) 'gtk4)
                                                  ((#:chromium.toolkit/qt5) 'qt5)
                                                  ((#:chromium.toolkit/qt6) 'qt6)))
                                              toolkits))
                             wayland? pipewire? theme
                             #:gtk4? (member #:chromium.toolkit/gtk4 toolkits))))

    (when stateless?
      (let ((chrome-state-prefix (case release-channel
                                   ((#:chrome.channel/stable) "google-chrome")
                                   ((#:chrome.channel/beta) "google-chrome-beta")
                                   ((#:chrome.channel/unstable) "google-chrome-unstable"))))
        (home-stateless-service
         'google-chrome
         #:state `(((#:path . (,(string-append chrome-state-prefix "/") #:xdg-base "XDG_CACHE_HOME"))
                    (#:storage . #:storage/machine)
                    (#:mode . #o700))
                   ((#:path . (,(string-append chrome-state-prefix "/") #:xdg-base "XDG_CONFIG_HOME"))
                    (#:storage . #:storage/machine)
                    (#:mode . #o700))
                   ((#:path . ".pki/nssdb/")
                    (#:storage . #:storage/machine)
                    (#:mode . #o700)
                    (#:parent-dir-perms . ((#:mode . #o700)))))
         ;; It's weird that Chrome creates this, it's not even in one of the recognized locations (https://wiki.archlinux.org/title/XDG_MIME_Applications#mimeapps.list). Also the only time I've seen it not be empty is once when Gmail promted me to let it open emails and I hit accept. Whatever, lets just ignore it.
         #:ignore '(((#:path . ("mimeapps.list" #:xdg-base "XDG_DATA_HOME"))
                     (#:preds . ((#:empty-file)))))))))

   (or gtk-services '())
   (or qt-services '())))
#+end_src
****** Mozilla
******* Firefox
#+begin_src scheme
(define* (firefox-app #:key
                      stateless?
                      gtk-services)
  (append
   (list
    (simple-service
     'firefox-add-packages
     home-profile-service-type
     (list firefox))

    (when stateless?
      (home-stateless-service
       'firefox
       #:state '(((#:path . ("mozilla/firefox/" #:xdg-base "XDG_CACHE_HOME"))
                  (#:storage . #:storage/machine)
                  (#:mode . #o700)
                  (#:parent-dir-perms . ((#:mode . #o700))))
                 ((#:path . ".mozilla/firefox")
                  (#:storage . #:storage/machine)
                  (#:mode . #o700)
                  (#:parent-dir-perms . ((#:mode . #o700))))
                 ((#:path . ".mozilla/extensions")
                  (#:storage . #:storage/machine)
                  (#:mode . #o700)
                  (#:parent-dir-perms . ((#:mode . #o700))))))))

   (or gtk-services '())))
#+end_src
** Common
*** Input/output devices
:PROPERTIES:
:header-args+: :tangle (meta-in-dir "io-devices.scm")
:END:
- TODO Is this what the ~hwdata~ package is for? Can/should I use it to augment/replace this? Probably wait on this, until I do hyprland or later.
#+begin_src scheme
(define-module (nonphrenetic io-devices)
  #:use-module (gnu system keyboard)
  #:export (%macbook-keyboard
            %macbook-display))
#+end_src
**** Apple
#+begin_src scheme
(define %macbook-keyboard
  `((#:keyboard/name . "Apple Inc. Apple Internal Keyboard / Trackpad")
    (#:keyboard/vendor-id . 1452)
    (#:keyboard/product-id . 610)
    (#:keyboard/layout . ,(keyboard-layout "us" #:model "macbook78"))))

(define %macbook-display
  '((#:display/make . "Apple Computer Inc")
    (#:display/model . "Color LCD")
    (#:display/hidpi? . #t)))
#+end_src

* Configurations
:PROPERTIES:
:meta-dir+: configs
:END:
#+begin_src scheme :tangle (meta-in-dir "core.scm")
(define-module (configs core)
  #:use-module ((phrenetic home) #:select (create-he he-entire))
  #:use-module ((phrenetic install) #:select (installer-package))
  #:use-module ((phrenetic system) #:select (blank-os btrfs disk-encryption host-info os-base stateless swap tmpfs zswap))
  #:use-module (phrenetic utils)
  #:use-module ((nonphrenetic io-devices) #:select (%macbook-display %macbook-keyboard))
  #:use-module ((nonphrenetic home) #:select (%nixpkgs-allow-unfree))
  #:use-module ((nonphrenetic system) #:select (%nonguix-authorized-keys %nonguix-substitute-urls with-macbook-hardware))
  #:use-module ((ice-9 match) #:select (match-lambda))
  #:use-module ((srfi srfi-1) #:select (delete-duplicates))
  #:export (system
            installer
            primary-he
            aux-he
            guest-he))

(define (system)
  (let ((primary-name "pharcosyle")
        (aux-name "pcoulson")
        (guest-name "mellon")
        (number-of-ttys 6)
        (bluetooth? #t)
        (stateless? #t))
    (as-> blank-os $
      (base-os $ #:who `(((#:name . ,primary-name)
                          (#:comment . "Krzysztof Baranowski")
                          (#:shell . ,primary-he-shell)
                          (#:admin? . #t))
                         ((#:name . ,aux-name)
                          (#:comment . "Phil Coulson")
                          (#:shell . ,aux-he-shell)
                          (#:admin? . #t))
                         ((#:name . ,guest-name)
                          (#:comment . "Mellon")
                          (#:shell . ,guest-he-shell)))
               #:login-number-of-ttys number-of-ttys
               #:guix-authorized-keys %nonguix-authorized-keys
               #:guix-substitute-urls %nonguix-substitute-urls
               #:kmonad? #t
               #:kmonad-users (feature-users `((,primary-name . ,primary-he-kmonad?)
                                               (,aux-name . ,aux-he-kmonad?)
                                               (,guest-name . ,guest-he-kmonad?)))
               #:avahi-users (list primary-name
                                   aux-name
                                   guest-name)
               #:pipewire-users (list primary-name
                                      aux-name
                                      guest-name)
               #:wireless-users (list primary-name
                                      aux-name
                                      guest-name)
               #:bluetooth? bluetooth?
               #:seat-users (list primary-name
                                  aux-name
                                  guest-name)
               #:auto-login? disk-encryption?
               #:auto-login-user primary-name
               #:sessions (->> (list primary-he-sessions
                                     aux-he-sessions
                                     guest-he-sessions)
                               (apply append)
                               delete-duplicates)
               #:hyprland-users (session-users #:session/hyprland
                                               `((,primary-name . ,primary-he-sessions)
                                                 (,aux-name . ,aux-he-sessions)
                                                 (,guest-name . ,guest-he-sessions)))
               #:sway-users (session-users #:session/sway
                                           `((,primary-name . ,primary-he-sessions)
                                             (,aux-name . ,aux-he-sessions)
                                             (,guest-name . ,guest-he-sessions)))
               #:stateless? stateless?)
      (host-info $ #:host-name "frostfire"
                 #:timezone "America/Los_Angeles")
      (tmpfs $ #:mount-point "/"
             ;; TODO trying without at the moment
             ;; #:size (let ((virtual-memory (+ physical-memory swap-size)))
             ;;          (/ virtual-memory 2))
             )
      (case filesystem
        ;; ((#:filesystem/ext4)
        ;;  (ext4 $ #:label root-label
        ;;           #:mount-point "/"))
        ((#:filesystem/btrfs)
         (btrfs $ #:label root-label
                #:mounts (map (match-lambda
                                ((subvol . mount-point)
                                 `((#:mount-point . ,mount-point)
                                   (#:subvol . ,subvol))))
                              mountables))))
      (if disk-encryption?
          (disk-encryption $ #:device-uuid luks-uuid
                           #:mount-points (case filesystem
                                            ;; ((#:filesystem/ext4)
                                            ;;  ...)
                                            ((#:filesystem/btrfs)
                                             (map (match-lambda ((_ . mount-point) mount-point))
                                                  mountables))))
          $)
      (swap $ #:file? #t
            #:file-size swap-size
            #:file-no-cow? (equal? filesystem #:filesystem/btrfs)
            #:stateless? stateless?)
      ;; (zswap $)
      (if stateless?
          (stateless $ #:storage-paths %stateless-storage-paths
                     #:hes `((,primary-name . ,(primary-he))
                             (,aux-name . ,(aux-he))
                             (,guest-name . ,(guest-he)))
                     #:state-users (list primary-name)
                     #:password-users (list primary-name
                                            aux-name
                                            guest-name))
          $)
      (with-macbook-hardware $ #:efi-label efi-label
                             ;; #:xanmod? #t
                             #:virtualization-kvm-users (feature-users `((,primary-name . ,primary-he-virtualization?)
                                                                         (,aux-name . ,aux-he-virtualization?)
                                                                         (,guest-name . ,guest-he-virtualization?)))
                             ;; #:virtualization-binfmt-platforms '("aarch64")
                             #:number-of-ttys number-of-ttys
                             #:bluetooth? bluetooth?
                             #:stateless? stateless?))))

(define physical-memory (* 16 GiB))
;; TODO trying without at the moment
;; (define swap-size (* 32 GiB))
(define swap-size (* 16 GiB)) ; Made this large to accommodate big Guix builds in /tmp, namely the linux kernel.

(define (feature-users flags)
  (->> flags
       (filter (match-lambda ((_ . enable?) enable?)))
       (map (match-lambda ((user . _) user)))))

(define (session-users session user-sessions)
  (->> user-sessions
       (filter (match-lambda
                 ((_ . sessions)
                  (member session sessions))))
       (map (match-lambda ((user . _) user)))))



(define* (base-os os #:rest opts)
  (apply os-base
         os
         (append opts
                 (os+he-shared-opts))))



(define default-shell #:shell/bash)


(define (primary-he)
  (let ((stateless? #t))
    (create-he
     (apply
      he-entire
      ;; TODO
      #:stateless-storage-paths '((#:storage/machine . "/.machine")
                                  (#:storage/persist . "/.persist"))
      #:login-shell primary-he-shell
      #:email "pharcosyle@gmail.com"
      #:kmonad? primary-he-kmonad?
      #:sessions primary-he-sessions
      #:virtualization? primary-he-virtualization?
      #:projects `(("phrenetic" . ((#:doom? . ,doom?)))
                   ("Krush/hyperdrive" . ((#:stateless? . ,stateless?)
                                          (#:doom? . ,doom?)
                                          (#:doom-org? . ,(assoc-ref doom-flags #:doom/org?))
                                          (#:doom-tree-sitter? . ,(assoc-ref doom-flags #:doom/tree-sitter?)))))
      (he-shared-opts)))))

(define primary-he-shell default-shell)
(define primary-he-kmonad? #t)
(define primary-he-sessions '(#:session/hyprland
                              #:session/sway))
(define primary-he-virtualization? #t)


(define (aux-he)
  (create-he
   (apply
    he-entire
    ;; TODO
    #:stateless-storage-paths '((#:storage/machine . "/home/pcoulson/.machine")
                                (#:storage/persist . "/home/pcoulson/.persist"))
    #:login-shell aux-he-shell
    #:email "pharcosyle@gmail.com"
    #:kmonad? aux-he-kmonad?
    #:sessions aux-he-sessions
    #:virtualization? aux-he-virtualization?
    (he-shared-opts))))

(define aux-he-shell default-shell)
(define aux-he-kmonad? #f)
(define aux-he-sessions primary-he-sessions)
(define aux-he-sessions '(;; #:session/gnome
                          #:session/hyprland
                          #:session/sway))
(define aux-he-virtualization? primary-he-virtualization?)


(define (guest-he)
  (create-he
   (apply
    he-entire
    ;; TODO
    #:stateless-storage-paths '((#:storage/machine . "/home/mellon/.machine")
                                (#:storage/persist . "/home/mellon/.persist"))
    #:login-shell guest-he-shell
    #:kmonad? guest-he-kmonad?
    #:sessions guest-he-sessions
    #:virtualization? guest-he-virtualization?
    (he-shared-opts))))

(define guest-he-shell default-shell)
(define guest-he-kmonad? #f)
(define guest-he-sessions '(;; #:session/gnome
                            #:session/hyprland
                            #:session/sway))
(define guest-he-virtualization? #f)



;; HE shared opts
(define doom? #t)
(define doom-flags '((#:doom/calendar? . #t)
                     (#:doom/org? . #t)
                     (#:doom/evil? . #t)
                     (#:doom/tree-sitter? . #t)))

(define (he-shared-opts)
  (append
   (os+he-shared-opts)
   `(#:stateless? #t
     #:nix-nixpkgs-config-settings ,%nixpkgs-allow-unfree
     #:doom? ,doom?
     #:doom-flags ,(acons #:doom/icons? #t doom-flags)
     #:doom-ui? #t
     #:bluetooth? #t
     #:sessions-inputs ,(list %macbook-keyboard)
     #:sessions-outputs ,(list %macbook-display)

     ;; NEW package parameterization
     #:emacs-pgtk ,(@ (gnu packages emacs) emacs-pgtk)
     #:sessions-swayidle ,(@ (gnu packages wm) swayidle)
     #:apps-make-google-chrome ,(@ (nongnu packages chrome) make-google-chrome-stable))))



;; OS+HE shared opts
(define (os+he-shared-opts)
  `(#:package-managers (#:pm/guix #:pm/nix)
    #:console? #t
    #:desktop? #t
    #:media #:media/pipewire
    ;; #:login-manager #:lm/gdm

    ;; NEW package parameterization
    #:kmonad ,(@ (gnu packages haskell-apps) kmonad)
    #:media-pipewire ,(@ (gnu packages linux) pipewire)
    #:sessions-swaylock-effects? #t
    #:sessions-swaylock ,(@ (gnu packages wm) swaylock)
    #:sessions-swaylock-effects ,(@ (gnu packages wm) swaylock-effects)))



(define (installer)
  #f
  ;; (installer-package
  ;;  #:os-name "frostfire"
  ;;  #:boot-target boot-target
  ;;  #:efi-label efi-label
  ;;  #:root-label root-label
  ;;  #:disk-encryption? disk-encryption?
  ;;  #:luks-uuid luks-uuid
  ;;  #:filesystem filesystem
  ;;  #:mountables mountables
  ;;  #:btrfs-mount-flags btrfs-mount-flags
  ;;  #:btrfs-mount-options btrfs-mount-options)
  )





;; TODO temporarily putting these two here as I removed them from system component
(define %stateless-storage-paths
  '((#:storage/machine . "/.machine")
    (#:storage/persist . "/.persist")))

(define %stateless-mountables
  (append
   `(("boot" . "/boot")
     ("guix-store" . "/gnu/store")
     ("guix-var" . "/var/guix"))
   (map (match-lambda
          ((storage . dir)
           (cons (case storage
                   ((#:storage/machine) "machine")
                   ((#:storage/persist) "persist"))
                 dir)))
        %stateless-storage-paths)))





;; System+installer shared opts

(define efi-label "genesis")
(define filesystem #:filesystem/btrfs)
(define root-label "firmament")
(define mountables %stateless-mountables) ; TODO nb: had this in `(if stateless? ...)' before.
(define disk-encryption? #t)
(define luks-uuid "bdda56af-6ca0-4953-bc13-d5af8715e0e5")



(define system (system))
(define installer (installer))
(define primary-he (primary-he))
(define aux-he (aux-he))
(define guest-he (guest-he))
#+end_src
** Machines
:PROPERTIES:
:meta-dir+: machines
:END:
*** Frostfire
#+begin_src scheme :tangle (meta-in-dir "frostfire.scm")
(define-module (configs machines frostfire)
  #:use-module (configs core)
  #:re-export (system
               installer
               primary-he
               aux-he
               guest-he))
#+end_src
- [2024-04-27 Sat] TODO: consider [[https://git.savannah.gnu.org/cgit/guix.git/commit/?id=be14d41d9be3ef91d11ab24780855682c432cac9][new ~guix-for-channels~ procedure]]
**** Channels
#+begin_src scheme :tangle (meta-in-dir "frostfire-channels")
;; TODO Do local channels better.
(cons* (channel
        (name 'rde)
        ;; (url "https://git.sr.ht/~abcdw/rde")
        (url "file:///.persist/home/pharcosyle/work_for_now/channels/rde")
        (introduction
         (make-channel-introduction
          "257cebd587b66e4d865b3537a9a88cccd7107c95"
          (openpgp-fingerprint
           "2841 9AC6 5038 7440 C7E9  2FFA 2208 D209 58C1 DEB0"))))
       (channel
        (name 'nonguix)
        ;; (url "https://gitlab.com/nonguix/nonguix")
        (url "file:///.persist/home/pharcosyle/work_for_now/channels/nonguix")
        (introduction
         (make-channel-introduction
          "897c1a470da759236cc11798f4e0a5f7d4d59fbc"
          (openpgp-fingerprint
           "2A39 3FFF 68F4 EF7A 3D29  12AF 6F51 20A0 22FB B2D5"))))

       ;; %default-channels
       (list
        (channel
         (name 'guix)
         (url "file:///.persist/home/pharcosyle/work_for_now/channels/guix")
         (introduction
          (make-channel-introduction
           "9edb3f66fd807b096b48283debdcddccfea34bad"
           (openpgp-fingerprint
            "BBB0 2DDF 2CEA F6A8 0D1D  E643 A2A0 6DF2 A33A 54FA"))))))
#+end_src
***** COMMENT From project channel
#+begin_src scheme :tangle (meta-in-dir "frostfire-channels")
(cons* (channel
        (name 'phrenetic)
        (url "https://github.com/pharcosyle/phrenetic")
        (branch "tangled"))
       %default-channels)
#+end_src
***** COMMENT From project channel (local)
#+begin_src scheme :tangle (meta-in-dir "frostfire-channels")
(cons* (channel
        (name 'phrenetic)
        (url "file:///home/pharcosyle/work/phrenetic")
        (branch "tangled"))
       %default-channels)
#+end_src
**** Channels lock :version:
#+begin_src scheme :tangle (meta-in-dir "frostfire-channels-lock")
(list (channel
       (name 'guix)
       (url "https://git.savannah.gnu.org/git/guix.git")
       (branch "master")
       (commit
        "1ee2d117d8fa9e2e0d4ec46cc5555497bb5e6337")
       (introduction
        (make-channel-introduction
         "9edb3f66fd807b096b48283debdcddccfea34bad"
         (openpgp-fingerprint
          "BBB0 2DDF 2CEA F6A8 0D1D  E643 A2A0 6DF2 A33A 54FA"))))
      (channel
       (name 'rde)
       (url "https://git.sr.ht/~abcdw/rde")
       (branch "master")
       (commit
        "77bf57ba4f977af437fbaabff5e14bc09fb2eccd")
       (introduction
        (make-channel-introduction
         "257cebd587b66e4d865b3537a9a88cccd7107c95"
         (openpgp-fingerprint
          "2841 9AC6 5038 7440 C7E9  2FFA 2208 D209 58C1 DEB0"))))
      (channel
       (name 'nonguix)
       (url "https://gitlab.com/nonguix/nonguix")
       (branch "master")
       (commit
        "5a76529aff40107fbc03f293a0a332c839059815")
       (introduction
        (make-channel-introduction
         "897c1a470da759236cc11798f4e0a5f7d4d59fbc"
         (openpgp-fingerprint
          "2A39 3FFF 68F4 EF7A 3D29  12AF 6F51 20A0 22FB B2D5")))))
#+end_src
* Guix channel
#+begin_src scheme :tangle (meta-in-dir ".guix-channel")
(channel
 (version 0)
 (dependencies
  (channel
   (name rde)
   (url "https://git.sr.ht/~abcdw/rde")
   (introduction
    (make-channel-introduction
     "257cebd587b66e4d865b3537a9a88cccd7107c95"
     (openpgp-fingerprint
      "2841 9AC6 5038 7440 C7E9  2FFA 2208 D209 58C1 DEB0"))))
  (channel
   (name nonguix)
   (url "https://gitlab.com/nonguix/nonguix")
   (introduction
    (make-channel-introduction
     "897c1a470da759236cc11798f4e0a5f7d4d59fbc"
     (openpgp-fingerprint
      "2A39 3FFF 68F4 EF7A 3D29  12AF 6F51 20A0 22FB B2D5"))))))
#+end_src
* Github
** Readme
#+begin_src org :tangle (meta-in-dir "README.org")
,* Phrenetic
Configuration components and useful packages/services for [[https://guix.gnu.org/][GNU Guix]].

It's decent.
,* [[file:phrenetic.org][Browse the full source]]
,* Usage
Install as a [[https://guix.gnu.org/manual/devel/en/guix.html#Channels][Guix channel]] with the following declaration:
,#+begin_src scheme
(channel
 (name 'phrenetic)
 (url "https://github.com/pharcosyle/phrenetic")
 (branch "tangled"))
,#+end_src
,* Noteworthy features
Some stuff I haven't seen elsewhere folks might be interested in:
- Stateless service :: Configure your Guix to run with an ephemeral, in-memory root directory. Kind of like [[https://grahamc.com/blog/erase-your-darlings][Erase your darlings: immutable infrastructure for mutable systems]] but using Guix/Btrfs instead of NixOS/ZFS.
- Doom package and module :: [[https://github.com/doomemacs/doomemacs][Doom Emacs]] packaged for Guix and with patches to better organize Emacs state, a service to set up symlinks, etc.
- Guix integration for [[https://github.com/radian-software/straight.el][Straight.el]] :: Your Straight or Doom-based Emacs configuration can use Guix Emacs packages under hood (but with the revisions you, or Doom, specify). Get the best of both worlds! Still WIP.
- Miscellaneous packages :: Guix packages for stuff not upstream yet: Datomic CLI tools, the AWS CLI v2, etc.
,* A word about literate programming
I use Emacs' =org-mode= to structure my code as a single file that I can export ("tangle") into numerous source files. This allows me to annotate and organize related code in potentially different languages with different output paths together in a way that easy for humans to read and reason about. This does necessitate maintaining a separate =tangled= branch (set as the Github default) so others can use it easily, though.
,* Contributing
Pull requests welcome! Targeting =master= is ideal but if you aren't familiar with literate programming / Emacs / =org=mode= then making your changes on the =tangled= branch is also fine (I'll reverse-tangle it for you).
,* Acknowledgements
This project incorporates code from Andrew Tropin's excellent [[https://github.com/abcdw/rde][RDE]], many thanks to him.
#+end_src
** License
:PROPERTIES:
:VISIBILITY: folded
:END:
#+begin_src fundamental :tangle (meta-in-dir "LICENSE")
                    GNU GENERAL PUBLIC LICENSE
                       Version 3, 29 June 2007

 Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

                            Preamble

  The GNU General Public License is a free, copyleft license for
software and other kinds of works.

  The licenses for most software and other practical works are designed
to take away your freedom to share and change the works.  By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users.  We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors.  You can apply it to
your programs, too.

  When we speak of free software, we are referring to freedom, not
price.  Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.

  To protect your rights, we need to prevent others from denying you
these rights or asking you to surrender the rights.  Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.

  For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received.  You must make sure that they, too, receive
or can get the source code.  And you must show them these terms so they
know their rights.

  Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.

  For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software.  For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.

  Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so.  This is fundamentally incompatible with the aim of
protecting users' freedom to change the software.  The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable.  Therefore, we
have designed this version of the GPL to prohibit the practice for those
products.  If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.

  Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary.  To prevent this, the GPL assures that
patents cannot be used to render the program non-free.

  The precise terms and conditions for copying, distribution and
modification follow.

                       TERMS AND CONDITIONS

  0. Definitions.

  "This License" refers to version 3 of the GNU General Public License.

  "Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.

  "The Program" refers to any copyrightable work licensed under this
License.  Each licensee is addressed as "you".  "Licensees" and
"recipients" may be individuals or organizations.

  To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy.  The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.

  A "covered work" means either the unmodified Program or a work based
on the Program.

  To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy.  Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.

  To "convey" a work means any kind of propagation that enables other
parties to make or receive copies.  Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.

  An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License.  If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.

  1. Source Code.

  The "source code" for a work means the preferred form of the work
for making modifications to it.  "Object code" means any non-source
form of a work.

  A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.

  The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form.  A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.

  The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities.  However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work.  For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.

  The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.

  The Corresponding Source for a work in source code form is that
same work.

  2. Basic Permissions.

  All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met.  This License explicitly affirms your unlimited
permission to run the unmodified Program.  The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work.  This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.

  You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force.  You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright.  Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.

  Conveying under any other circumstances is permitted solely under
the conditions stated below.  Sublicensing is not allowed; section 10
makes it unnecessary.

  3. Protecting Users' Legal Rights From Anti-Circumvention Law.

  No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.

  When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.

  4. Conveying Verbatim Copies.

  You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.

  You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.

  5. Conveying Modified Source Versions.

  You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:

    a) The work must carry prominent notices stating that you modified
    it, and giving a relevant date.

    b) The work must carry prominent notices stating that it is
    released under this License and any conditions added under section
    7.  This requirement modifies the requirement in section 4 to
    "keep intact all notices".

    c) You must license the entire work, as a whole, under this
    License to anyone who comes into possession of a copy.  This
    License will therefore apply, along with any applicable section 7
    additional terms, to the whole of the work, and all its parts,
    regardless of how they are packaged.  This License gives no
    permission to license the work in any other way, but it does not
    invalidate such permission if you have separately received it.

    d) If the work has interactive user interfaces, each must display
    Appropriate Legal Notices; however, if the Program has interactive
    interfaces that do not display Appropriate Legal Notices, your
    work need not make them do so.

  A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit.  Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.

  6. Conveying Non-Source Forms.

  You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:

    a) Convey the object code in, or embodied in, a physical product
    (including a physical distribution medium), accompanied by the
    Corresponding Source fixed on a durable physical medium
    customarily used for software interchange.

    b) Convey the object code in, or embodied in, a physical product
    (including a physical distribution medium), accompanied by a
    written offer, valid for at least three years and valid for as
    long as you offer spare parts or customer support for that product
    model, to give anyone who possesses the object code either (1) a
    copy of the Corresponding Source for all the software in the
    product that is covered by this License, on a durable physical
    medium customarily used for software interchange, for a price no
    more than your reasonable cost of physically performing this
    conveying of source, or (2) access to copy the
    Corresponding Source from a network server at no charge.

    c) Convey individual copies of the object code with a copy of the
    written offer to provide the Corresponding Source.  This
    alternative is allowed only occasionally and noncommercially, and
    only if you received the object code with such an offer, in accord
    with subsection 6b.

    d) Convey the object code by offering access from a designated
    place (gratis or for a charge), and offer equivalent access to the
    Corresponding Source in the same way through the same place at no
    further charge.  You need not require recipients to copy the
    Corresponding Source along with the object code.  If the place to
    copy the object code is a network server, the Corresponding Source
    may be on a different server (operated by you or a third party)
    that supports equivalent copying facilities, provided you maintain
    clear directions next to the object code saying where to find the
    Corresponding Source.  Regardless of what server hosts the
    Corresponding Source, you remain obligated to ensure that it is
    available for as long as needed to satisfy these requirements.

    e) Convey the object code using peer-to-peer transmission, provided
    you inform other peers where the object code and Corresponding
    Source of the work are being offered to the general public at no
    charge under subsection 6d.

  A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.

  A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling.  In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage.  For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product.  A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.

  "Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source.  The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.

  If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information.  But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).

  The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed.  Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.

  Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.

  7. Additional Terms.

  "Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law.  If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.

  When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it.  (Additional permissions may be written to require their own
removal in certain cases when you modify the work.)  You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.

  Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:

    a) Disclaiming warranty or limiting liability differently from the
    terms of sections 15 and 16 of this License; or

    b) Requiring preservation of specified reasonable legal notices or
    author attributions in that material or in the Appropriate Legal
    Notices displayed by works containing it; or

    c) Prohibiting misrepresentation of the origin of that material, or
    requiring that modified versions of such material be marked in
    reasonable ways as different from the original version; or

    d) Limiting the use for publicity purposes of names of licensors or
    authors of the material; or

    e) Declining to grant rights under trademark law for use of some
    trade names, trademarks, or service marks; or

    f) Requiring indemnification of licensors and authors of that
    material by anyone who conveys the material (or modified versions of
    it) with contractual assumptions of liability to the recipient, for
    any liability that these contractual assumptions directly impose on
    those licensors and authors.

  All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10.  If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term.  If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.

  If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.

  Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.

  8. Termination.

  You may not propagate or modify a covered work except as expressly
provided under this License.  Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).

  However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.

  Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.

  Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License.  If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.

  9. Acceptance Not Required for Having Copies.

  You are not required to accept this License in order to receive or
run a copy of the Program.  Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance.  However,
nothing other than this License grants you permission to propagate or
modify any covered work.  These actions infringe copyright if you do
not accept this License.  Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.

  10. Automatic Licensing of Downstream Recipients.

  Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License.  You are not responsible
for enforcing compliance by third parties with this License.

  An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations.  If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.

  You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License.  For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.

  11. Patents.

  A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based.  The
work thus licensed is called the contributor's "contributor version".

  A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version.  For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.

  Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.

  In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement).  To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.

  If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients.  "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.

  If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.

  A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License.  You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.

  Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.

  12. No Surrender of Others' Freedom.

  If conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all.  For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.

  13. Use with the GNU Affero General Public License.

  Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a single
combined work, and to convey the resulting work.  The terms of this
License will continue to apply to the part which is the covered work,
but the special requirements of the GNU Affero General Public License,
section 13, concerning interaction through a network will apply to the
combination as such.

  14. Revised Versions of this License.

  The Free Software Foundation may publish revised and/or new versions of
the GNU General Public License from time to time.  Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.

  Each version is given a distinguishing version number.  If the
Program specifies that a certain numbered version of the GNU General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation.  If the Program does not specify a version number of the
GNU General Public License, you may choose any version ever published
by the Free Software Foundation.

  If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.

  Later license versions may give you additional or different
permissions.  However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.

  15. Disclaimer of Warranty.

  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

  16. Limitation of Liability.

  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.

  17. Interpretation of Sections 15 and 16.

  If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.

                     END OF TERMS AND CONDITIONS

            How to Apply These Terms to Your New Programs

  If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.

  To do so, attach the following notices to the program.  It is safest
to attach them to the start of each source file to most effectively
state the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.

    <one line to give the program's name and a brief idea of what it does.>
    Copyright (C) <year>  <name of author>

    This program 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.

    This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.

Also add information on how to contact you by electronic and paper mail.

  If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:

    <program>  Copyright (C) <year>  <name of author>
    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
    This is free software, and you are welcome to redistribute it
    under certain conditions; type `show c' for details.

The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License.  Of course, your program's commands
might be different; for a GUI interface, you would use an "about box".

  You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU GPL, see
<https://www.gnu.org/licenses/>.

  The GNU General Public License does not permit incorporating your program
into proprietary programs.  If your program is a subroutine library, you
may consider it more useful to permit linking proprietary applications with
the library.  If this is what you want to do, use the GNU Lesser General
Public License instead of this License.  But first, please read
<https://www.gnu.org/licenses/why-not-lgpl.html>.
#+end_src
* Dev
** Git ignore
#+begin_src gitignore :tangle (meta-in-dir ".gitignore") :prologue (meta-tangled-files->gitignore)
#+end_src





* Prebuilt clojure-tools :package:version:
Mirrors the clojure.org install script and thus uses prebuilt resources instead of bootstrapping everything the way the Guix package does. Bootstrapping is challenging and the Guix package is frequently out of date, doesn't update transitive dependencies to the same versions as upstream, and may be missing functionality (see [[https://issues.guix.gnu.org/53765][{PATCH 00/17} Remove limitations on clojure-tools]]).
#+begin_src scheme :tangle (meta-in-dir "nonphrenetic/packages/clojure.scm")
(define-module (nonphrenetic packages clojure)
  #:use-module (guix build-system copy)
  #:use-module (guix download)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module ((guix utils) #:select (substitute-keyword-arguments))
  #:use-module ((gnu packages clojure) #:select (clojure-tools) #:prefix clojure:)
  #:use-module ((gnu packages readline) #:select (rlwrap)))

(define-public clojure-tools
  (package
    (name (package-name clojure:clojure-tools))
    (version "1.11.1.1435")
    (source
     (origin
       (method url-fetch)
       (uri (string-append "https://download.clojure.org/install/clojure-tools-" version ".tar.gz"))
       (sha256
        (base32
         "1h4v762agzhnrqs3mj7a84xlw51xv6jh8mvlc5cc83q4n9wwabs5"))))
    (build-system copy-build-system)
    (arguments
     (substitute-keyword-arguments (package-arguments clojure:clojure-tools)
       ((#:install-plan install-plan)
        #~(append #$install-plan
                  (list
                   `(,(string-append "clojure-tools-" #$version ".jar") "lib/clojure/libexec/"))))
       ((#:phases phases)
        #~(modify-phases #$phases
            (delete 'copy-tools-deps-alpha-jar)))))
    (inputs
     (list rlwrap))
    (home-page (package-home-page clojure:clojure-tools))
    (synopsis (package-synopsis clojure:clojure-tools))
    (description (package-description clojure:clojure-tools))
    (license (package-license clojure:clojure-tools))))
#+end_src