;;; GNU Guix --- Functional package management for GNU

;;; Copyright © 2023 ( <paren@disroot.org>
;;; Copyright © 2023 David Wilson <david@daviwil.com>
;;; Copyright © 2023 Kierin Bell <fernseed@fernseed.me>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu home services emacs)
  #:use-module (gnu home services)
  #:use-module (gnu home services shepherd)
  #:autoload   (gnu packages emacs) (emacs emacs-minimal)
  #:autoload   (gnu packages emacs-xyz) (emacs-use-package)
  #:use-module (gnu services configuration)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module (guix modules)
  #:use-module (guix read-print)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix i18n)
  #:use-module ((guix diagnostics)
                #:select (formatted-message))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 control)
  #:use-module (ice-9 regex)
  #:use-module (language elisp parser)
  #:re-export (blank?

               vertical-space
               vertical-space?
               vertical-space-height

               page-break
               page-break?

               comment
               comment?
               comment->string
               comment-margin?)
  #:export (elisp?
            elisp->sexp
            sexp->elisp
            elisp

            elisp-file*
            elisp-file
            elisp-file?

            emacs-keymap
            emacs-keymap?
            emacs-keymap-name
            emacs-keymap-package-name
            emacs-keymap-repeat?
            emacs-keymap-repeat-exit
            emacs-keymap-repeat-enter
            emacs-keymap-keys

            emacs-package
            emacs-package?
            emacs-package-name
            emacs-package-package
            emacs-package-extra-packages
            emacs-package-extra-files
            emacs-package-install?
            emacs-package-load-force?
            emacs-package-load-predicates
            emacs-package-load-after-packages
            emacs-package-load-paths
            emacs-package-autoloads
            emacs-package-autoloads-interactive
            emacs-package-keys-global
            emacs-package-keys-global-keymaps
            emacs-package-keys-override
            emacs-package-keys-local
            emacs-package-options
            emacs-package-faces
            emacs-package-hooks
            emacs-package-auto-modes
            emacs-package-magic-modes
            emacs-package-extra-after-load
            emacs-package-extra-init
            emacs-package-extra-keywords

            emacs-configuration
            emacs-configuration?
            emacs-configuration-early-init
            emacs-configuration-extra-init-files
            emacs-configuration-extra-files
            emacs-configuration-variables
            emacs-configuration-modes
            emacs-configuration-keys
            emacs-configuration-keys-override
            emacs-configuration-extra-init

            emacs-server
            emacs-server?
            emacs-server-name
            emacs-server-inherit-directory?
            emacs-server-inherit-init?
            emacs-server-inherit-configured-packages?
            emacs-server-load-custom?
            emacs-server-extra-packages
            emacs-server-auto-start?
            emacs-server-debug?
            emacs-server-shepherd-requirements
            emacs-server-default-init
            emacs-server-configured-packages

            emacs-package-serializer
            emacs-package-serializer?
            emacs-package-serializer-name
            emacs-package-serializer-procedure
            emacs-package-serializer-dependencies
            emacs-package-serializer-indent-forms
            emacs-package-serializer-description

            emacs-package->simple-elisp
            %emacs-simple-package-serializer
            emacs-package->use-package-elisp
            %emacs-use-package-serializer

            home-emacs-configuration
            home-emacs-configuration?
            home-emacs-configuration-emacs
            home-emacs-configuration-user-emacs-directory
            home-emacs-configuration-native-compile?
            home-emacs-configuration-load-custom?
            home-emacs-configuration-extra-packages
            home-emacs-configuration-package-serializer
            home-emacs-configuration-indent-forms
            home-emacs-configuration-propagated-init
            home-emacs-configuration-default-init
            home-emacs-configuration-configured-packages
            home-emacs-configuration-servers

            home-emacs-extension
            home-emacs-extension?
            home-emacs-extension-extra-packages
            home-emacs-extension-indent-forms
            home-emacs-extension-servers
            home-emacs-extension-default-init
            home-emacs-extension-configured-packages

            emacs-server->provision

            home-emacs-service-type

            elisp-file->home-emacs-configuration))

;;; Commentary:
;;;
;;; Services for the GNU Emacs extensible text editor.
;;;
;;; Code:

\f
;;;
;;; Elisp expression objects.
;;;

(define-record-type* <elisp> %elisp
  make-elisp
  elisp?
  this-elisp
  (sexp elisp-sexp))

(define (dotted-list?* obj)
  (and (pair? obj)
       (dotted-list? obj)))

(define list->dotted-list
  (match-lambda
    ((? list? lst)
     (match (last-pair lst)
       (((? pair?) . ())
        ;; Prevent, e.g., '((quote a) (quote b)) -> '((quote a) quote b).
        lst)
       (_
        (apply cons* lst))))
    (x
     x)))

(define (fold-right/elisp fhere fup fcons seed exp)
  "Recurse into subexpressions and `elisp' objects in EXP, applying FHERE, FUP
and FCONS.  FHERE transforms atoms, FUP transforms accumulators after
traversing lists, and FCONS joins atoms or lists with accumulators while
traversing lists.  FHERE and FCONS each take two arguments: an element and an
accumulator.  For FUP, the second argument is the accumulator, and the first
argument is either the empty list or false if its first argument was derived
from a dotted list.  The accumulator starts as SEED."
  (define (reverse* lst)
    (let loop ((lst lst)
               (acc '()))
      (match lst
        ((? null?)
         acc)
        ((not (? pair?))
         ;; Convert dotted lists into proper lists.
         (cons lst acc))
        ((head . tail)
         (loop tail (cons head acc))))))

  (match exp
    ((? elisp?)
     (fold-right/elisp fhere fup fcons seed (elisp-sexp exp)))
    ((or (not (? pair?))
         (? null?))
     ;; The empty list should be passed to FHERE along with atoms.
     (fhere exp seed))
    (_
     (let loop ((exp (reverse* exp))
                (acc seed)
                (dotted? (dotted-list?* exp)))
       (match exp
         ((? null?)
          ;; XXX: FUP must handle any transformation of ACC back into a
          ;; dotted list, since FHERE could have transformed the last
          ;; element of ACC into a list, in which case we can't just use
          ;; `list->dotted-list' to get a dotted list back.
          (fup (if dotted? (not dotted?) exp) acc))
         ((head . tail)
          (loop tail
                (fcons (fold-right/elisp fhere fup fcons seed head)
                       acc)
                dotted?)))))))

(define (elisp->sexp exp)
  "Return an s-expression containing the contents of Elisp expression EXP."
  (fold-right/elisp (lambda (t s) t)
                    (lambda (t s)
                      (if (not t) (list->dotted-list s) s))
                    cons
                    '()
                    exp))

(define (elisp->lowerable-sexp exp)
  "Return an s-expression from EXP that is lowerable within a G-expression,
that is, strip `<vertical-space>', `<page-break>', and `<comment>' objects."
  (let ((result (fold-right/elisp (lambda (t s) t)
                                  (lambda (t s)
                                    (if (not t) (list->dotted-list s) s))
                                  (lambda (t s) (if (blank? t) s (cons t s)))
                                  '()
                                  exp)))
    ;; XXX: What to do when an Elisp expression *is* a <blank>?
    (if (blank? result) '() result)))

(define-gexp-compiler (elisp-compiler (elisp <elisp>) system target)
  ;; "Compile" an `elisp' object by stripping `<vertical-space>',
  ;; `<page-break>', and `<comment>' objects, so that it can be `ungexp'd
  ;; within a G-expression.
  (with-monad %store-monad
    (return (elisp->lowerable-sexp elisp))))

(define (sexp->elisp sexp)
  "Return an Elisp expression object containing SEXP."
  (%elisp (sexp sexp)))

(define-syntax elisp
  ;; Create an `<elisp>' object from EXP, including any substitutions made
  ;; with `unelisp', `unelisp-splicing', `unelisp-comment', `unelisp-newline',
  ;; or `unelisp-page-break'.
  ;; Modified from the `gexp' macro in `(guix gexp)'.
  (lambda (s)

    (define (substitute-unelisp e)
      (syntax-case e (unelisp
                      unelisp-splicing
                      unelisp-comment
                      unelisp-newline
                      unelisp-page-break)
        ((unelisp exp)
         #'exp)
        (((unelisp-splicing exp) rest ...)
         #`(append exp #,(substitute-unelisp #'(rest ...))))
        ((unelisp-comment str)
         #'(comment str))
        ((unelisp-newline)
         #'(vertical-space 0))
        ((unelisp-page-break)
         #'(page-break))
        ((exp0 . exp)
         #`(cons #,(substitute-unelisp #'exp0)
                 #,(substitute-unelisp #'exp)))
        (x #''x)))

    (syntax-case s ()
      ((_ exp)
       (let ((sexp* (substitute-unelisp #'exp)))
         #`(%elisp (sexp #,sexp*)))))))

\f
;;;
;;; Elisp files.
;;;

(define-record-type* <elisp-file> %elisp-file
  make-elisp-file
  elisp-file?
  this-elisp-file
  (name elisp-file-name)
  (gexp elisp-file-gexp))

(define (constant? obj)
  "Return whether OBJ is self-quoting."
  (or (boolean? obj)
      (char? obj)
      (string? obj)
      (keyword? obj)
      (number? obj)
      (array? obj)))

(define* (elisp->file-builder exps #:key (special-forms '()))
  "Return a G-expression that builds a file containing the Elisp
expressions (<elisp> objects or s-expressions) or G-epxressions in list EXPS.
See `elisp-file' for a description of SPECIAL-FORMS."

  (define (object->pp-quoted exp)
    (match exp
      ((? vertical-space?)
       `((@ (guix read-print) vertical-space)
         ,(vertical-space-height exp)))
      ((? page-break?)
       '((@ (guix read-print) page-break)))
      ((? comment?)
       `((@ (guix read-print) comment)
         ,(comment->string exp)))
      ((? constant?)
       exp)
      (_
       (list 'quote exp))))

  (define (elisp->pp-arg exp)
    ;; Doing some of this on the derivation side with a macro similar to
    ;; `quasiquote' might be cleaner, at the expense of an extra tree
    ;; traversal.
    (fold-right/elisp (lambda (t s)
                        (object->pp-quoted t))
                      (lambda (t s)
                        (if (not t)
                            ;; Transform S back into a dotted list, but only
                            ;; after Scheme `quote' forms have been evaluated.
                            ;; Also, never allow <comment>, <vertical-space>,
                            ;; or <page-break> record constructors to
                            ;; terminate a dotted list
                            ;; (`pretty-print-with-comments' shouldn't print
                            ;; them anyway).
                            (match (last-pair s)
                              ((`((@ (guix read-print) ,(or 'vertical-space
                                                            'page-break
                                                            'comment)) . ,_)
                                . ())
                               `(list ,@s))
                              (_ `(apply cons* (list ,@s))))
                            `(list ,@s)))
                      cons
                      '()
                      exp))

  (with-imported-modules (source-module-closure
                          '((guix read-print)))
    (gexp (begin
            (use-modules (guix read-print))
            (call-with-output-file (ungexp output "out")
              (lambda (port)
                (set-port-encoding! port "UTF-8")
                (ungexp-splicing (append-map
                                  (match-lambda
                                    ((? gexp? exp)
                                     (list (gexp (pretty-print-with-comments
                                                  port
                                                  (quote (ungexp exp))
                                                  #:elisp? #t
                                                  #:special-forms
                                                  '(ungexp special-forms)))
                                           (gexp (display "\n" port))))
                                    ((? elisp? exp)
                                     (append
                                      (list
                                       (gexp (pretty-print-with-comments
                                              port
                                              (ungexp (elisp->pp-arg exp))
                                              #:format-comment
                                              canonicalize-comment
                                              #:elisp? #t
                                              #:special-forms
                                              '(ungexp special-forms))))
                                      (if (comment? (elisp->sexp exp))
                                          '()
                                          (list
                                           (gexp (display "\n" port))))))
                                    (exp
                                     ;; We can use S-exps internally to
                                     ;; avoid overhead of converting `elisp'
                                     ;; objects back into S-exps.
                                     (append
                                      (list
                                       (gexp (pretty-print-with-comments
                                              port
                                              (ungexp (elisp->pp-arg exp))
                                              #:format-comment
                                              canonicalize-comment
                                              #:elisp? #t
                                              #:special-forms
                                              '(ungexp special-forms))))
                                      (if (comment? exp)
                                          '()
                                          (list
                                           (gexp (display "\n" port)))))))
                                  exps))))))))

(define* (elisp-file name exps #:key (special-forms '()))
  "Return an object representing the store file NAME, an Emacs Lisp file that
contains EXPS, a list of Elisp expression objects or G-expressions.

Custom indentation rules can be specified with SPECIAL-FORMS, an association
list where each entry is of the form (SYMBOL . INDENT).  When SYMBOL occurs at
the beginning of a list in an expression in EXPS, the first INDENT expressions
after SYMBOL are indented as arguments and the remainder are indented as body
expressions, as if INDENT was the value of the `lisp-indent-function' symbol
property for SYMBOL in Emacs.  As in Emacs, argument expressions, if they
cannot be pretty-printed on the same line as SYMBOL, are indented 4 columns
beyond the base indentation of the enclosing list, and body expressions are
indented 2 columns beyond the base indentation.

This is the declarative counterpart of `elisp-file*'."
  (%elisp-file (name name)
               (gexp (elisp->file-builder exps
                                          #:special-forms special-forms))))

(define-gexp-compiler (elisp-file-compiler (elisp-file <elisp-file>)
                                           system target)
  (match-record elisp-file <elisp-file>
                (name gexp)
    (with-monad %store-monad
      (gexp->derivation name gexp
                        #:system system
                        #:target target
                        #:local-build? #t
                        #:substitutable? #f))))

(define* (elisp-file* name exps #:key (special-forms '()))
  "Return as a monadic value a derivation that builds an Elisp file named NAME
containing the expressions in EXPS, a list of Elisp expression objects or
G-expressions.

This is the monadic counterpart of `elisp-file', which see for a description
of SPECIAL-FORMS,"
  (define builder
    (elisp->file-builder exps
                         #:special-forms special-forms))

  (gexp->derivation name builder
                    #:local-build? #t
                    #:substitutable? #f))

\f
;;;
;;; Helper functions
;;;

(define (ensure-list obj)
  "Return OBJ as a list."
  (if (list? obj) obj (list obj)))

(define (file-name-concat dir . rest)
  "Concatenate DIR and REST filename components.  Any final slashes are
stripped from the resulting filename."
  (string-join (append (list (string-trim-right dir #\/))
                       (map (cut string-trim-both <> #\/)
                            rest))
               "/"))

(define (record-value rec field)
  "Return the value of field named FIELD in record REC."
  ((record-accessor (record-type-descriptor rec) field) rec))

(define-syntax extend-record
  ;; Extend record ORIGINAL by creating a new copy using CONSTRUCTOR,
  ;; replacing each field specified by ORIG-FIELD with the evaluation of (PROC
  ;; ORIG-VAL EXT-VALS), where ORIG-VAL is the value of ORIG-FIELD in ORIGINAL
  ;; and EXT-VALS is the list of values of EXT-FIELD in EXTENSIONS.
  (lambda (s)
    (syntax-case s ()
      ((_ constructor original extensions (proc orig-field ext-field) ...)
       (with-syntax (((field-specs ...)
                      (map
                       (lambda (spec)
                         (syntax-case spec ()
                           ((proc orig-field ext-field)
                            #'(orig-field
                               (apply
                                proc
                                (list
                                 (record-value original 'orig-field)
                                 (map
                                  (lambda (e)
                                    (record-value e 'ext-field))
                                  extensions)))))))
                       #'((proc orig-field ext-field) ...))))
         #'(constructor
            (inherit original)
            field-specs ...))))))

(define (extend-list original extensions)
  "Extend list ORIGINAL with list of lists EXTENSIONS."
  (apply append original extensions))

(define (extend-list-merge original extensions)
  "Extend list ORIGINAL with list of lists EXTENSIONS, deleting duplicates."
  (delete-duplicates (apply append original extensions) equal?))

(define (extend-alist-merge original extensions)
  "Extend association list ORIGINAL with list of association lists EXTENSIONS,
merging the values for any duplicate keys into a single list value.  Key
comparison is done with `equal?'."
  (fold-right (lambda (elem ret)
                (let ((entry (assoc (car elem) ret)))
                  (if entry
                      (acons (car elem)
                             (append (ensure-list (cdr elem))
                                     (ensure-list (cdr entry)))
                             (assoc-remove! ret (car elem)))
                      (cons elem ret))))
              '()
              (apply append original extensions)))


(define* (extend-record-list-merge original extensions cmp-field proc
                                   #:key (type? (const #t)) (= equal?))
 "Extend list of records ORIGINAL with list of records EXTENSIONS by merging
all records whose CMP-FIELDs are equal according to equality predicate = using
PROC, a procedure that takes a record as its first argument and a list of
records as its second argument and should return a single record object.  All
objects that do not satisfy type predicate TYPE? are added to the returned
list without comparison."
  (let loop ((lst (apply append original extensions))
             (acc '()))
    (cond
     ((null? lst) (reverse acc))
     ((not (type? (car lst)))
      (loop (cdr lst)
            (cons (car lst) acc)))
     ((partition
       (lambda (ext)
         (and (type? ext)
              (= (record-value ext cmp-field)
                 (record-value (car lst) cmp-field))))
       (cdr lst))
      (lambda (matches rest) (not (null? matches)))
      => (lambda (matches rest)
           (loop rest
                 (cons (apply proc (car lst) (list matches))
                       acc))))
     (else (loop (cdr lst)
                 (cons (car lst) acc))))))

(define* (extend-record-field-default original extensions
                                      default-record field
                                      #:key (= eq?))
  "Extend the value of ORIGINAL with any value in the list of EXTENSIONS that
is not equal to the value of FIELD in DEFAULT-RECORD, signaling an error if
there is any value in EXTENSIONS that is not equal to either ORIGINAL or the
default according to equality predicate = (which defaults conservatively to
`eq?').  For example, if the default value of FIELD and the value of FIELD in
ORIGINAL are both #f, and at least one element of EXTENSIONS is #t, return #t,
but if the default value of FIELD is 'foo, ORIGINAL is 'bar, and EXTENSIONS
contains a value 'baz, then signal an error."
  (let* ((def (record-value default-record field))
         (new (fold (lambda (elem ret)
                      (cond
                       ((= elem original) ret)
                       ((= elem def) elem)
                       (else (configuration-field-error
                              #f field elem))))
                    '()
                    extensions)))
    (if (null? new) original new)))

(define (elisp-or-gexp? val)
  (or (elisp? val)
      (gexp? val)))

(define-syntax alist-sanitizer
  ;; Construct a lambda expression that matches each KEY-PAT and VALUE-PAT
  ;; pair against each entry of its argument, an alist.  If no pair matches,
  ;; or if its argument is not an alist, the lambda signals an error
  ;; displaying FIELD-NAME and the value of its argument.  Otherwise, the
  ;; return value of the lambda is its argument.
  (lambda (s)
    (syntax-case s ()
      ((_ field-name (key-pat . value-pat) ...)
       (with-syntax (((clauses ...)
                      (map
                       (lambda (spec)
                         (syntax-case spec ()
                           ((key-pat . value-pat)
                            ;; Note that entries of the form (A B) are
                            ;; equivalent to (A . (B))---i.e., the value is
                            ;; really a list, not an atom.  However, (A B)
                            ;; where B is an Elisp expression is converted
                            ;; into (A . B).
                            #'(((and key-pat key)
                                . (and value-pat value))
                               (cons key value)))))
                       #'((key-pat . value-pat) ...))))
         #'(lambda (val)
             (map
              (lambda (expr)
                (match expr
                  clauses ...
                  (_ (configuration-field-error #f 'field-name val))))
              val))))
      ((_ field-name '(key-pat . value-pat) ...)
       #'(alist-sanitizer field-name (key-pat . value-pat) ...))
      ((_ field-name)
       #'(alist-sanitizer field-name (_ . _))))))

(define (symbol-or-false? val)
  (or (symbol? val)
      (not val)))

(define (symbol-or-null? val)
  (or (symbol? val)
      (null? val)))

(define (string-or-file-like? val)
  (or (string? val)
      (file-like? val)))

(define (string-or-vector? val)
  (or (string? val)
      (vector? val)))

(define (package-or-null? val)
  (or (package? val)
      (null? val)))

(define (keyword-or-symbol? val)
  (or (keyword? val)
      (symbol? val)))

(define list-of-symbols?
  (list-of symbol?))

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

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

(define list-of-elisp-or-gexps?
  (list-of elisp-or-gexp?))

(define (elispifiable-quoted? val)
  "Return whether VAL can be serialized as Elisp, but needs to be quoted."
  (or (symbol? val)
      (pair? val)))

(define (elispifiable? val)
  "Return whether VAL can be serialized as Elisp."
  (or (constant? val)
      (elispifiable-quoted? val)
      (gexp? val)
      (file-like? val)
      (and (elisp? val)
           (not (blank? (elisp->sexp val))))))

(define elispifiable->elisp
  (match-lambda
    ((? elisp? obj)
     obj)
    ((? elispifiable-quoted? obj)
     (sexp->elisp `(quote ,obj)))
    (obj
     (sexp->elisp obj))))

(define-syntax keys-field-sanitizer
  (syntax-rules ()
    ((_ field-name)
 (alist-sanitizer field-name
                      ((? string-or-vector?) . (? symbol-or-false?))))))

(define (composite-file name . files)
  "Return an object representing store file NAME containing the text contents
of all file-like objects in FILES."
  (define builder
    (with-imported-modules (source-module-closure
                            '((ice-9 rdelim)))
      (gexp (begin
              (use-modules (ice-9 rdelim))
              (call-with-output-file (ungexp output "out")
                (lambda (port)
                  (set-port-encoding! port "UTF-8")
                  (ungexp-splicing
                   (interpose
                    (map (lambda (file)
                           (gexp (display (with-input-from-file
                                              (ungexp file)
                                            read-string)
                                          port)))
                         files)
                    (gexp (display "\n" port))
                    'suffix))))))))

  (computed-file name builder))

\f
;;;
;;; Emacs configuration records.
;;;

(define %default-emacs emacs)
(define %default-emacs-config-dir "~/.config/emacs/")
(define %emacs-user-init-filename "init.el")
(define %emacs-early-init-filename "early-init.el")

(define-configuration/no-serialization emacs-keymap
  (name
   (symbol 'global-map)
   "The symbol of the Emacs keymap in which to bind keys.")
  (package-name
    (symbol-or-null '())
    "The symbol naming the Emacs package providing the keymap, as would be
used with Emacs @code{require}.  If this field is null (the default), then the
package for which the keymap is being configured should define the keymap or
the keymap should otherwise be defined by the time the configuration for the
package is evaluated.")
  (repeat?
   (boolean #f)
   "Whether to make this keymap a repeat map (@pxref{Repeating,,, emacs, The
GNU Emacs Manual}).  Repeat maps are created by setting the @code{repeat-map}
symbol property for each key definition in @code{keys} to the @code{name} of
this keymap.  Use the @code{repeat-exit} field to override this setting for
specific bindings.")
  (repeat-exit
   (list-of-symbols '())
   "A list of commands that exit the repeat map.  When @code{repeat?} is true,
these commands do not get the @code{repeat-map} property.  The meaning of this
field is similar to that of the @code{:exit} keyword used by the
@code{defvar-keymap} function in Emacs.  This field has no effect when
@code{repeat?} is false.")
  (repeat-enter
   (list-of-symbols '())
   "A list of additional commands that enter the repeat map.  When
@code{repeat?} is true, these commands get the @code{repeat-map} property,
even when they are not bound in the keymap.  This is only useful when a
command is not bound in @code{name}, but the repeat map should be accessible
after that command is invoked (e.g., with @kbd{M-x}).  The meaning of this
field is similar to that of the @code{:enter} keyword used by the
@code{defvar-keymap} function in Emacs.  This field has no effect when
@code{repeat?} is false.")
  (disabled-commands
   (alist '())
   "An association list of command symbols and whether to disable them.  When
a disabled command is interactively invoked, Emacs asks for confirmation from
the user (@pxref{Disabling,,, emacs, The GNU Emacs Manual}).  The values of
this alist should be booleans, which will be stored as the value of the
@code{disabled} property of each respective command symbol.  Thus, to disable
the @code{transpose-chars} command and enable the @code{erase-buffer} command,
you can use:

@lisp
'((transpose-chars . #t)
  (erase-buffer . #f))
@end lisp
"
   (sanitizer
    (alist-sanitizer disabled-commands
                     ((? symbol?) . (? boolean?)))))
  (keys
   (alist '())
   "An association list of key sequences and binding definitions.  Key
sequences are Emacs-specific string or vector representations of sequences of
keystrokes or events.  Strings should be valid arguments to the Emacs function
@code{kbd}, and they are preferred over the low-level vector
representations (@pxref{Keymaps,,, elisp, The Emacs Lisp Manual}).  Binding
definitions should be Emacs command symbols.  As a special case, when a
binding definition is the boolean false, the key is unset in the keymap."
   (sanitizer (keys-field-sanitizer keys))))

(define list-of-emacs-keymaps?
  (list-of emacs-keymap?))

(define-configuration/no-serialization emacs-package
  (name
   (symbol)
   "The symbol naming the Emacs package or library, as would be used with
Emacs @code{require}.")
  (package
    (package-or-null '())
    "A Guix package providing the Emacs package specified by @code{name}.  If
the package is built into Emacs, or if there is no associated Guix package,
this field should be set to the empty list (the default).")
  (extra-packages
   (list-of-file-likes '())
   "A list of packages or file-like objects that provide additional
functionality used by this package, but which are not installed automatically
by the Guix package manager as propagated inputs of @code{package}.")
  (extra-files
   (alist '())
   "An association list of filenames and file-like objects specifying files to
create in the Emacs user directory.  For each entry, a file with the given
filename will be created in the Emacs user directory with the contents of the
file-like object.  If a list of file-like objects is given for an entry, the
new file will contain the combined text contents of all of the file-like
objects in the list.  This field should be used to add per-package files to
the Emacs user directory."
   (sanitizer (alist-sanitizer extra-files
                               ((? string?)
                                . (or (? file-like?)
                                      (? list-of-file-likes?))))))
  (install?
   (boolean #t)
   "Whether to install @code{package} and @code{extra-packages}.")
  (load-force?
   (boolean #f)
   "Whether to force loading of this package immediately when Emacs is
initialized, rather than deferring loading, for example, until an autoloaded
function is invoked.  This is similar in effect to the keyword @code{:demand}
from @code{use-package} and to the inverse of the keyword @code{:defer}.  The
difference is that when this field is false, package loading should always be
deferred; @code{use-package} normally does not defer loading when it does not
set up autoloads, because it doesn't know that Guix handles autoloads on its
own.")
  (load-predicates
   (list-of-elisp-or-gexps '())
   "A list predicate expressions to evaluate when Emacs is initialized to
determine whether to evaluate the configuration for this package.  When this
list is not empty, @emph{all} other configuration for this package should be
effectively surrounded in the Emacs user initialization file by a block of the
form: @code{(when @var{load-predicates} @dots{})}.  This is the supercharged
Guix version of the @code{use-package} @code{:if} keyword!

If multiple load predicates are specified, the behavior is determined by the
package configuration serializer.  Both @code{%emacs-use-package-serializer}
and the @code{%emacs-use-package-serializer} compose load predicates using
@code{and}, so that all load predicates in the list must be satisfied in order
for the package configuration to be evaluated.")
  (load-after-packages
   (list-of-symbols '())
   "A list of symbols for Emacs packages that must be loaded before this
package is loaded.  Only after all of the packages in the list have been
loaded by Emacs should configuration for this package be evaluated.  This is
similar to a simplified version of the @code{:after} keyword from
@code{use-package}.")
  (load-paths
   (list-of-string-or-file-likes '())
   "A list of additional load paths to add to the Emacs @code{load-paths}
variable.  Load paths can be specified either as strings or as file-like
objects, in which case a path to the respective store item is substituted.")
  (autoloads
   (list-of-symbols '())
   "A list of Emacs functions from the package to autoload.  This can be
useful, for example, when defining custom commands in the Emacs user
initialization file that use functions which are not autoloaded by default.")
  (autoloads-interactive
   (list-of-symbols '())
   "A list of additional Emacs interactive commands from the package to
autoload, so that they can be invoked interactively before the package is
loaded.")
  (keys-global
   (alist '())
   "An association list of key sequences (as strings or vectors) and Emacs
commands to bind in the global keymap."
   (sanitizer (keys-field-sanitizer keys-global)))
  (keys-global-keymaps
   (alist '())
   "An association list of key sequences and Emacs keymap variables to bind to
them in the global keymap.  The keymap variables should be symbols that define
keymaps in the package; they can be effectively autoloaded using this
assumption."
   (sanitizer (alist-sanitizer field-name
                               ((? string-or-vector?) . (? symbol?)))))
  (keys-override
   (alist '())
   "An association list of key sequences and symbols naming Emacs commands to
bind in the global override map.  These key bindings have a higher precedence
than local and global keybindings."
   (sanitizer (keys-field-sanitizer keys-override)))
  (keys-local
   (list-of-emacs-keymaps '())
   "A list of key binding configurations for specific keymaps, each contained
in an @code{emacs-keymap} object.")
  (options
   (alist '())
   "An association list of user options and values for this package.
Options should be symbols naming Emacs variables, and values can be any object
that can be serialized to Elisp.  For values, primitive Scheme data types are
implicitly quoted, including lists and symbols.  To instead set an option to
the value of an expression to be evaluated at Emacs initialization time,
either use an Elisp expression
(e.g., specified with the @code{elisp} form) or a G-expression for a value."
   (sanitizer (alist-sanitizer options
                               ((? symbol?) . (? elispifiable?)))))
  (faces
   (alist '())
   "An association list of face symbols and face specs.  @xref{Defining
Faces,,, elisp, The Emacs Lisp Manual} for the format of face specs."
   (sanitizer (alist-sanitizer
               faces
               ((? symbol?)
                . (((or 'default #t 't (? list?)) . (prop . rest)) ..1)))))
  (hooks
   (alist '())
   "An association list of hooks and functions to add to them.  Each entry is
a pair of symbols.  Hook symbols in Emacs should end in @samp{-hook}, but the
@code{%emacs-simple-package-serializer} and
@code{%emacs-use-package-serializer} serializers effectively add this suffix
when necessary."
   (sanitizer (alist-sanitizer hooks
                               ((? symbol?) . (? symbol?)))))
  (auto-modes
   (alist '())
   "An association list of filename patterns as regular expression strings and
Emacs mode functions to call when visiting files with filenames that match the
patterns.  @xref{Auto Major Mode,,, elisp, The Emacs Lisp Manual}, for
details."
   (sanitizer (alist-sanitizer auto-modes
                               ((? string?) . (? symbol?)))))
  (magic-modes
   (alist '())
   "An association list regular expression strings and Emacs mode functions to
call when visiting files that begin with matching text.  @xref{Auto Major
Mode,,, elisp, The Emacs Lisp Manual}, for details."
   (sanitizer (alist-sanitizer magic-modes
                               ((? string?) . (? symbol?)))))
  (extra-after-load
   (list-of-elisp-or-gexps '())
   "A list of Elisp expressions or G-expressions to evaluate after the package
is loaded, as with the Emacs @code{eval-after-load} function.  Elisp
expressions can be specified using the @code{elisp} syntax or the @code{#%}
reader extension.")
  (extra-init
   (list-of-elisp-or-gexps '())
   "A list of Elisp expressions or G-expressions to evaluate immediately when
Emacs is initialized, even if loading is deferred due to the
@code{load-force?} field.  Note that the @code{load-predicates} field should
still determine whether these expressions are evaluated, and they will only be
evaluated after all packages specified in the @code{load-after-packages} field
have been loaded.")
  (extra-keywords
   (alist '())
   "An association list of keys and lists of extra Elisp expressions or
G-expressions.  Keys can potentially be any keyword or symbol object; keywords
are automatically serialized to their Emacs Lisp equivalent (e.g.,
@code{#:keyword} is serialized as @code{:keyword}).  The meanings of entries
is specific to each package serializer, and any key may be ignored by a
package serializer.  This field is currently ignored by the
@code{%emacs-simple-package-serializer}.  Entries in this list matching
@code{use-package} keywords will be spliced by the
@code{%emacs-use-package-serializer} into the @code{use-package} body, after
all other forms."
   (sanitizer (alist-sanitizer extra-keywords
                               ((? keyword-or-symbol? key)
                                . (? list-of-elisp-or-gexps? val))))))

(define list-of-emacs-packages?
  (list-of emacs-package?))

(define-configuration/no-serialization emacs-configuration
  (early-init
   (list-of-elisp-or-gexps '())
   "A list of Elisp expressions or G-expressions to serialize to the Emacs
early init file, the @file{early-init.el} file in the appropriate Emacs
configuration directory.")
  (extra-init-files
   (alist '())
   "An association list of filenames and file-like objects containing Emacs
Lisp to load when Emacs is initialized.  For each entry, a file with the text
contents of the file-like object, or the combined text contents of all of the
file-like objects in a list if a list is specified, will be created with the
given filename in the appropriate Emacs configuration directory (the directory
where the @file{early-init.el} and @file{init.el} files are located).  These
files will then be loaded when Emacs is initialized, before the expressions
specified in @code{extra-init} are evaluated.

Note that it is an error to specify files with the filenames @samp{init.el}
and @samp{early-init.el}, because these files are already generated by the
Emacs home service."
   (sanitizer (alist-sanitizer extra-init-files
                               ((? string?)
                                . (or (? file-like?)
                                      (? list-of-file-likes?))))))
  (extra-files
   (alist '())
   "An association list of filenames and file-like objects specifying files to
create in the Emacs user directory.  For each entry, a file with the given
filename will be created with the contents of the file-like object.  If a list
of file-like objects is given for an entry, the new file will contain the
combined text contents of all of the file-like objects in the list.  This
field can be used to add configuration files for Emacs that should not be
automatically loaded when Emacs is initialized.

Note that the Emacs user directory, which can be specified using the
@code{user-emacs-directory} field of the @code{home-emacs-configuration}
record for the service, may not be the same as the directory containing Emacs
configuration files, such as the Emacs user initialization file or files
created according to the @code{extra-init-files} field."
   (sanitizer (alist-sanitizer extra-files
                               ((? string?)
                                . (or (? file-like?)
                                      (? list-of-file-likes?))))))
  (variables
   (alist '())
   "An association list of Emacs variables and values to set in the Emacs
initialization file.  Variables should be symbols naming Emacs variables, and
values can be any objects that can be serialized to Elisp.  For values,
primitive Scheme data types are implicitly quoted, including lists and
symbols.  To instead set an option to the value of an expression to be
evaluated at Emacs initialization time, use either an Elisp expression (e.g.,
specified with the @code{elisp} form) or a G-expression as a value.  For
convenience, a file-like object can be given directly as a value, in which
case it will be substituted with a path name in the store as if it was
included within an Elisp expression or G-expression.  Note that it is an error
to specify an Elisp expression value that contains only comments or whitespace
for this field."
   (sanitizer (alist-sanitizer variables
                               ((? symbol?) . (? elispifiable?)))))
  (modes
   (alist '())
   "An association list of global minor modes and arguments.  When an argument
is true or false, enable or disable the mode, respectively, when Emacs is
initialized.  Otherwise, the argument will be passed to the mode's toggle
function.  For example, to disable @code{tool-bar-mode}, enable
@code{pixel-scroll-precision-mode}, and enable @code{fringe-mode} with the
argument @code{20}, you could use:

@lisp
'((tool-bar-mode . #f)
  (pixel-scroll-precision-mode . #t)
  (fringe-mode . 20))
@end lisp

@noindent.  Arguments given as lists and symbols are implicitly quoted.  Use
Elisp expressions (e.g., specified with the @code{elisp} form) or
G-expressions to specify arguments that should be evaluated at Emacs
initialization time."
   (sanitizer (alist-sanitizer modes
                               ((? symbol?) . (? elispifiable?)))))
  (keys
   (alist '())
   "An association list of key bindings for the Emacs global keymap.
Entries are pairs of key sequences and binding definitions.  Key sequences are
Emacs-specific string or vector representations of sequences of keystrokes or
events.  Strings should be valid arguments to the Emacs function @code{kbd},
and they are preferred over the low-level vector representations.  Here are
some examples of valid string values: @samp{\"C-c a\"}, @samp{\"M-RET\"},
@samp{\"M-<up>\"}, @samp{\"<remap> <foo>\"}, and
@samp{\"<t>\"} (@pxref{Keymaps,,, elisp,The Emacs Lisp Manual}).  Binding
definitions should be symbols for Emacs commands."
   (sanitizer (keys-field-sanitizer keys)))
  (keys-override
   (alist '())
   "An association list of key sequences and Emacs commands to bind in the
global override map.  These key bindings have a higher precedence than local
and global keybindings."
   (sanitizer (keys-field-sanitizer keys-override)))
  (extra-init
   (list-of-elisp-or-gexps '())
   "A list additional of Elisp expressions or G-expressions to serialize to
the Emacs user initialization file, the @file{init.el} file in the appropriate
Emacs configuration directory.  These expressions will occur in the serialized
file after those corresponding to the above fields."))

(define-configuration/no-serialization emacs-server
  (name
   (string)
   "A string naming the server.  Users will subsequently be able to start the
new server by using the command @code{herd start emacs-@var{name}}.  To create
Emacs client frames for the sever, users can use commands like:
@code{emacsclient --create-frame --socket-name=@var{name}}.

Because this string is meant for use in shell commands (and filenames), it
should not contain any characters other than letters and digits and the
characters @samp{-}, @samp{_}, and @samp{.}."
   (sanitizer
    (lambda (str)
      (cond
       ((not (string? str))
        (configuration-field-error #f 'name str))
       ((string-any (char-set-complement
                     (char-set-union char-set:letter+digit
                                     (char-set #\- #\_ #\.)))
                    str)
        (configuration-field-error #f 'name str))
       (else str)))))
  (inherit-directory?
   (boolean #t)
   "Whether the server should share its Emacs user directory with that of
the Emacs home service.  When false, the server will use a subdirectory
of the one used by the service for its own user directory.  When true
(the default), the @code{user-emacs-directory} Emacs variable for the server
will be set to that of the Emacs home service, but the server will still load
its own @file{early-init.el} and @file{init.el} files.  See the
@code{inherit-init?} and @code{inherit-configured-packages?}  fields for how
to inherit configuration from other Emacsen.")
  (inherit-init?
   (boolean #t)
   "Whether to load the default configuration used by the Emacs home service,
that is, the initialization expressions specified by the @code{default-init}
field of the @code{home-emacs-configuration} value for the service.  This is
loaded in addition to any configuration specified in the @code{default-init}
field for this specific server.

Note that if @code{inherit-directory?} is false, this also results in the
creation of duplicate copies in the Emacs user directory for the server of any
files specified by the @code{extra-files} field of the
@code{emacs-configuration} record for the @code{home-emacs-configuration} of
the service.  This ensures that any references to those files in the inherited
configuration expressions will not fail in unexpected ways.")
  (inherit-configured-packages?
   (boolean #t)
   "Whether to load configuration for packages used by the Emacs home service,
that is, the package configuration specified in the @code{configured-packages}
field of the @code{home-emacs-configuration} value for the service.  This is
loaded in addition to any configuration specified with the
@code{configured-packages} field for this specific server.

Note that if @code{inherit-directory?} is false, this also results in the
creation of duplicate copies in the Emacs user directory for the server of any
files specified by the @code{extra-files} fields of @code{emacs-package}
records from the @code{configured-packages} field of the
@code{home-emacs-configuration} of the service.")
  (load-custom?
   (boolean #t)
   "Whether to load customizations created with the Emacs customization
interface.  When @code{inherit-directory?} is true, customizations made within
this specific server affect the Emacs home service, and vice versa.
Otherwise, the server has its own separate set of customizations.")
  (extra-packages
   (list-of-file-likes '())
   "A list of extra packages or file-like objects to install, without
associated configuration.")
  (auto-start?
   (boolean #t)
   "Whether to start the server automatically.")
  (debug?
   (boolean #f)
   "Whether to enable the Emacs Lisp debugger for errors in the initialization
files of the server.")
  (shepherd-requirements
   (list-of-symbols '())
   "A list of symbols specifying Shepherd services that must be started before
the service for the Emacs server can be started (@pxref{Defining Services,,,
shepherd, The GNU Shepherd Manual}).")
  (default-init
    (emacs-configuration (emacs-configuration))
    "Configuration used to create initialization files specifically for this
server.")
  (configured-packages
   (list-of-emacs-packages '())
   "A list of @code{emacs-package} objects specifying Emacs packages to
install and configure in the Emacs user initialization file for the server."))

(define list-of-emacs-servers?
  (list-of emacs-server?))

\f
;;;
;;; Emacs package configuration serializers.
;;;

(define-configuration/no-serialization emacs-package-serializer
  (name
   (symbol)
   "A symbol identifying the serializer.")
  (procedure
   (procedure)
   "A procedure that takes two arguments, an @code{emacs-package} object and
the @code{package} object providing GNU Emacs for the Emacs home service, and
that should return a list of @code{elisp} objects or G-expressions containing
package-specific configuration to serialize to the Emacs user initialization
file.")
  (dependencies
   (alist '())
   "An association list of additional packages to install whenever this
serializer is used and predicates to determine whether to install them.  Each
predicate should be a procedure that accepts one argument, the @code{package}
object providing the GNU Emacs for the Emacs home service."
   (sanitizer (alist-sanitizer dependencies
                               ((? file-like?) . (? procedure?)))))
  (indent-forms
   (alist '())
   "An association list of symbols and indentation rules.  Each entry is of
the form (@var{symbol} .  @var{indent}), where @var{symbol} is a symbol and
@var{indent} is an integer.  Values have the same effect as the
@code{indent-forms} field in the @code{home-emacs-configuration} record.

 Note that indentation rules specified here will subsequently affect all Emacs
Lisp expressions serialized by the Emacs home service, not just
package-specific configuration."
   (sanitizer (alist-sanitizer indent-forms
                               ((? symbol?) . (? integer?)))))
  (description
   (string "")
   "A brief description of the serializer."))

(define (emacs-version-<29? emacs)
  "Return true if the version of EMACS, a `package' object, is less than 29,
and return false otherwise."
  (eq? (version-compare (package-version emacs) "29") '<))

(define (compose-load-predicates-lambda composer)
  "Return a lambda that composes multiple load predicates into a single
s-expression beginning with symbol COMPOSER."
  (match-lambda
    (() '())
    (lst
     (if (> (length lst) 1)
         `(,composer ,@lst)
         (first lst)))))

(define (emacs-package->simple-elisp config emacs)
  "Return from `emacs-package' object CONFIG a list containing Elisp
expressions that configure EMACS using only minimal built-in functionality."
  (let ((<29? (emacs-version-<29? emacs)))
    (define (load-path->sexp obj)
      `(add-to-list 'load-path ,obj))

    (define keys-global->sexp
      (match-lambda  (((? vector? k) . s)
                      `(global-set-key ,k ,(elispifiable->elisp s)))
                     (((? string? k) . s)
                      (if <29?
                          `(global-set-key (kbd ,k) ,(elispifiable->elisp s))
                          `(keymap-global-set ,k ,(elispifiable->elisp s))))))

    (define keys-override->sexp
      (match-lambda ((k . s)
                     `(bind-key* ,k ,(elispifiable->elisp s)))))

    (define (keys-local->sexp keymap)
      (match-record keymap <emacs-keymap>
                    (name
                     package-name
                     repeat?
                     repeat-exit
                     repeat-enter
                     disabled-commands
                     keys)
        (let ((keydefs (append
                        (map (match-lambda
                               (((? vector? k) . s)
                                `(define-key ,name ,k
                                   ,(elispifiable->elisp s)))
                               (((? string? k) . s)
                                (if <29?
                                    `(define-key ,name (kbd ,k)
                                       ,(elispifiable->elisp s))
                                    `(keymap-set ,name ,k
                                                 ,(elispifiable->elisp s)))))
                             keys))))
          (append
           (if repeat?
               (list `(progn
                       (defvar ,name
                         (make-sparse-keymap))
                       ,@keydefs
                       ,@(map (lambda (s)
                                `(put ',s 'repeat-map ',name))
                              (delete-duplicates
                               (append
                                (filter-map (match-lambda
                                              ((_ . s)
                                               (if (or (not s)
                                                       (memq s repeat-exit))
                                                   #f
                                                   s)))
                                            keys)
                                repeat-enter)
                               eq?))))
               (list `(if (boundp ',name)
                          (progn
                           ,@keydefs)
                          (with-eval-after-load
                           ',(if (not (null? package-name))
                                 package-name
                                 (emacs-package-name config))
                           ,@keydefs))))
           (map (match-lambda
                  ((command . val)
                   `(put ',command 'disabled ,val)))
                disabled-commands)))))

    (define option->sexp
      (match-lambda ((key . val)
                     (if <29?
                         `(setq ,key ,(elispifiable->elisp val))
                         `(setopt ,key ,(elispifiable->elisp val))))))

    (define face->sexp
      (match-lambda ((face . spec)
                     `(face-spec-set ',face ',spec))))

    (define hook->sexp
      (match-lambda ((hook . func)
                     (let* ((str (symbol->string hook))
                            (hook* (string->symbol
                                    (if (not (string-suffix? "-hook" str))
                                        (string-append str "-hook")
                                        str))))
                       `(add-hook ',hook* (function ,func))))))

    (define auto-mode->sexp
      (match-lambda ((pat . mode)
                     `(add-to-list 'auto-mode-alist '(,pat . ,mode)))))

    (define magic-mode->sexp
      (match-lambda ((pat . mode)
                     `(add-to-list 'magic-mode-alist '(,pat . ,mode)))))

    (match-record config <emacs-package>
                  (name
                   load-force?
                   load-predicates
                   load-after-packages
                   load-paths
                   autoloads
                   autoloads-interactive
                   keys-global
                   keys-global-keymaps
                   keys-override
                   keys-local
                   options
                   faces
                   hooks
                   auto-modes
                   magic-modes
                   extra-after-load
                   extra-init
                   extra-keywords)

      (define (autoload->sexp* obj interactive)
        `(autoload (function ,obj) ,(symbol->string name) #f ,interactive))

      (define autoload->sexp
        (cut autoload->sexp* <> #f))

      (define autoload-interactive->sexp
        (cut autoload->sexp* <> #t))

      (define keys-global-keymaps->sexp
        (match-lambda (((? vector? ks) . obj)
                       `(progn
                         (autoload ',obj
                                   ,(symbol->string name)
                                   #f #f 'keymap)
                         (global-set-key ,ks ,obj)))
                      (((? string? ks) . obj)
                       `(progn
                         (autoload ',obj
                                   ,(symbol->string name)
                                   #f #f 'keymap)
                         ,(if <29?
                              `(global-set-key (kbd ,ks) ,obj)
                              `(keymap-global-set ,ks ,obj))))))

      (define (load-after-packages->sexp load-after extra)
        (let loop ((load-after (reverse load-after))
                   (acc '()))
          (if (null? load-after)
              acc
              (loop (cdr load-after)
                    (cons 'with-eval-after-load
                          (cons (list 'quote (car load-after))
                                (if (null? acc)
                                    extra
                                    (list acc))))))))

      (let* ((load-predicates* (apply (compose-load-predicates-lambda 'and)
                                      (list load-predicates)))
             (load-after-packages* load-after-packages)
             (load-paths* (map load-path->sexp load-paths))
             (autoloads* (map autoload->sexp autoloads))
             (autoloads-interactive* (map autoload-interactive->sexp
                                          autoloads-interactive))
             (keys-global* (map keys-global->sexp keys-global))
             (keys-global-keymaps* (map keys-global-keymaps->sexp
                                        keys-global-keymaps))
             (keys-override* (map keys-override->sexp keys-override))
             (keys-local* (append-map keys-local->sexp keys-local))
             (options* (map option->sexp options))
             (faces* (map face->sexp faces))
             (hooks* (map hook->sexp hooks))
             (auto-modes* (map auto-mode->sexp auto-modes))
             (magic-modes* (map magic-mode->sexp magic-modes))
             (extra-after-load* (cond
                                 (load-force?
                                  (list
                                   `(if (not (require ',name nil t))
                                        (display-warning
                                         'initialization
                                         (format "Failed to load %s" ',name)
                                         :error)
                                        ,@extra-after-load)))
                                 ((not (null? extra-after-load))
                                  (list `(with-eval-after-load
                                          (quote ,name)
                                          ,@extra-after-load)))
                                 (else '())))
             (after-packages-sexps (append autoloads*
                                           autoloads-interactive*
                                           keys-global*
                                           keys-override*
                                           keys-global-keymaps*
                                           keys-local*
                                           options*
                                           faces*
                                           hooks*
                                           auto-modes*
                                           magic-modes*
                                           extra-after-load*
                                           extra-init))
             (combined-sexps (append load-paths*
                                     (if (null? load-after-packages*)
                                         after-packages-sexps
                                         (list (load-after-packages->sexp
                                                load-after-packages*
                                                after-packages-sexps)))))
             (comment-string (string-append ";;; Package "
                                            (symbol->string name)
                                            "\n")))
        (if (null? combined-sexps)
            '()
            (append
             (list (elisp (unelisp-comment comment-string)))
             (if (null? load-predicates*)
                 (map sexp->elisp combined-sexps)
                 (list (sexp->elisp `(when ,load-predicates*
                                       ,@combined-sexps))))))))))

(define %emacs-simple-package-serializer
  (emacs-package-serializer
   (name 'emacs-simple-package)
   (procedure emacs-package->simple-elisp)
   (description "An Emacs package configuration serializer that configures
Emacs using minimal, built-in Emacs mechanisms, instead of complex macros such
as @code{use-package}.")))

(define (emacs-package->use-package-elisp config emacs)
  "Return from `emacs-package' object CONFIG a list containing Elisp
expressions that configures EMACS using the `use-package' macro."

  (define-syntax unless-null
    (syntax-rules ()
      ((_ var exp)
       (if (null? var)
           '()
           exp))
      ((_ var)
       var)))

  (define (keys-local->sexp config)
    (match-record config <emacs-keymap>
                  (name repeat? repeat-exit keys)
      (cond
       ((null? keys) '())
       (repeat?
        (receive (exit rest)
            (partition (match-lambda
                         ((_ . binding)
                          (memq binding repeat-exit)))
                       keys)
          `(:repeat-map ,name
            ,@rest
            ,@(if (null? exit)
                  '()
                  `(:exit
                    ,(elisp (unelisp-newline))
                    ,@exit)))))
       (else `(:map ,name
               ,@keys)))))

  (define (keys-local->extra-sexps config)
    (match-record config <emacs-keymap>
                  (name repeat? repeat-enter disabled-commands keys)
      (append
       (if (and repeat?
                (not (null? keys)))
           (map
            (lambda (symbol)
              `(put ',symbol 'repeat-map ',name))
            repeat-enter)
           '())
       (map (match-lambda ((command . val)
                           `(put ',command 'disabled ,val)))
            disabled-commands))))

  (define option->sexp
    (match-lambda ((key . val)
                   `(,key ,(elispifiable->elisp val)))))

  (define face->sexp
    (match-lambda ((key . val)
                   `(,key ,val))))

  (define hook->sexp
    (match-lambda ((hook . func)
                   (let* ((str (symbol->string hook))
                          (hook* (string->symbol
                                  (if (string-suffix? "-hook" str)
                                      (string-drop-right str 5)
                                      str))))
                     `(,hook* . ,func)))))

  (define use-package-keywords '(#:after
                                 #:autoload
                                 #:bind
                                 #:bind*
                                 #:bind-keymap
                                 #:bind-keymap*
                                 #:catch
                                 #:commands
                                 #:config
                                 #:custom
                                 #:custom-face
                                 #:defer
                                 #:defines
                                 #:demand
                                 #:disabled
                                 #:functions
                                 #:hook
                                 #:if
                                 #:init
                                 #:interpreter
                                 #:load
                                 #:load-path
                                 #:magic
                                 #:magic-fallback
                                 #:mode
                                 #:no-require
                                 #:preface
                                 #:requires
                                 #:unless
                                 #:when))

  (define symbol->keyword*
    (match-lambda
      ((? symbol? kw)
       (let* ((str (symbol->string kw))
              (str* (if (string-prefix? ":" str)
                        (string-drop str 1)
                        str)))
         (symbol->keyword (string->symbol str*))))
      ((? keyword? kw)
       kw)))

  (define (use-package-keyword? obj)
    (memq (symbol->keyword* obj) use-package-keywords))

  (define extra-keyword->sexp
    (match-lambda
      (((? use-package-keyword? kw) . exps)
       `(,(symbol->keyword* kw) ,@exps))
      (_ #f)))

  (match-record config <emacs-package>
                (name
                 load-force?
                 load-predicates
                 load-after-packages
                 load-paths
                 autoloads
                 autoloads-interactive
                 keys-global
                 keys-global-keymaps
                 keys-override
                 keys-local
                 options
                 faces
                 hooks
                 auto-modes
                 magic-modes
                 extra-after-load
                 extra-init
                 extra-keywords)
    (let* ((load-predicates* (apply (compose-load-predicates-lambda 'and)
                                    (list load-predicates)))
           (load-after-packages* load-after-packages)
           (autoloads* autoloads)
           (autoloads-interactive* autoloads-interactive)
           (load-paths* load-paths)
           (keys-global+local (append keys-global
                                      (append-map keys-local->sexp
                                                  keys-local)))
           (keys-global-keymaps* keys-global-keymaps)
           (keys-override* keys-override)
           (options* (map option->sexp options))
           (faces* (map face->sexp faces))
           (hooks* (map hook->sexp hooks))
           (auto-modes* auto-modes)
           (magic-modes* magic-modes)
           (extra-after-load* extra-after-load)
           (extra-init* (append extra-init
                                (append-map keys-local->extra-sexps
                                            keys-local)))
           (extra-keywords* (apply append (filter-map extra-keyword->sexp
                                                      extra-keywords)))
           (comment-string (string-append ";;; Package "
                                          (symbol->string name)
                                          "\n"))
           (combined-sexps (append
                            (list
                             `(use-package
                               ,name
                               ,@(if load-force?
                                     '(:demand t)
                                     '(:defer t))
                               ,@(unless-null load-after-packages*
                                              `(:after ,load-after-packages*))
                               ,@(unless-null load-paths*
                                              `(:load-path ,load-paths*))
                               ,@(unless-null autoloads*
                                              `(:autoload ,autoloads*))
                               ,@(unless-null autoloads-interactive*
                                              `(:commands
                                                ,autoloads-interactive*))
                               ,@(unless-null keys-global+local
                                              `(:bind ,keys-global+local))
                               ,@(unless-null keys-override*
                                              `(#:bind* ,keys-override*))
                               ,@(unless-null keys-global-keymaps*
                                              `(:bind-keymap
                                                ,keys-global-keymaps*))
                               ,@(unless-null hooks*
                                              `(:hook ,hooks*))
                               ,@(unless-null auto-modes*
                                              `(:mode ,auto-modes*))
                               ,@(unless-null magic-modes*
                                              `(:magic ,magic-modes*))
                               ,@(unless-null faces*
                                              `(:custom-face
                                                ,@(append (list
                                                           (elisp
                                                            (unelisp-newline)))
                                                          faces*)))
                               ,@(unless-null options*
                                              `(:custom
                                                ,@(append (list
                                                           (elisp
                                                            (unelisp-newline)))
                                                          options*)))
                               ,@(unless-null extra-after-load*
                                              `(:config
                                                ,@(append (list
                                                           (elisp
                                                            (unelisp-newline)))
                                                          extra-after-load*)))
                               ,@extra-keywords*
                               ,@(unless-null extra-init*
                                              `(:init
                                                ,@(append (list
                                                           (elisp
                                                            (unelisp-newline)))
                                                          extra-init*))))))))
      (if (null? combined-sexps)
          '()
          (append
           (list (elisp (unelisp-comment comment-string)))
           (if (null? load-predicates*)
               (map sexp->elisp combined-sexps)
               (list (sexp->elisp `(when ,load-predicates*
                                     ,@combined-sexps)))))))))

(define %emacs-use-package-serializer
  (emacs-package-serializer
   (name 'emacs-use-package)
   (procedure emacs-package->use-package-elisp)
   (indent-forms '((use-package . 1)))
   (dependencies `((,emacs-use-package . ,emacs-version-<29?)))
   (description "An Emacs package configuration serializer that configures
Emacs with the @code{use-package} macro.")))

\f
;;;
;;; Emacs home service.
;;;

(define-configuration/no-serialization home-emacs-configuration
  (emacs
   (package %default-emacs)
   "The package providing the @file{/bin/emacs} command.")
  (user-emacs-directory
   (string "~/.config/emacs/")
   "Directory beneath which additional Emacs user files are placed.
By default, this is also the directory that contains the @file{init.el} and
@file{early-init.el} Emacs initialization files, but you can change this field
to specify any directory of your choosing; initialization files generated by
this service will still be loaded."
   (sanitizer
    (lambda (str)
      ;; Ensure that the path name ends with a '/', as some low-level Emacs
      ;; libraries use the value of `user-emacs-directory' with this
      ;; expectation.
      (cond
       ((not (string? str))
        (configuration-field-error #f 'user-emacs-directory str))
       ((not (string-suffix? "/" str))
        (string-append str "/"))
       (else str)))))
  (native-compile?
   (boolean #t)
   "Whether to enable native-compilation of Emacs packages by building them
with the Emacs specified by the @code{emacs} field rather than
@code{emacs-minimal}.")
  (load-custom?
   (boolean #t)
   "Whether to load customizations created with the Emacs customization
interface.  Because all configuration files created by this service are
effectively read-only, the service modifies the default behavior of Emacs so
that customizations are always saved in a separate @file{custom.el} file,
which will be loaded when Emacs is initialized if this field is true.")
  (extra-packages
   (list-of-file-likes '())
   "A list of additional Emacs-related packages or file-like objects to
install.  If a package is specified in @code{configured-packages}, it does not
need to be specified here.")
  (package-serializer
   (emacs-package-serializer %emacs-simple-package-serializer)
   "The serializer to use for configuration specified by @code{emacs-package}
objects.")
  (indent-forms
   (alist '())
   "An association list of symbols and indentation rules.  Each entry is of
the form (@var{symbol} .  @var{indent}), where @var{symbol} is a symbol and
@var{indent} is an integer.

When @var{symbol} occurs at the beginning of a list in an Emacs Lisp file, the
first @var{indent} expressions are indented as arguments and the remainder as
body expressions, as if @var{indent} was supplied as the
@code{lisp-indent-function} symbol property for @var{symbol} in Emacs.
Argument expressions are either printed on the same line as @var{symbol} or
indented 4 columns beyond the base indentation of the enclosing list, and body
expressions are indented 2 columns beyond the base indentation."
   (sanitizer (alist-sanitizer indent-forms
                               ((? symbol?) . (? integer?)))))
  (propagated-init
   (list-of-elisp-or-gexps '())
   "A list of Elisp expressions or G-expressions that should be evaluated by
all Emacsen during initialization, including servers.  These expressions are
serialized to the beginning of the Emacs user initialization file.")
  (default-init
    (emacs-configuration (emacs-configuration))
    "General configuration used to create Emacs initialization files.  Emacsen
will use this configuration by default, in addition to any package-specific
configuration specified in the @code{configured-packages} field and any
appropriate configuration for specific servers.")
  (configured-packages
   (list-of-emacs-packages '())
   "A list of Emacs-related packages to install and associated configuration
for the Emacs user initialization file.  @code{emacs-package} objects
encapsulate lists of packages to install along with relevant configuration.")
  (servers
   (list-of-emacs-servers '())
   "A list of configurations for Emacs servers."))

(define-configuration/no-serialization home-emacs-extension
  (extra-packages
   (list-of-file-likes '())
   "A list of additional Emacs-related packages or file-like objects to
install.  If a package is specified in @code{configured-packages}, it does not
need to be specified here.")
  (indent-forms
   (alist '())
   "An association list of symbols and indentation rules.  Each entry is of
the form (SYMBOL . INDENT), where SYMBOL is a symbol and INDENT is an integer
specifying the number of argument expressions for SYMBOL."
   (sanitizer (alist-sanitizer indent-forms
                               ((? symbol?) . (? integer?)))))
  (servers
   (list-of-emacs-servers '())
   "A list of configurations for Emacs servers.  It is an error to specify
multiple @code{emacs-server} objects with equivalent @code{name} fields.")
  (default-init
    (emacs-configuration (emacs-configuration))
    "General configuration used to create the Emacs initialization files.
Emacsen will use this configuration by default, in addition to any
package-specific configuration specified in the @code{configured-packages}
field and any relevant configuration for specific servers.")
  (configured-packages
   (list-of-emacs-packages '())
   "A list of Emacs-related packages and associated configuration for the
Emacs user initialization file.  Configuration for multiple
@code{emacs-package} objects with equivalent @code{name} fields is merged when
possible; an error is signaled otherwise."))

(define (extend-emacs-configuration original extensions)
  "Extend an `emacs-configuration' record ORIGINAL with list of records
EXTENSIONS."
  (extend-record
   emacs-configuration
   original extensions
   (extend-list early-init early-init)
   (extend-alist-merge extra-init-files extra-init-files)
   (extend-alist-merge extra-files extra-files)
   (extend-list variables variables)
   (extend-list modes modes)
   (extend-list keys keys)
   (extend-list keys-override keys-override)
   (extend-list extra-init extra-init)))

(define %default-emacs-package-configuration (emacs-package))
(define %default-emacs-keymap-configuration (emacs-keymap))

(define (extend-emacs-package original extensions)
  "Extend an `emacs-package' record ORIGINAL with list of records
EXTENSIONS."
  (define extend-package-field
    (cut extend-record-field-default <> <>
         %default-emacs-package-configuration 'package))

  (define extend-install?-field
    (cut extend-record-field-default <> <>
         %default-emacs-package-configuration 'install?))

  (define extend-load-force?-field
    (cut extend-record-field-default <> <>
         %default-emacs-package-configuration 'load-force?))

  (define extend-package-name-field
    (cut extend-record-field-default <> <>
         %default-emacs-keymap-configuration 'package-name))

  (define extend-repeat?-field
    (cut extend-record-field-default <> <>
         %default-emacs-keymap-configuration 'repeat?))

  (define (extend-emacs-keymap original extensions)
    (extend-record
     emacs-keymap
     original extensions
     (extend-package-name-field package-name package-name)
     (extend-repeat?-field repeat? repeat?)
     (extend-list-merge repeat-exit repeat-exit)
     (extend-list-merge repeat-enter repeat-enter)
     (extend-list disabled-commands disabled-commands)
     (extend-list keys keys)))

  (define (extend-keys-local-field original extensions)
    (extend-record-list-merge original extensions
                              'name extend-emacs-keymap))

  (extend-record
   emacs-package
   original extensions
   (extend-package-field package package)
   (extend-list-merge extra-packages extra-packages)
   (extend-alist-merge extra-files extra-files)
   (extend-install?-field install? install?)
   (extend-load-force?-field load-force? load-force?)
   (extend-list load-predicates load-predicates)
   (extend-list-merge load-after-packages load-after-packages)
   (extend-list-merge load-paths load-paths)
   (extend-list-merge autoloads autoloads)
   (extend-list-merge autoloads-interactive autoloads-interactive)
   (extend-list keys-global keys-global)
   (extend-list keys-global-keymaps keys-global-keymaps)
   (extend-list keys-override keys-override)
   (extend-keys-local-field keys-local keys-local)
   (extend-list options options)
   (extend-list faces faces)
   (extend-list hooks hooks)
   (extend-list auto-modes auto-modes)
   (extend-list magic-modes magic-modes)
   (extend-list extra-after-load extra-after-load)
   (extend-list extra-init extra-init)
   (extend-alist-merge extra-keywords extra-keywords)))

(define (extend-emacs-package-list original extensions)
  "Extend a list of `emacs-package' records ORIGINAL with list of lists
EXTENSIONS by merging records with equivalent `name' fields.  Records with a
non-null `load-predicates' field will not be merged."
  (define (emacs-package-no-predicates? config)
    (match-record config <emacs-package>
                  (load-predicates)
      (null? load-predicates)))

  (extend-record-list-merge original extensions
                            'name extend-emacs-package
                            #:type? emacs-package-no-predicates?))

(define (server-name->file-name name)
  "Return the full name for server NAME as a filename."
  (string-append "emacs-" (string-delete (char-set #\/ #\nul)
                                         name)))

(define (emacs-server->provision config)
  "Return the provision symbol for the Shepherd service created for
@code{emacs-server} object CONFIG."
  (match-record config <emacs-server>
                (name)
    (string->symbol (server-name->file-name name))))

(define (server-user-directory name user-emacs-directory inherit-directory?)
  "Return the location of the Emacs user directory for server NAME based on
INHERIT-DIRECTORY? and the USER-EMACS-DIRECTORY from the Emacs home service."
  (if inherit-directory?
      user-emacs-directory
      (string-append (file-name-concat
                      user-emacs-directory
                      (server-name->file-name name))
                     "/")))

(define (home-emacs-packages config)
  "Return a list of file-like objects to install from CONFIG."

  (define (rewrite-for-native-compile emacs)
    (package-input-rewriting
     `((,emacs-minimal . ,emacs))))

  (define (package-serializer-dependencies config emacs)
    (match-record config <emacs-package-serializer>
                  (dependencies)
      (filter-map (match-lambda
                    ((dep . pred)
                     (and (apply pred (list emacs))
                          dep)))
                  dependencies)))

  (define (emacs-package->installable-packages config)
    (match-record config <emacs-package>
                  (package extra-packages install?)
      (if install?
          (append (if (null? package)
                      '()
                      (list package))
                  extra-packages)
          '())))

  (define (server->installable-packages config)
    (match-record config <emacs-server>
                  (configured-packages extra-packages)
      (append
       (append-map emacs-package->installable-packages configured-packages)
       extra-packages)))

  (match-record config <home-emacs-configuration>
                (emacs
                 native-compile?
                 configured-packages
                 extra-packages
                 package-serializer
                 servers)
    (let ((packages (delete-duplicates
                     (append
                      (package-serializer-dependencies package-serializer
                                                       emacs)
                      (append-map emacs-package->installable-packages
                                  configured-packages)
                      extra-packages
                      (append-map server->installable-packages servers))
                     eq?)))
      (append (list emacs)
              (if native-compile?
                  (map (rewrite-for-native-compile emacs) packages)
                  packages)))))

(define (home-emacs-shepherd-services config)
  "Return a list of Shepherd services for CONFIG."
  (match-record config <home-emacs-configuration>
                (emacs user-emacs-directory servers)
    (map
     (lambda (server)
       (match-record server <emacs-server>
                     (name
                      inherit-directory?
                      auto-start?
                      debug?
                      shepherd-requirements)
         (let ((server-init-dir (file-name-concat
                                 %default-emacs-config-dir
                                 (server-name->file-name name)))
               (server-user-dir (server-user-directory name
                                                       user-emacs-directory
                                                       inherit-directory?)))
           (shepherd-service
            (provision (list (emacs-server->provision server)))
            (requirement shepherd-requirements)
            (start
             #~(make-forkexec-constructor
                (list #$(file-append emacs "/bin/emacs")
                      #$(string-append "--init-directory=" server-init-dir)
                      #$(string-append "--fg-daemon=" name)
                      #$@(if debug?
                             (list "--debug-init")
                             '()))
                #:log-file
                #$(file-name-concat server-user-dir
                                    (string-append
                                     (server-name->file-name name) ".log"))))
            (stop
             #~(make-forkexec-constructor
                (list #$(file-append emacs "/bin/emacsclient")
                      "-s" #$name "--eval" "(kill-emacs)")))
            (actions (list
                      (shepherd-configuration-action
                       (file-name-concat server-init-dir
                                         %emacs-user-init-filename))))
            (auto-start? auto-start?)
            (documentation
             (string-append "Start the Emacs server called "
                            name "."))))))
     servers)))

(define (home-emacs-xdg-configuration-files config)
  "Return from CONFIG an association list of filenames and file-like objects
to create in XDG_CONFIG_HOME."

  (define emacs-config-filename
    (cut file-name-concat "emacs" <>))

  (define (elisp-file-with-forms name exps)
    (elisp-file name exps
                #:special-forms (append
                                 (home-emacs-configuration-indent-forms config)
                                 (emacs-package-serializer-indent-forms
                                  (home-emacs-configuration-package-serializer
                                   config)))))

  (define config-emacs (home-emacs-configuration-emacs config))

  (define config-package-serializer-procedure
    (emacs-package-serializer-procedure
     (home-emacs-configuration-package-serializer config)))

  (define config-user-emacs-directory
    (home-emacs-configuration-user-emacs-directory config))

  (define (set-user-emacs-directory-sexps directory)
    (list `(setq user-emacs-directory ,directory)
          ;; Variables set before early init file is loaded that rely upon the
          ;; value of `user-emacs-directory':
          ;; XXX: `native-comp-eln-load-path' is properly set in startup.el to
          ;; reflect the new `user-emacs-directory', but this means that
          ;; servers which use their own `user-emacs-directory' get their own
          ;; eln cache.
          '(custom-reevaluate-setting 'auto-save-list-file-prefix)
          '(custom-reevaluate-setting 'package-user-dir)
          '(custom-reevaluate-setting 'package-quickstart-file)
          '(custom-reevaluate-setting 'abbrev-file-name)
          '(custom-reevaluate-setting 'custom-theme-directory)))

  (define (load-custom?-sexps load-custom?)
    ;; 'locate-user-emacs-file' also ensures that `user-emacs-directory'
    ;; exists, creating it with the proper permissions if needed.
    (list '(setq custom-file (locate-user-emacs-file "custom.el"))
          (if load-custom?
              '(if (not (file-exists-p custom-file))
                   (make-empty-file custom-file)
                   (load custom-file))
              '(when (not (file-exists-p custom-file))
                 (make-empty-file custom-file)))
          (elisp (unelisp-newline))))

  (define early-init-sexps
    (cut emacs-configuration-early-init <>))

  (define (default-init-sexps config)
    (let ((<29? (emacs-version-<29? config-emacs)))
      (match-record config <emacs-configuration>
                    (variables modes keys keys-override)
        (let ((result (append
                       (map
                        (match-lambda
                          ((var . val)
                           (if <29?
                               `(setq ,var ,(elispifiable->elisp val))
                               `(setopt ,var ,(elispifiable->elisp val)))))
                        variables)
                       (map
                        (match-lambda
                          ((mode . #t)
                           `(,mode 1))
                          ((mode . #f)
                           `(,mode -1))
                          ((mode . arg)
                           `(,mode ,(elispifiable->elisp arg))))
                        modes)
                       (map
                        (match-lambda
                          (((? vector? k) . s)
                           `(global-set-key ,k ',s))
                          (((? string? k) . s)
                           (if <29?
                               `(global-set-key (kbd ,k)
                                                ,(elispifiable->elisp s))
                               `(keymap-global-set ,k
                                                   ,(elispifiable->elisp s)))))
                        keys)
                       (map
                        (match-lambda
                          ((k . s)
                           `(bind-key* ,k ,(elispifiable->elisp s))))
                        keys-override))))
          (if (null? result)
              '()
              (append result
                      (list (elisp (unelisp-newline)))))))))

  (define (default-init-extra-sexps config)
    (match-record config <emacs-configuration>
                  (extra-init)
      (interpose extra-init
                 (elisp (unelisp-newline))
                 'suffix)))

  (define (configured-packages-sexps configs)
    (append-map (lambda (config)
                  (append (apply config-package-serializer-procedure
                                 (list config config-emacs))
                          (list (elisp (unelisp-newline)))))
                configs))

  (define* (extra-init-files-sexps config #:optional subdirectory)
    (let* ((directory (if subdirectory
                          (file-name-concat %default-emacs-config-dir
                                            "emacs"
                                            subdirectory)
                          (file-name-concat %default-emacs-config-dir
                                            "emacs")))
           (result (map
                    (match-lambda
                      ((name . _)
                       `(load ,(file-name-concat directory name)
                              #f #f #t)))
                    (emacs-configuration-extra-init-files config))))
      (if (null? result)
          '()
          (append result
                  (list (elisp (unelisp-newline)))))))

  (define* (extra-init-file->config-file-entry entry
                                               #:optional subdirectory)
    (match entry
      ((name . files)
       (list (emacs-config-filename (if subdirectory
                                        (file-name-concat subdirectory name)
                                        name))
             (apply composite-file (basename name) (ensure-list files))))))

  (define (server->config-file-entries server
                                       propagated-init
                                       inherit-extra-init-files
                                       inherit-default-init
                                       inherit-configured-packages)
    (match-record server <emacs-server>
                  (name
                   inherit-init?
                   inherit-directory?
                   inherit-configured-packages?
                   load-custom?
                   configured-packages
                   default-init)
      (let* ((server-dir (server-name->file-name name))
             (extra-init-files* (extra-init-files-sexps default-init
                                                        server-dir))
             (default-init* (if inherit-init?
                                (extend-emacs-configuration
                                 inherit-default-init
                                 (list default-init))
                                default-init))
             (configured-packages* (if inherit-configured-packages?
                                       (extend-emacs-package-list
                                        inherit-configured-packages
                                        (list configured-packages))
                                       configured-packages)))
        (append
         (list
          (list (emacs-config-filename
                 (file-name-concat server-dir
                                   %emacs-early-init-filename))
                (elisp-file-with-forms %emacs-early-init-filename
                                       (append
                                        (set-user-emacs-directory-sexps
                                         (server-user-directory
                                          name
                                          config-user-emacs-directory
                                          inherit-directory?))
                                        (early-init-sexps default-init))))
          (list (emacs-config-filename
                 (file-name-concat server-dir
                                   %emacs-user-init-filename))
                (elisp-file-with-forms %emacs-user-init-filename
                                       (append
                                        propagated-init
                                        (load-custom?-sexps load-custom?)
                                        (if inherit-init?
                                            inherit-extra-init-files
                                            '())
                                        extra-init-files*
                                        (default-init-sexps default-init*)
                                        (configured-packages-sexps
                                         configured-packages*)
                                        (default-init-extra-sexps
                                          default-init*)))))
         (map (cut extra-init-file->config-file-entry <> server-dir)
              (emacs-configuration-extra-init-files default-init))))))

  (match-record config <home-emacs-configuration>
                (user-emacs-directory
                 load-custom?
                 configured-packages
                 propagated-init
                 servers
                 default-init)
    (let ((propagated-init* (if (null? propagated-init)
                                '()
                                (append propagated-init
                                        (list (elisp (unelisp-newline))))))
          (extra-init-files* (extra-init-files-sexps default-init))
          (default-init* (default-init-sexps default-init))
          (configured-packages* (configured-packages-sexps
                                 configured-packages))
          (extra-init* (default-init-extra-sexps default-init)))
      (append
       (list (list (emacs-config-filename %emacs-early-init-filename)
                   (elisp-file-with-forms %emacs-early-init-filename
                                          (append
                                           (set-user-emacs-directory-sexps
                                            user-emacs-directory)
                                           (early-init-sexps default-init))))
             (list (emacs-config-filename %emacs-user-init-filename)
                   (elisp-file-with-forms %emacs-user-init-filename
                                          (append
                                           propagated-init*
                                           (load-custom?-sexps load-custom?)
                                           extra-init-files*
                                           default-init*
                                           configured-packages*
                                           extra-init*))))
       (append-map (cut server->config-file-entries <>
                        propagated-init*
                        extra-init-files*
                        default-init
                        configured-packages)
                   servers)
       (map extra-init-file->config-file-entry
            (emacs-configuration-extra-init-files default-init))))))

(define (home-emacs-files config)
  "Return from CONFIG an association list of filenames and file-like objects
to create in the Emacs user directory."

  (define file-name-with-home (make-regexp "^(~/|/home/[^/]+/)(.+)$"))

  (define (file-name->home-file-name filename)
    (or (and=> (regexp-exec file-name-with-home
                            filename)
               (cut match:substring <> 2))
        filename))

  (define (extra-file->home-files-entry entry directory)
    (match entry
      ((name . files)
       (list (file-name-concat directory name)
             (apply composite-file (basename name) (ensure-list files))))))

  (define (package->home-files-entries package directory)
    (match-record package <emacs-package>
                  (extra-files)
      (map (cut extra-file->home-files-entry <> directory)
           extra-files)))

  (define (server->home-files-entries server directory)
    (match-record server <emacs-server>
                  (name
                   inherit-directory?
                   inherit-init?
                   inherit-configured-packages?
                   default-init
                   configured-packages)
      (let ((server-dir (server-user-directory name
                                               directory
                                               inherit-directory?)))
        (append (map (cut extra-file->home-files-entry <> server-dir)
                     (append (emacs-configuration-extra-files default-init)
                             (if (and inherit-init?
                                      (not inherit-directory?))
                                 (emacs-configuration-extra-files
                                  (home-emacs-configuration-default-init
                                   config))
                                 '())))
                (append-map (cut package->home-files-entries <> server-dir)
                            (append
                             configured-packages
                             (if (and inherit-configured-packages?
                                      (not inherit-directory?))
                                 (home-emacs-configuration-configured-packages
                                  config)
                                 '())))))))

  (match-record config <home-emacs-configuration>
                (user-emacs-directory
                 servers
                 default-init
                 configured-packages)
    (let ((user-emacs-directory* (file-name->home-file-name
                                  user-emacs-directory)))
      (append
       (map (cut extra-file->home-files-entry <> user-emacs-directory*)
            (emacs-configuration-extra-files default-init))
       (append-map (cut package->home-files-entries <> user-emacs-directory*)
                   configured-packages)
       (append-map (cut server->home-files-entries <> user-emacs-directory*)
                   servers)))))

(define (home-emacs-extensions original-config extension-configs)
  "Extend the Emacs home service configuration ORIGINAL-CONFIG with list of
configurations EXTENSION-CONFIGS."

  (define (extend-configured-packages-field original extensions)
    (extend-emacs-package-list original extensions))

  (define (extend-servers-field original extensions)
    ;; Extend `emacs-servers', signaling an error if any two servers have the
    ;; same name.
    (fold-right (lambda (elem ret)
                  (if (find (lambda (e)
                              (equal? (record-value e 'name)
                                      (record-value elem 'name)))
                            ret)
                      (configuration-field-error #f 'name elem)
                      (cons elem ret)))
                '()
                (apply append original extensions)))

  (extend-record
   home-emacs-configuration
   original-config extension-configs
   (extend-list-merge extra-packages extra-packages)
   (extend-list-merge indent-forms indent-forms)
   (extend-servers-field servers servers)
   (extend-emacs-configuration default-init default-init)
   (extend-configured-packages-field configured-packages configured-packages)))

(define home-emacs-service-type
  (service-type (name 'home-emacs-service)
                (extensions
                 (list (service-extension
                        home-profile-service-type
                        home-emacs-packages)
                       (service-extension
                        home-shepherd-service-type
                        home-emacs-shepherd-services)
                       (service-extension
                        home-xdg-configuration-files-service-type
                        home-emacs-xdg-configuration-files)
                       (service-extension
                        home-files-service-type
                        home-emacs-files)))
                (default-value (home-emacs-configuration))
                (compose identity)
                (extend home-emacs-extensions)
                (description
                 "Configure and run the GNU Emacs extensible text editor.")))

\f
;;;
;;; Utility functions.
;;;

(define (schemified-elisp->home-emacs-configuration lst)
  "Convert LST, a list of s-expressions, into a `home-emacs-configuration'
record."

  (define elisp->scheme
    (match-lambda
      ('t
       #t)
      ('nil
       #f)
      ((? constant? obj)
       obj)
      (('quote obj)
       obj)
      (obj
       (elisp (unelisp obj)))))

  (define (variable-specs->alist specs)
    (let lp ((specs specs)
             (acc '()))
      (match specs
        (()
         (reverse! acc))
        (((? blank?) . rest)
         (lp rest acc))
        ((var val . rest)
         (lp rest (cons (cons var (elisp->scheme val))
                        acc)))
        (_
         (raise (formatted-message (G_ "invalid `setq'/`setopt' in file")))))))

  (define mode-toggle-function?
    (match-lambda
      ((? symbol? obj)
       (string-suffix? "-mode" (symbol->string obj)))
      (_ #f)))

  (define (use-package->emacs-package name body)

    (define elisp-keyword?
      (match-lambda
        ((? symbol? obj)
         (string-prefix? ":" (symbol->string obj)))
        (_ #f)))

    (define dotted-pair?
      (match-lambda
        ((head . (not (? pair?)))
         #t)
        (_ #f)))

    (define list-of-dotted-pairs?
      (list-of dotted-pair?))

    (let lp ((lst body)
             (package (emacs-package (name name))))
      (match lst
        (()
         package)
        (((? elisp-keyword? kw) . rest)
         (receive (args rest)
             (break elisp-keyword? rest)
           (match kw
             (':demand
              (lp rest
                  (emacs-package
                   (inherit package)
                   (load-force? (match (remove blank? args)
                                  ('nil #f)
                                  (_ #t))))))
             ((or ':if ':when)
              (lp rest
                  (emacs-package
                   (inherit package)
                   (load-predicates (append (emacs-package-load-predicates
                                             package)
                                            (match (remove blank? args)
                                              ((exp)
                                               (list (elisp (unelisp exp))))
                                              (_ '())))))))
             (':unless
              (lp rest
                  (emacs-package
                   (inherit package)
                   (load-predicates (append (emacs-package-load-predicates
                                             package)
                                            (match (remove blank? args)
                                              ((exp)
                                               (list (elisp (not
                                                             (unelisp exp)))))
                                              (_ '())))))))
             (':after
              (lp rest
                  (emacs-package
                   (inherit package)
                   (load-after-packages (append
                                         (emacs-package-load-after-packages
                                          package)
                                         (match (remove blank? args)
                                           (((':all
                                              . (? list-of-symbols? lst)))
                                            lst)
                                           (((':any . rest))
                                            ;; Ignore, because we can't
                                            ;; guarantee equivalent behavior.
                                            '())
                                           ((? list-of-symbols? lst)
                                            args)
                                           (((? list-of-symbols? lst))
                                            lst)
                                           (_ '())))))))
             (':load-path
              (lp rest
                  (emacs-package
                   (inherit package)
                   (load-paths (append (emacs-package-load-paths package)
                                       (filter string?
                                               (match args
                                                 (((? list? lst))
                                                  lst)
                                                 ((? list? lst)
                                                  lst)
                                                 (_ '()))))))))
             (':autoload
              (lp rest
                  (emacs-package
                   (inherit package)
                   (autoloads (append (emacs-package-autoloads package)
                                      (match (remove blank? args)
                                        ((? list-of-symbols? lst)
                                         lst)
                                        (((? list-of-symbols? lst))
                                         lst)
                                        (_ '())))))))
             (':commands
              (lp rest
                  (emacs-package
                   (inherit package)
                   (autoloads-interactive (append
                                           (emacs-package-autoloads-interactive
                                            package)
                                           (match (remove blank? args)
                                             ((? list-of-symbols? lst)
                                              lst)
                                             (((? list-of-symbols? lst))
                                              lst)
                                             (_ '())))))))
             (':bind*
              (lp rest
                  (emacs-package
                   (inherit package)
                   (keys-override (append (emacs-package-keys-override package)
                                          (filter dotted-pair?
                                                  (match args
                                                    (((? list? lst))
                                                     lst)
                                                    (_ args))))))))
             (':bind
              (receive (global local)
                  (break elisp-keyword? (match args
                                          (((? list? lst))
                                           lst)
                                          (_ args)))
                (lp rest
                    (emacs-package
                     (inherit package)
                     (keys-global (append (emacs-package-keys-global package)
                                          (filter dotted-pair? global)))
                     (keys-local
                      (append
                       (emacs-package-keys-local package)
                       (let lp/inner ((lst (remove blank? local))
                                      (keymaps '()))
                         (match lst
                           ((':map (? symbol? kmap) . rest)
                            (receive (kspecs rest)
                                (break (cut memq <> '(:map :repeat-map))
                                       rest)
                              (lp/inner rest
                                        (append
                                         keymaps
                                         (list (emacs-keymap
                                                (name kmap)
                                                (keys (filter dotted-pair?
                                                              kspecs))))))))
                           ((':repeat-map (? symbol? kmap) . rest)
                            (receive (kspecs rest)
                                (break (cut memq <> '(:map :repeat-map))
                                       rest)
                              (lp/inner rest
                                        (append
                                         keymaps
                                         (list
                                          (emacs-keymap
                                           (name kmap)
                                           (repeat? #t)
                                           (repeat-exit
                                            (filter-map
                                             (match-lambda
                                               (((? string-or-vector?)
                                                 . (? symbol? sym))
                                                sym)
                                               (_ #f))
                                             (take-while
                                              (negate (cut eq? <>
                                                           ':continue))
                                              (drop-while
                                               (negate (cut eq? <>
                                                            ':exit))
                                               kspecs))))
                                           (keys (filter dotted-pair?
                                                         kspecs))))))))
                           (_ keymaps)))))))))
             (':bind-keymap
              (lp rest
                  (emacs-package
                   (inherit package)
                   (keys-global-keymaps (append
                                         (emacs-package-keys-global-keymaps
                                          package)
                                         (filter dotted-pair?
                                                 (match args
                                                   (((? list? lst))
                                                    lst)
                                                   (_ args))))))))
             (':custom
              (lp rest
                  (emacs-package
                   (inherit package)
                   (options (append (emacs-package-options package)
                                    (filter-map
                                     (match-lambda
                                       ((var val . rest)
                                        `(,var . ,(elisp->scheme val)))
                                       (_ #f))
                                     (match args
                                       (((and ((? list?) . rest) lst))
                                        ;; :custom ((foo bar))
                                        lst)
                                       (_ args))))))))
             (':custom-face
              (lp rest
                  (emacs-package
                   (inherit package)
                   (faces (append (emacs-package-faces package)
                                  (filter-map (match-lambda
                                                (((? symbol? face)
                                                  ((? pair? spec) ..1))
                                                 `(,face . ,spec))
                                                (_ #f))
                                              args))))))
             (':hook
              (lp rest
                  (emacs-package
                   (inherit package)
                   (hooks (append (emacs-package-hooks package)
                                  (match args
                                    ((((? list-of-symbols? hooks)
                                       . (? symbol? func)))
                                     (map (cut cons <> func)
                                          hooks))
                                    (((? list-of-dotted-pairs? lst))
                                     (filter-map (match-lambda
                                                   (((? symbol? hook)
                                                     . (? symbol? func))
                                                    (cons hook func))
                                                   (_ #f))
                                                 lst))
                                    ((or (? list-of-symbols? hooks)
                                         ((? list-of-symbols? hooks)))
                                     (map
                                      (cute cons <>
                                            (symbol-append name '-mode))
                                      hooks))
                                    (_ '())))))))
             (':mode
              (lp rest
                  (emacs-package
                   (inherit package)
                   (auto-modes (append (emacs-package-auto-modes package)
                                       (match args
                                         ((or ((? string? strings) ..1)
                                              (((? string? strings) ..1)))
                                          (map (cut cons <> name)
                                               strings))
                                         ((or ((? list-of-dotted-pairs? lst))
                                              (? list-of-dotted-pairs? lst))
                                          (filter
                                           (match-lambda
                                             (((? string?) . (? symbol?))
                                              #t)
                                             (_ #f))
                                           lst))
                                         (_ '())))))))
             (':magic
              (lp rest
                  (emacs-package
                   (inherit package)
                   (magic-modes (append (emacs-package-magic-modes package)
                                        (match args
                                          ((or ((? string? strings) ..1)
                                               (((? string? strings) ..1)))
                                           (map (cut cons <> name)
                                                strings))
                                          ((or ((? list-of-dotted-pairs? lst))
                                               (? list-of-dotted-pairs? lst))
                                           (filter
                                            (match-lambda
                                              (((? string?) . (? symbol?))
                                               #t)
                                              (_ #f))
                                            lst))
                                          (_ '())))))))
             (':config
              (lp rest
                  (emacs-package
                   (inherit package)
                   (extra-after-load (append (emacs-package-extra-after-load
                                              package)
                                             (map sexp->elisp
                                                  args))))))
             (':init
              (lp rest
                  (emacs-package
                   (inherit package)
                   (extra-init (append (emacs-package-extra-init package)
                                       (map sexp->elisp
                                            args))))))
             (kw
              (lp rest
                  (emacs-package
                   (inherit package)
                   (extra-keywords (append (emacs-package-extra-keywords
                                            package)
                                           (list
                                            `(,kw . ,(map sexp->elisp
                                                          args)))))))))))
        (((? blank?) . rest)
         (lp rest package))
        (_ (raise (formatted-message
                   (G_ "invalid `use-package' form in file")))))))

  (let loop ((lst lst)
             (init (emacs-configuration))
             (packages '()))
    (match lst
      (()
       (home-emacs-configuration
        (configured-packages packages)
        (default-init init)))
      ((((or 'setq 'setopt) . specs) . rest)
       (loop rest
             (emacs-configuration
              (inherit init)
              (variables (append (emacs-configuration-variables init)
                                 (variable-specs->alist specs))))
             packages))
      ((((? mode-toggle-function? mode) . arg) . rest)
       (loop rest
             (emacs-configuration
              (inherit init)
              (modes (append (emacs-configuration-modes init)
                             (list (cons mode
                                         (match arg
                                           ((1)
                                            #t)
                                           (()
                                            #t)
                                           ((-1)
                                            #f)
                                           (((? blank?))
                                            #t)
                                           ((obj)
                                            (elisp->scheme obj))))))))
             packages))
      ((`(bind-key* ,(? string-or-vector? key)
                    (,(or 'quote 'function) ,(? symbol? def)) . ,_)
        . rest)
       (loop rest
             (emacs-configuration
              (inherit init)
              (keys-override (append (emacs-configuration-keys-override init)
                                     (list (cons key def)))))
             packages))
      (((or `(global-set-key ,(? vector? key)
                             (,(or 'quote 'function) ,(? symbol? def))
                             . ,_)
            `(global-set-key (kbd ,(? string? key))
                             (,(or 'quote 'function) ,(? symbol? def))
                             . ,_)
            `(keymap-global-set ,(? string? key)
                                (,(or 'quote 'function) ,(? symbol? def)))
            `(bind-key ,(? string-or-vector? key)
                       (,(or 'quote 'function) ,(? symbol? def)))
            `(bind-key ,(? string-or-vector? key)
                       (,(or 'quote 'function) ,(? symbol? def))
                       ,(or `(quote global-map)
                            'global-map)
                       . ,_)) . rest)
       (loop rest
             (emacs-configuration
              (inherit init)
              (keys (append (emacs-configuration-keys init)
                            (list (cons key def)))))
             packages))
      ((`(use-package ,(? symbol? package) . ,body) . rest)
       (loop rest
             init
             (append packages
                     (list (use-package->emacs-package package body)))))
      (((? blank?) . rest)
       (loop rest
             init
             packages))
      ((exp . rest)
       (loop rest
             (emacs-configuration
              (inherit init)
              (extra-init (append (emacs-configuration-extra-init init)
                                  (list (elisp (unelisp exp))))))
             packages)))))

(define (home-emacs-configuration->code config)
  "Return a Scheme s-expression creating a `home-emacs-configuration' record
equivalent to CONFIG."

  (define-syntax unless-null
    (syntax-rules ()
      ((_ var exp)
       (if (null? var)
           '()
           (list (list 'var exp))))))

  (define (elisp->code exp)
    ;; Simple serialization for Elisp expressions containing no G-expressions
    ;; or file-likes.
    `(elisp ,(fold-right/elisp (lambda (t s)
                                 (match t
                                   ((? vertical-space?)
                                    '(unelisp-newline))
                                   ((? page-break?)
                                    '(unelisp-page-break))
                                   ((? comment?)
                                    `(unelisp-comment
                                      ,(comment->string t)))
                                   (_ t)))
                               (lambda (t s)
                                 (if (not t)
                                     (list->dotted-list s)
                                     s))
                               cons
                               '()
                               exp)))

  (define (alist->code lst)
    (list (if (any (match-lambda
                     ((var . (? elisp? val))
                      #t)
                     (_ #f))
                   lst)
              'quasiquote
              'quote)
          (map (match-lambda
                 ((var . (? elisp? val))
                  ;; Works because `quasiquote' expands `unquote' forms like
                  ;; `(a . ,C) correctly into (a . C), and
                  ;; `pretty-print-with-comments' prints them nicely.
                  (cons var (list 'unquote
                                  (elisp->code val))))
                 ((var . val)
                  (cons var val)))
               lst)))

  (define (emacs-configuration->code config)
    (match-record config <emacs-configuration>
                  (early-init
                   extra-init-files
                   extra-files
                   variables
                   modes
                   keys
                   keys-override
                   extra-init)
      (let ((body `(,@(unless-null early-init
                                   `(list ,@(map elisp->code
                                                 early-init)))
                    ,@(unless-null extra-init-files
                                   `(quote ,extra-init-files))
                    ,@(unless-null extra-files
                                   `(quote ,extra-files))
                    ,@(unless-null variables
                                   (alist->code variables))
                    ,@(unless-null modes
                                   (alist->code modes))
                    ,@(unless-null keys
                                   `(quote ,keys))
                    ,@(unless-null keys-override
                                   `(quote ,keys-override))
                    ,@(unless-null extra-init
                                   `(list ,@(map elisp->code
                                                 extra-init))))))
        (if (null? body)
            body
            `(emacs-configuration
              ,@body)))))

  (define (emacs-keymap->code config)
    (match-record config <emacs-keymap>
                  (name
                   repeat?
                   repeat-exit
                   repeat-enter
                   disabled-commands
                   keys)
      `(emacs-keymap
        (name (quote ,name))
        ,@(if (not repeat?)
              '()
              (list `(repeat? ,repeat?)))
        ,@(unless-null repeat-exit
                       `(quote ,repeat-exit))
        ,@(unless-null repeat-enter
                       `(quote ,repeat-enter))
        ,@(unless-null disabled-commands
                       `(quote ,disabled-commands))
        ,@(unless-null keys
                       `(quote ,keys)))))

  (define (emacs-package->code config)
    (match-record config <emacs-package>
                  (name
                   load-force?
                   load-predicates
                   load-after-packages
                   load-paths
                   autoloads
                   autoloads-interactive
                   keys-global
                   keys-global-keymaps
                   keys-override
                   keys-local
                   options
                   faces
                   hooks
                   auto-modes
                   magic-modes
                   extra-after-load
                   extra-init
                   extra-keywords)
      `(emacs-package
        (name (quote ,name))
        ,@(if (not load-force?)
              '()
              (list `(load-force? ,load-force?)))
        ,@(unless-null load-predicates
                       `(list ,@(map elisp->code
                                     load-predicates)))
        ,@(unless-null load-after-packages
                       `(quote ,load-after-packages))
        ,@(unless-null load-paths
                       `(quote ,(filter string?
                                        load-paths)))
        ,@(unless-null autoloads
                       `(quote ,autoloads))
        ,@(unless-null autoloads-interactive
                       `(quote ,autoloads-interactive))
        ,@(unless-null keys-global
                       `(quote ,keys-global))
        ,@(unless-null keys-global-keymaps
                       `(quote ,keys-global-keymaps))
        ,@(unless-null keys-override
                       `(quote ,keys-override))
        ,@(unless-null keys-local
                       `(list ,@(map emacs-keymap->code
                                     keys-local)))
        ,@(unless-null options
                       (alist->code options))
        ,@(unless-null faces
                       `(quote ,faces))
        ,@(unless-null hooks
                       `(quote ,hooks))
        ,@(unless-null auto-modes
                       `(quote ,auto-modes))
        ,@(unless-null magic-modes
                       `(quote ,magic-modes))
        ,@(unless-null extra-after-load
                       `(list ,@(map elisp->code
                                     extra-after-load)))
        ,@(unless-null extra-init
                       `(list ,@(map elisp->code
                                     extra-init)))
        ,@(unless-null extra-keywords
                       (list 'quasiquote
                             (map (match-lambda
                                    ((head . tail)
                                     `(,head
                                       ,@(map (lambda (e)
                                                (list 'unquote
                                                      (elisp->code e)))
                                              tail))))
                                  extra-keywords))))))

  (match-record config <home-emacs-configuration>
                (default-init configured-packages)
    (let ((default-init* (emacs-configuration->code default-init)))
      `(home-emacs-configuration
        ,@(if (null? default-init*)
              '()
              (list `(default-init
                       ,default-init*)))
        (configured-packages
         ,(if (null? configured-packages)
              '(quote ())
              `(list ,@(map emacs-package->code
                            configured-packages))))))))

(define (input->home-emacs-configuration port)
  "Return a `home-emacs-configuration' record from Elisp read from PORT."
  (schemified-elisp->home-emacs-configuration
    (read-with-comments/sequence port
                                 #:elisp? #t)))

(define (elisp-file->home-emacs-configuration port file)
  "Write to PORT a Scheme snippet creating a `home-emacs-configuration' from
the Elisp file named FILE."
  (pretty-print-with-comments port
                              (home-emacs-configuration->code
                               (call-with-input-file file
                                 input->home-emacs-configuration))
                              #:special-forms '((emacs-configuration . 0)
                                                (emacs-package . 0)
                                                (emacs-keymap . 0)
                                                (default-init . 0)
                                                (configured-packages . 0)
                                                (extra-after-load . 0)
                                                (extra-init . 0)
                                                (extra-keywords . 0))))

\f
;;;
;;; Elisp reader extension.
;;;

(eval-when (expand load eval)

  (define (read-elisp-extended port)
    (read-with-comments port
                        #:blank-line? #f
                        #:elisp? #t
                        #:unelisp-extensions? #t))

  (define (read-elisp-expression chr port)
    `(elisp ,(read-elisp-extended port)))

  (read-hash-extend #\% read-elisp-expression))

;;; emacs.scm ends here