~whereiseveryone/guixrus

4037eb43428f4beb335e30c234c71949529d8ef0 — ( 1 year, 1 month ago c429810
feat(home): rewrite HOME-EMACS-SERVICE-TYPE

This commit completely rewrites the HOME-EMACS-SERVICE-TYPE, adding numerous
features.  It should now be upstream-quality :)

- Environment variables for the Emacs daemon are now set by building a profile
  out of the Emacs packages provided.
- Launching multiple differently-named Emacs servers is now supported.
- You can now specify the Emacs to run as the daemon and the Emacs for compiling
  packages as separate fields.
- Emacs is now launched only when a connection is received on its socket, thanks
  to MAKE-SYSTEMD-CONSTRUCTOR.
1 files changed, 139 insertions(+), 95 deletions(-)

M guixrus/home/services/emacs.scm
M guixrus/home/services/emacs.scm => guixrus/home/services/emacs.scm +139 -95
@@ 1,5 1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 ( <paren@disroot.org>
;;; Copyright © 2022, 2023 ( <paren@disroot.org>
;;;
;;; This file is not part of GNU Guix.
;;;


@@ 19,130 19,174 @@
(define-module (guixrus home services emacs)
  #:use-module (gnu home services)
  #:use-module (gnu home services shepherd)
  #:autoload   (gnu packages emacs) (emacs-minimal
                                     emacs)
  #:autoload   (gnu packages emacs) (emacs emacs-minimal)
  #:autoload   (gnu packages gnupg) (guile-gcrypt)
  #:use-module (gnu services configuration)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix modules)
  #:use-module (guix monads)
  #:use-module (guix profiles)
  #:use-module (guix records)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)

  #:use-module (guix search-paths)
  #:use-module (guix store)
  #:use-module (ice-9 match)
  #:export (home-emacs-configuration
            home-emacs-service-type))

(define list-of-string?
  (list-of string?))

(define list-of-file-likes?
  (list-of file-like?))

(define file-like-or-#f?
  (match-lambda
    ((or #f
         (? file-like?)) #t)
    (_ #f)))

(define-configuration/no-serialization home-emacs-configuration
  (servers
   (list-of-string (list "server"))
   "List of strings which name Emacs servers to run.")
  (emacs
   (file-like emacs)
   "The package providing @file{/bin/emacs}.")
  (packages
   (list-of-file-likes '())
   "Packages to add to the Emacs plugin load path.")
   "Packages to add to the Emacs load path.")
  (native-compile?
   (boolean #f)
   "Whether to compile the @code{packages} using the Emacs package
provided as the value of the @code{emacs} field, which will enable
native compilation if the @code{emacs} package supports it.")
   "Whether to enable native-compilation of Emacs packages by building them with
@code{emacs} rather than @code{emacs-minimal}.  Has no effect if
COMPILATION-EMACS is not set to #F.")
  (compilation-emacs
   (file-like-or-#f #f)
   "The Emacs package to use to compile Emacs packages.  If #F, default to
EMACS-MINIMAL.")
  (init-file
   (file-like (plain-file "init.el" ""))
   "File-like to use as the initialisation Lisp file.")
   "File-like object to use as the Emacs initialisation script.")
  (early-init-file
   (file-like (plain-file "early-init.el" ""))
   "File-like to use as the pre-initialisation Lisp file.")
   "File-like object to use as the Emacs early-initialisation script.")
  (debug?
   (boolean #f)
   "Whether to enable debugging."))
   "Whether to enable debug output from Emacs."))

(define (home-emacs-profile-packages config)
  (list (home-emacs-configuration-emacs config)))
(define (emacs-for-compile config)
  (match-record config <home-emacs-configuration> (native-compile?
                                                   compilation-emacs)
    (cond
     (compilation-emacs compilation-emacs)
     (native-compile? emacs)
     (else emacs-minimal))))

(define (home-emacs-transformed-packages config)
  (map (if (home-emacs-configuration-native-compile? config)
           (package-input-rewriting
            `((,emacs-minimal
              . ,(home-emacs-configuration-emacs config))))
           identity)
       (let ((packages (home-emacs-configuration-packages config)))
         (concatenate
          (cons packages
                (map (compose (cute map second <>)
                              package-transitive-propagated-inputs)
                     packages))))))
(define (transformed-emacs-packages config)
  (match-record config <home-emacs-configuration> (packages)
    (map (package-input-rewriting
          `((,emacs-minimal . ,(emacs-for-compile config))))
         packages)))

(define (home-emacs-shepherd-services config)
  (list (shepherd-service
         (provision '(emacs))
         (documentation "Start the Emacs daemon.")
         (modules '((ice-9 ftw)
                    (srfi srfi-1)
                    (srfi srfi-26)))
         (start
          #~(make-forkexec-constructor
             (list #$(file-append
                      (home-emacs-configuration-emacs config)
                      "/bin/emacs")
                   "--fg-daemon" "--eval"
                   (format #f "~s"
                           `(progn
                             (setq custom-file
                                   (concat (or (getenv "XDG_CONFIG_HOME")
                                               (concat (getenv "HOME")
                                                       "/.config"))
                                           "/emacs/custom.el"))
                             (load custom-file)))
                   #$@(if (home-emacs-configuration-debug? config)
                          (list "--debug-init")
                          '()))
             #:log-file
             (format #f "~a/emacs.log"
                     (or (getenv "XDG_LOG_HOME")
                         (format #f "~a/.local/var/log"
                                 (getenv "HOME"))))
             #:environment-variables
             (let ((env-var
                    (lambda (name path)
                      (define (regular-directory? directory)
                        (not (member directory (list "." ".."))))
(define (make-emacs-profile config)
  (match-record config <home-emacs-configuration> (packages)
    (profile
     (name "emacs-profile")
     (content (packages->manifest (cons (emacs-for-compile config)
                                        packages))))))

                      (define (package-paths package)
                        (let ((directory (string-append package "/" path)))
                          (if (file-exists? directory)
                              (cons directory
                                    (map (cute string-append directory "/" <>)
                                         (scandir directory regular-directory?)))
                              '())))
(define not-config?
  ;; Select (guix …) and (gnu …) modules, except (guix config).
  (match-lambda
    (('guix 'config) #f)
    ((or ('gnu rest ...)
         ('guix rest ...))
     #t)
    (rest #f)))

                      (let ((old-value (getenv name)))
                        (string-append
                         name "="
                         (string-join
                          (append-map
                           package-paths
                           (list #$@(home-emacs-transformed-packages config)))
                          ":" (if old-value
                                  'suffix
                                  'infix))
                         (or old-value ""))))))
               (append (default-environment-variables)
                       (list (env-var "EMACSLOADPATH"
                                      "share/emacs/site-lisp")
                             (env-var "EMACSNATIVELOADPATH"
                                      "lib/emacs/native-site-lisp"))))))
         (stop
          #~(make-forkexec-constructor
             (list #$(file-append
                      (home-emacs-configuration-emacs config)
                      "/bin/emacsclient")
                   "--eval" "(kill-emacs)"))))))
(define (build-emacs-profile config)
  (with-store store
    (run-with-store store
      (mlet %store-monad
          ((profile-drv (lower-object
                         (make-emacs-profile config))))
        (mbegin %store-monad
          (built-derivations (list profile-drv))
          (return (derivation-output-path
                   (assoc-ref (derivation-outputs profile-drv)
                              "out"))))))))

(define (emacs-environment config)
  (with-imported-modules (source-module-closure '((guix search-paths)))
    #~(begin
        (use-modules (guix search-paths))
        (map (lambda (env-var)
               (let ((variable (list-ref env-var 0))
                     (separator (list-ref env-var 1))
                     (value (list-ref env-var 2)))
                 (string-append variable "="
                                (or (and=> (getenv variable)
                                           (lambda (original)
                                             (string-append original
                                                            separator)))
                                    "")
                                value)))
             '(#$@(map (match-lambda
                         ((spec . value)
                          (match-record spec <search-path-specification>
                              (variable separator)
                            (list variable separator value))))
                       (profile-search-paths
                        (build-emacs-profile config))))))))

(define (home-emacs-profile-packages config)
  (match-record config <home-emacs-configuration> (emacs)
    (list emacs)))

(define (home-emacs-shepherd-services config)
  (match-record config <home-emacs-configuration> (servers emacs debug?)
    (map (lambda (server)
           (shepherd-service
            (provision (list (string->symbol
                              (string-append "emacs-" server))))
            (documentation
             (string-append "Start the Emacs server called "
                            server "."))
            (start
             #~(make-systemd-constructor
                (list #$(file-append emacs "/bin/emacs")
                      (string-append "--fg-daemon=" #$server)
                      #$@(if debug?
                             (list "--debug-init")
                             '()))
                (list (endpoint
                       (make-socket-address
                        AF_UNIX
                        (format #f "/run/user/~a/emacs/~a"
                                (getuid) #$server))))
                #:log-file
                (format #f "~a/log/emacs/~a.log"
                        (or (getenv "XDG_STATE_HOME")
                            (format #f "~a/.local/state"
                                    (getenv "HOME")))
                        #$server)
                #:environment-variables
                (append (default-environment-variables)
                        #$(emacs-environment config))))
            (stop
             #~(make-forkexec-constructor
                (list #$(file-append emacs "/bin/emacsclient")
                      "-s" #$server "--eval" "(kill-emacs)")))))
         servers)))

(define (home-emacs-xdg-configuration-files config)
  `(("emacs/early-init.el"
     ,(home-emacs-configuration-early-init-file config))
    ("emacs/init.el"
     ,(home-emacs-configuration-init-file config))))
  (match-record config <home-emacs-configuration> (early-init-file
                                                   init-file)
    `(("emacs/early-init.el"
       ,(home-emacs-configuration-early-init-file config))
      ("emacs/init.el"
       ,(home-emacs-configuration-init-file config)))))

(define home-emacs-service-type
  (service-type