From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp12.migadu.com ([2001:41d0:403:478a::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms9.migadu.com with LMTPS id kFwIM9VzsWTWnQAASxT56A (envelope-from ) for ; Fri, 14 Jul 2023 18:12:05 +0200 Received: from aspmx1.migadu.com ([2001:41d0:403:478a::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp12.migadu.com with LMTPS id QFL+MtVzsWTYYwEAauVa8A (envelope-from ) for ; Fri, 14 Jul 2023 18:12:05 +0200 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id D86AB5EB86 for ; Fri, 14 Jul 2023 18:12:04 +0200 (CEST) Authentication-Results: aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=fernseed.me header.s=gm1 header.b=SiXrzqmA; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=fail reason="SPF not aligned (relaxed)" header.from=fernseed.me (policy=none) ARC-Seal: i=1; s=key1; d=yhetil.org; t=1689351125; a=rsa-sha256; cv=none; b=aYtzr1hpzoLLZ1I1Tsen5BeXvCcWwSYA0/wJxiZoUauvrJIy0CxkLBZ1ZOiF4RFWmvrwJO /ZpADlvOZ0t5aiJhFl3hKEUdde4feLU7rA6r+5yEGQhtSUaBCdje7CcZOPRzrVrISL3N0Y GbBL0cuA8JqdHt3ezCSEFdx1CiwXvia1YuqtKSH9fDKiNdSUPV/hiEuI04aMea4tNKBmbE 5Zdk8UxKO/kGs6mq6WMymBgRWGplEtImDnIHK+kS/HvFe7WlHMrqfXNvBYxxehkywmuNA3 SL6kQX3XEG/9C5wPEuvCgs61C5HoAIxSPzCSKoR/e0ZcvDfZ4wIU1riJAgU7gA== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=fernseed.me header.s=gm1 header.b=SiXrzqmA; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=fail reason="SPF not aligned (relaxed)" header.from=fernseed.me (policy=none) ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1689351125; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-type:content-type: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:list-id:list-help: list-unsubscribe:list-subscribe:list-post:dkim-signature; bh=3oKlRbz4aPm4+/eMNnPt5pWIkX+cEzh4XNqnBqIEft0=; b=ml8N9lS845dCOGny2kXZDmP/VlWDhf4ezWE25ZNZYgW+6dMVLdKVS6pH7ka+HxY+7HeoEr hTBB6SCWYecUj/pQhmChvb8UXaiwXGk1KIKeqOte31yEe7GronKzmXCmWMTY83wmxDkq+L 5Ugm/0ld5HuMjJEtoG6t+NbQsgGv+IYdLcDGTIn8Sez2+f9Sqpo9N4xIXZYZPjCbnZRhkJ 3+FINuiC6DvYETq/Qi4Nr6+fymiInytkijkD1HuMgqu06pVb5YPCiLekwCuA6cfoDDXyh/ eNjrREZNHfO52VrQi/L86Yv5mgNDd0e85jMm+qXFjgVTTvR+ql5Po3oMzd2idw== Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1qKLOV-00005t-Pl; Fri, 14 Jul 2023 12:11:47 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1qKL3W-0006YT-Cl for guix-patches@gnu.org; Fri, 14 Jul 2023 11:50:07 -0400 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1qKL3S-00086G-HH for guix-patches@gnu.org; Fri, 14 Jul 2023 11:50:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1qKL3S-0005Jh-C9 for guix-patches@gnu.org; Fri, 14 Jul 2023 11:50:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#64620] [PATCH] gnu: home: Add home-emacs-service-type. Resent-From: fernseed@fernseed.me Original-Sender: "Debbugs-submit" Resent-CC: , guix-patches@gnu.org Resent-Date: Fri, 14 Jul 2023 15:50:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 64620 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 64620@debbugs.gnu.org Cc: Kierin Bell , ( , Andrew Tropin , Christopher Baines , Josselin Poiret , Ludovic =?UTF-8?Q?Court=C3=A8s?= , Mathieu Othacehe , Ricardo Wurmus , Simon Tournier , Tobias Geerinckx-Rice X-Debbugs-Original-To: guix-patches@gnu.org X-Debbugs-Original-Xcc: ( , Andrew Tropin , Christopher Baines , Josselin Poiret , Ludovic =?UTF-8?Q?Court=C3=A8s?= , Mathieu Othacehe , Ricardo Wurmus , Simon Tournier , Tobias Geerinckx-Rice Received: via spool by submit@debbugs.gnu.org id=B.168934975320372 (code B ref -1); Fri, 14 Jul 2023 15:50:02 +0000 Received: (at submit) by debbugs.gnu.org; 14 Jul 2023 15:49:13 +0000 Received: from localhost ([127.0.0.1]:43279 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1qKL2e-0005IW-VZ for submit@debbugs.gnu.org; Fri, 14 Jul 2023 11:49:13 -0400 Received: from lists.gnu.org ([2001:470:142::17]:35864) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1qKKU2-0004NY-H2 for submit@debbugs.gnu.org; Fri, 14 Jul 2023 11:13:26 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1qKKTw-00066P-Rb for guix-patches@gnu.org; Fri, 14 Jul 2023 11:13:21 -0400 Received: from relay9-d.mail.gandi.net ([2001:4b98:dc4:8::229]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1qKKTq-0002Kk-Mn for guix-patches@gnu.org; Fri, 14 Jul 2023 11:13:20 -0400 Received: by mail.gandi.net (Postfix) with ESMTPSA id 30410FF80A; Fri, 14 Jul 2023 15:13:07 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=fernseed.me; s=gm1; t=1689347589; h=from:from:reply-to:subject:subject:date:date:message-id:message-id: to:to:cc:cc:mime-version:mime-version:content-type:content-type: content-transfer-encoding:content-transfer-encoding; bh=3oKlRbz4aPm4+/eMNnPt5pWIkX+cEzh4XNqnBqIEft0=; b=SiXrzqmAyDe8KmmgzR0QoSF4Ri48Hrc/zsDCRAyRS1rKqOruDp1ywZ1RMdeL7AGunTJuKf FsFFswYCouiFrPB6tJmHw5Ibe8LnQwR5x3rzGLlz34uBJ6+2Fq9nL+GWgCmYMWuDouJvEj mSN8CnH48BY8wxVsXtfRZLqYIzQojnJhhf2pvDpX2U/z2dm4ZFovPJhyfNdeMFqu6yDzQ7 uzq8OgI51g8tOg8bIkRwZhjQIudkjytiGszU93SCXEQGs7LSlcLQ3R8Kqk8Bn/UOsE9gkV SIer1wTtKj4o48WIqGjPDtLLgLK1+hMr4M8y5pVeaBERPUyP2vLEj1B5l0hBIA== From: fernseed@fernseed.me Date: Fri, 14 Jul 2023 11:12:31 -0400 Message-Id: <0173e076aafb6ec389a7ebca5d56b7f4e8a02b6e.1689347338.git.fernseed@fernseed.me> X-Mailer: git-send-email 2.40.1 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-GND-Sasl: fernseed@fernseed.me Received-SPF: pass client-ip=2001:4b98:dc4:8::229; envelope-from=fernseed@fernseed.me; helo=relay9-d.mail.gandi.net X-Spam_score_int: -23 X-Spam_score: -2.4 X-Spam_bar: -- X-Spam_report: (-2.4 / 5.0 requ) BAYES_00=-1.9, DKIM_INVALID=0.1, DKIM_SIGNED=0.1, RCVD_IN_DNSWL_LOW=-0.7, SPF_HELO_PASS=-0.001, SPF_PASS=-0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no X-Spam_action: no action X-Mailman-Approved-At: Fri, 14 Jul 2023 11:49:11 -0400 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-Mailman-Approved-At: Fri, 14 Jul 2023 12:11:44 -0400 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: guix-patches-bounces+larch=yhetil.org@gnu.org X-Migadu-Flow: FLOW_IN X-Migadu-Country: US X-Migadu-Scanner: mx0.migadu.com X-Migadu-Spam-Score: -4.12 X-Spam-Score: -4.12 X-Migadu-Queue-Id: D86AB5EB86 X-TUID: czkNN4NP6cPQ From: Kierin Bell * gnu/home/services/emacs.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add new file. * tests/home/services/emacs.scm: New tests file. * Makefile.am (SCM_TESTS): Add new tests file. * doc/guix.texi (Emacs Home Services): New node. * guix/read-print.scm (read-with-comments, read-with-comments/sequence): Add new ELISP? and UNELISP-EXTENSIONS? keyword arguments to support reading Elisp. (%newline-forms): Add `home-emacs-configuration'. (%elisp-special-forms, %elisp-natural-whitespace-string-forms) (%elisp-special-symbol-chars, %elisp-confusable-number-symbols) (%elisp-basic-chars, %elisp-simple-escape-chars): New variables. (special-form-lead, printed-string, symbol->display-string): Add new ELISP? keyword argument. (atom->elisp-string): New helper function. (pretty-print-with-comments): New ELISP? and SPECIAL-FORMS keyword arguments to support serialization to Elisp. General improvements: enable pretty-printing of alists and improper lists; only print lists of constants with one element per line when length exceeds LONG-LIST; do not print newline before special read syntax forms (e.g., `'', `#~', etc.) unless they would exceed MAX-WIDTH; include backslashes when calculating whether a string would exceed MAX-WIDTH; do not print extraneous newline when special form has an empty body; print newlines after list arguments of special forms; print first argument after function on newline with same indentation as function when it would exceed MAX-WIDTH. * tests/read-print.scm: Add new tests and update old tests which fail due to improvements. --- This patch builds on patches from ( and David Wilson for a `home-emacs-service-type' (https://issues.guix.gnu.org/58693, https://issues.guix.gnu.org/60753, https://issues.guix.gnu.org/62549). Many of the features of the prior patches have been included, but the major focus here is to configure Emacs in Scheme rather than symlinking to existing configuration files. Here are some of the broad strokes: * The following record types have been introduced to encapsulate configuration for Emacs: `emacs-configuration' (for general configuration), `emacs-package' (for package-specific configuration), `emacs-keymap' (for configuration of local keymaps), and `emacs-server' (for configuration of Emacs servers). * Most configuration fields are either flat lists or alists that are considerably abstracted from their final serialized Elisp representation, but escape hatches are provided for both pulling in existing configuration files and specifying s-expressions directly. * All serialized Elisp is pretty-printed much how we would expect to see it in Emacs (for example, with proper indentation according to the `lisp-indent-function' symbol property, etc.). This has been accomplished by adding a new keyword argument to `pretty-print-with-comments' from `(guix read-print)', among other improvements. * Emacs package configuration can either be serialized as `use-package' forms or as equivalent, more minimalist s-expressions. Users can define their own package serializers, too. * For specifying s-expressions, an "Elisp expression" syntax has been implemented that is essentially a lighter-weight version G-expressions. (I try to explain why this is helpful in the documentation.) * A reader extension has been implemented that allows for "Elisp expressions" to be specified directly with Elisp read syntax, and Scheme values (including file-like objects or G-expressions) can in turn be "unquoted" within that Elisp code. Also, comments and whitespace can be included within the Elisp code via the `#;' (comment), `#>' (newline), and `;^L' (page break) forms. * Each Emacs server has its own user init and early init files, which can optionally inherit configuration from the init files used by non-server Emacsen. Each server can also inherit the "main" `user-emacs-directory', or it can use its own subdirectory. * The `home-emacs-service-type' can be extended, with subordinate configuration records being merged intelligently when possible. * A utility function has been provided for generating the aforementioned Scheme records from an existing Emacs init file: `elisp-file->home-emacs-configuration'. Here's an example configuration for the `home-emacs-service-type' demonstrating some of these features: --8<---------------cut here---------------start------------->8--- (use-modules (gnu home) (gnu services) (guix gexp) (gnu home services) (gnu home services emacs) (gnu packages emacs-xyz) (gnu packages file) (gnu packages compression)) (define %my-function-name 'my--compose-mail) (define %gnus-init-file (elisp-file "gnus.el" (list (elisp (setq gnus-select-method '(nnnil ""))) (elisp (setq gnus-secondary-select-methods '((nnml "") (nntp "news.gmane.io")))) (elisp (setq mail-sources '((imap :server "mail.example.net" :user "user@example.net" :port 993 :stream tls)))) ;; Elisp reader extension #%(define-key global-map [remap compose-mail] #;comment '#$%my-function-name nil)))) (home-environment ;; ... (services (list ;; ... (service home-emacs-service-type (home-emacs-configuration (user-emacs-directory "~/.local/state/emacs/") (package-serializer %emacs-use-package-serializer) (default-init (emacs-configuration ;; File-likes specified here symlinked in ~/.config/emacs and ;; loaded when Emacs starts. (extra-init-files `(("extra.el" . ,(local-file "extra.el")))) (variables '((initial-scratch-message . #f) ;; Symbols values for variables quoted when serialized. (confirm-kill-emacs . y-or-n-p) ;; Boolean values for variables serialized properly in Elisp. (visible-bell . #t) ;; Elisp expressions serialized as-is, with no quoting. (message-signature-file . ,(elisp mail-signature-file)))) (modes '((tool-bar-mode . #f) (menu-bar-mode . #f) (fringe-mode . 16) (repeat-mode . #t))) (keys '(("C-x C-b" . ibuffer))) (keys-override '(("M-" . scroll-down-line) ("M-" . scroll-up-line) ("C-M-S-" . my--scroll-other-window-down) ("C-M-S-" . my--scroll-other-window))) (extra-init (list (elisp (defun my--scroll-other-window-down () (interactive) (scroll-other-window-down 1))) (elisp (defun my--scroll-other-window () (interactive) (scroll-other-window 1))))))) (configured-packages (list (emacs-package (name 'windmove) ;; Autoload a function used by `my--display-buffer-down'. (autoloads '(windmove-display-in-direction)) (keys-override '(("C-M-" . windmove-left) ("C-M-" . windmove-right) ("C-M-" . windmove-up) ("C-M-" . windmove-down) ("C-x " . my--display-buffer-down))) (keys-local (list (emacs-keymap (name 'windmove-repeat-map) (repeat? #t) (keys '(("" . windmove-left) ("" . windmove-right) ("" . windmove-up) ("" . windmove-down)))))) (extra-init (list (elisp (defun my--display-buffer-down (&optional arg buf) (interactive "P\nbSwitch to buffer in window below: ") (windmove-display-in-direction 'down arg) (switch-to-buffer buf)))))) (emacs-package (name 'dired) ;; External packages used by Dired (extra-packages (list file unzip))))))) (simple-service 'emacs-mail-service home-emacs-service-type (home-emacs-extension (default-init (emacs-configuration ;; File-likes symlinked into `user-emacs-directory', but not ;; loaded automatically. (extra-files `(("gnus.el" . ,%gnus-init-file) ("signature" . ,(local-file "signature")))) (variables `((gnus-init-file . ,(elisp (locate-user-emacs-file "gnus.el"))) (mail-user-agent . gnus-user-agent) (read-mail-command . gnus))))) (configured-packages (list (emacs-package (name 'message) (options `((message-send-mail-function . smtpmail-send-it) (message-signature-file . ,(elisp (locate-user-emacs-file "signature")))))))) (servers (list ;; Servers inherit `user-emacs-directory' and init file ;; configuration from non-server Emacsen by default. (emacs-server (name "mail") (default-init (emacs-configuration (extra-init (list (elisp (add-hook 'server-after-make-frame-hook (function gnus)))))))))))) (simple-service 'emacs-sandbox-service home-emacs-service-type (home-emacs-extension (servers (list (emacs-server (name "sandbox") ;; Server gets its own subdirectory of `user-emacs-directory' ;; when inheritance is disabled. (inherit-directory? #f) ;; Server still inherits configuration from non-server Emacsen ;; unless inheritance is explicitly disabled. (inherit-init? #f) (inherit-configured-packages? #f) ;; Server is started via a Shepherd service automatically, ;; unless disabled. (auto-start? #f) (default-init (emacs-configuration (variables `((initial-scratch-message . #f) ;; Individualized `user-emacs-directory' gets symlinks ;; to all `extra-files' from the `emacs-configuration' ;; used by other Emacsen, so the files can still be ;; referenced. (mail-signature-file . ,(elisp (locate-user-emacs-file "signature"))))) (extra-init (list (elisp (ding)))))) (configured-packages (list ;; Configure a theme specifically for the "sandbox" server. (emacs-package (name 'modus-themes) (package emacs-modus-themes) (extra-init (list (elisp (load-theme 'modus-operandi-tinted))))))))))))))) --8<---------------cut here---------------end--------------->8--- Finally, unit tests have been added for the new `(guix read-print)' functionality, and for the "Elisp expression" syntax. I couldn't make unit tests for anything that builds derivations serializing Elisp, because '%bootstrap-guile' is apparently too old to load `(guix read-print)' on the derivation side. But most of this has gotten quite a bit of testing, as all of my personal Emacs config is now generated from Scheme. The patch is to the point where I'd like to get some feedback, and see if this is something that could be included into Guix. Makefile.am | 2 + doc/guix.texi | 1178 +++++++++++++ gnu/home/services/emacs.scm | 3040 +++++++++++++++++++++++++++++++++ gnu/local.mk | 2 + guix/read-print.scm | 995 +++++++++-- tests/home/services/emacs.scm | 345 ++++ tests/read-print.scm | 239 ++- 7 files changed, 5654 insertions(+), 147 deletions(-) create mode 100644 gnu/home/services/emacs.scm create mode 100644 tests/home/services/emacs.scm diff --git a/Makefile.am b/Makefile.am index a386e6033c..7b5c67e26b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -17,6 +17,7 @@ # Copyright © 2020, 2021, 2023 Maxim Cournoyer # Copyright © 2021 Chris Marusich # Copyright © 2021 Andrew Tropin +# Copyright © 2023 Kierin Bell # # This file is part of GNU Guix. # @@ -524,6 +525,7 @@ SCM_TESTS = \ tests/hackage.scm \ tests/home-import.scm \ tests/home-services.scm \ + tests/home/services/emacs.scm \ tests/http-client.scm \ tests/import-git.scm \ tests/import-github.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 9af1b4417b..f1958cc695 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -116,6 +116,7 @@ Copyright @copyright{} 2023 Karl Hallsby@* Copyright @copyright{} 2023 Nathaniel Nicandro@* Copyright @copyright{} 2023 Tanguy Le Carrour@* +Copyright @copyright{} 2023 Kierin Bell@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -440,6 +441,7 @@ Top * SSH: Secure Shell. Setting up the secure shell client. * GPG: GNU Privacy Guard. Setting up GPG and related tools. * Desktop: Desktop Home Services. Services for graphical environments. +* Emacs: Emacs Home Services. Services for configuring Emacs. * Guix: Guix Home Services. Services for Guix. * Fonts: Fonts Home Services. Services for managing User's fonts. * Sound: Sound Home Services. Dealing with audio. @@ -42593,6 +42595,7 @@ Home Services * SSH: Secure Shell. Setting up the secure shell client. * GPG: GNU Privacy Guard. Setting up GPG and related tools. * Desktop: Desktop Home Services. Services for graphical environments. +* Emacs: Emacs Home Services. Services for configuring Emacs. * Guix: Guix Home Services. Services for Guix. * Fonts: Fonts Home Services. Services for managing User's fonts. * Sound: Sound Home Services. Dealing with audio. @@ -43819,6 +43822,1181 @@ Desktop Home Services @end table @end deftp +@node Emacs Home Services +@subsection Emacs Home Services + +The @code{(gnu home services emacs)} module provides services for +configuring the GNU Emacs extensible text editor. + +@cindex Elisp expressions, for Emacs home services +Emacs is configured by providing @dfn{initialization files} that contain +@dfn{s-expressions} written in @dfn{Emacs Lisp} (abbreviated as +@dfn{Elisp}) which are evaluated when Emacs is started (@pxref{Init +File,,, emacs, The GNU Emacs Manual}). + +The main home service type for configuring Emacs, the +@code{home-emacs-service-type} (see below), provides three ways to +specify expressions for Emacs initialization files: + +@itemize +@item +File-like objects that contain Elisp can be directly referenced so that +Emacs will evaluate their contents upon initialization (see also +@code{elisp-file} below, which specifically creates Emacs Lisp files). + +@item +Expressions can be written in Scheme using a special syntax (see the +@code{elisp} form below), so that they will be serialized to Emacs +initialization files---with some minor transformations---as Elisp. This +is possible because Scheme and Emacs Lisp have very similar read +syntaxes. + +@item +Finally, some configuration fields provide an additional layer of +abstraction that transforms Scheme values into more complex Elisp +expressions that do meaningful things with those values. +@end itemize + +For the latter two options, the @code{(gnu home services emacs)} module +introduces a mechanism for explicitly specifying an s-expression that +should be serialized as Elisp and evaluated by Emacs: @dfn{Elisp +expressions}. Elisp expressions have their own data type (see +@code{elisp?}), and they must be created by using the @code{elisp} or +@code{#%} forms (see below), or by using other functions provided by the +module for constructing them. Whenever the term ``Elisp expression'' +occurs in the documentation for the Emacs home service, it is an +indication that Elisp expressions of this type should be used or that +they have a special meaning compared with other Scheme values like +symbols or lists. + +To illustrate why we would need to use Elisp expression objects when +configuring Emacs instead of simply writing s-expressions as we normally +would in Scheme, consider the @code{variables} field of the +@code{emacs-configuration} record type, an association list that +associates Emacs variable names---given as Scheme symbols---with values. + +When this field is serialized to the Emacs user initialization file, +Elisp expressions that set the variables to their corresponding values +are generated from this association list. But there is a problem: How +do we differentiate values that should be serialized as constants +---e.g., by using the @code{quote} syntax---from s-expressions that +should be @emph{evaluated} by Emacs? If a given value is of a Scheme +data type that corresponds to a self-quoting data type in Elisp---for +example, a number or a string---then there is no ambiguity. But what if +a symbol or a list value is given? Should it be interpreted by Emacs as +a quoted constant, or should it be interpreted as an unquoted +s-expression to be evaluated at initialization time? + +The solution chosen here is that all values of fields for which this +ambiguity exists are serialized to Elisp as constants, unless an Elisp +expression is explicitly used. Whenever explicit Elisp expressions +occur in the configuration for a service, though, we can be sure that +they will be serialized directly to Emacs initialization files as +s-expressions that will be evaluated by Emacs. + +This is best illustrated by an example. The following configuration +produces Elisp code that sets the @code{message-signature-file} Emacs +variable to the value of the @code{mail-signature-file} variable when +Emacs is initialized: + +@lisp +(emacs-configuration + (variables `((message-signature-file + . ,(elisp mail-signature-file))))) +@end lisp + +@noindent +while the example below sets the @code{message-signature-file} variable to the @emph{symbol} @code{mail-signature-file}, which is not what we want: + +@lisp +(emacs-configuration + (variables '((message-signature-file + . mail-signature-file)))) +@end lisp + +Additionally, Elisp expressions can be specified using the @code{#%} +form, which allows for Elisp code to be embedded within Scheme (see +documemtation below for more). The following is equivalent to the first +example above: + +@lisp +(emacs-configuration + (variables `((message-signature-file + . ,#%mail-signature-file))))) +@end lisp + +In many ways, Elisp expressions are similar to G-expressions +(@pxref{G-Expressions}). Elisp expressions can in fact be thought of as +an abstraction around G-expressions. After all, before any Elisp +expression can be serialized to a file by a service, it must first be +transformed into a G-expression so that a derivation can be generated +(@pxref{Derivations}). + +For this reason, any value that is a valid input for a G-expression can +be referenced within an Elisp expression (see @code{unelisp} and +@code{unelisp-splicing} below). Data types that ``compile'' and are +specially substituted in G-expressions, such as file-like objects +(@pxref{G-Expressions, file-like objects}), will be substituted in the +same exact way when they are referenced within Elisp expressions. Even +G-expressions themselves can be embedded within Elisp expressions. + +On the other hand, when Elisp expressions are referenced manually within +G-expressions (e.g., with @code{ungexp}), some of the expressive power +of Elisp expressions is lost, as explained below: comments, newlines, +and page-breaks are stripped. + +@defmac #%@var{exp} +@defmacx (elisp @var{exp}) +Return an Elisp expression containing @var{exp}. + +The @code{#%} form is special: the s-expression that follows it will not +be read as Scheme; it will be read as Elisp. In this way, it is +possible to fully embed Elisp code within a Scheme file. For example, the following Elisp expressions are equivalent when serialized: + +@lisp +(elisp (define-key global-map #(remap list-buffers) 'ibuffer #f)) +@end lisp + +@lisp +#%(define-key global-map [remap list-buffers] 'ibuffer nil) +@end lisp + +But, keep in mind, any Scheme syntax that is invalid in Elisp will cause +an error to be signaled by Guile's Elisp reader. To embed Scheme within +Elisp that is in turn embedded in Scheme, you can use the @code{#$} and +@code{#$@@} reader extensions (see below). + +Expressions within @var{exp} are constants rather than expressions that +are evaluated for their Scheme values---as if the expressions were +quoted using the @code{quote} syntax---unless they are ``unquoted'' with +one of the following two forms: + +@table @code +@item #$@var{exp} +@itemx (unelisp @var{exp}) +Include the value of @var{exp} in an @code{elisp} or @code{#%} form. + +@var{exp} is an s-expression, given in Scheme, that is evaluated, and +the resulting value is included within the containing form. Any values +that may appear within G-expressions are valid, and any substitutions +that would be made when ``compiling'' a G-expression containing +references to the given values will also be made when the resulting +Elisp expression is serialized to a file. + +If the result of evaluating @var{exp} is a list, it is traversed and all +relevant substitutions are similarly performed. + +If the result of evaluating @var{exp} is another Elisp expression, its +contents are inserted, with the relevant references included as above. + +@item #$@@@var{lst} +@itemx (unelisp-splicing @var{lst}) +Like the above, but splices the contents of @var{lst} inside the +containing expression (which must itself be a list). +@end table + +Additionally, the following forms allow for the inclusion of comments +and whitespace into Elisp expressions: + +@table @code +@item #;@var{comment} +@itemx (unelisp-comment @var{comment}) +Insert a comment containing the string @var{comment} into the containing +expression. + +With the @code{#;} form, @var{comment} comprises all text up to the +first newline, whereas with the @code{unelisp-comment} form, +@var{comment} must be a proper string that begins with @samp{;} and ends +with a newline character. Thus, the following two Elisp expressions are +equivalent (note the newline at the end of the second example): + +@lisp +(elisp (unelisp-comment ";;; Comment\n")) +@end lisp + +@lisp +#%#;;; Comment + +@end lisp + +@noindent +When the containing Elisp expression is serialized to an Elisp file (see +@code{elisp-file}), the comment is pretty-printed as it occurs. +However, when an Elisp expression is referenced within a G-expression +manually (e.g., using the @code{ungexp} syntax), all comments specified +with these forms are lost. This is because comments cannot normally be +``compiled'' into a substitution while lowering a G-expression. + +@item #> +@itemx (unelisp-newline) +Insert a newline into the containing expression. + +When an Elisp expression is serialized to an Elisp file, newlines are +inserted where they occur. But, as with @code{unelisp-comment}, +newlines specified using this syntax are removed when an Elisp +expression is referenced manually within a G-expression. + +@item #^L +@itemx (unelisp-page-break) +Insert a page-break character into the containing expression. + +When an Elisp expression is serialized to an Elisp file, page-break +characters are inserted where they occur, but, again, they are removed +when an Elisp expression is manually referenced within a G-expression. +@end table +@end defmac + +@deffn {Procedure} elisp? obj +Return true if @var{obj} is an Elisp expression object. +@end deffn + +@deffn {Procedure} elisp->sexp exp +Return an s-expression containing the contents of Elisp expression +@var{exp}. +@end deffn + +@deffn {Procedure} sexp->elisp sexp +Return an Elisp expression object containing @var{sexp}. +@end deffn + +@cindex Elisp files +Once we have some Elisp expressions, we need to be able to serialize +them to an Elisp file. Usually, we provide Elisp expressions as values +of configuration fields for the Emacs home service, which automatically +serializes them to the appropriate Emacs initialization files. However, +we can also serialize Elisp expressions directly to arbitrary files +ourselves. The @code{elisp-file} procedure takes Elisp expressions and +returns a file-like object ensuring that the expressions will be +pretty-printed as Elisp---comments, newlines and all. + +@deffn {Procedure} elisp-file name exps [#:special-forms ()] +Return an object representing the store file @var{name}, an Emacs Lisp +file that contains @var{exps}, a list of Elisp expression objects or +G-expressions. + +Custom indentation rules can be specified with @var{special-forms}, an +association list where each entry is of the form: + +@lisp +(@var{symbol} . @var{indent}) +@end lisp + +@noindent +When @var{symbol} occurs at the beginning of a list in an expression in +@var{exps}, the first @var{indent} expressions after @var{symbol} are +indented as arguments and the remainder are indented as body +expressions, as if @var{indent} was the value of the +@code{lisp-indent-function} symbol property for @var{symbol} in Emacs +(@pxref{Indenting Macros,,,elisp,The Emacs Lisp Manual}). As in Emacs, +argument expressions, if they cannot be pretty-printed on the same line +as @var{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 @code{elisp-file*}. +@end deffn + +@deffn {Procedure} elisp-file* name exps [#:special-forms ()] +Return as a monadic value a derivation that builds an Elisp file named +@var{name} containing the expressions in @var{exps}, a list of Elisp +expression objects or G-expressions. + +This is the monadic counterpart of @code{elisp-file}, which see for a +description of @var{special-forms}. +@end deffn + +@deffn {Procedure} elisp-file? obj +Return true if @var{obj} is an Elisp file object. +@end deffn + +@defvar home-emacs-service-type +This is the primary service type for configuring Emacs. Its value is a +@code{home-emacs-configuration} record, which in turn can contain up to +four subordinate configuration record types: + +@itemize +@item +@code{emacs-package}, a record type that associates an Emacs package or +library---specifically, a ``named feature'' provided by an Emacs package +(@pxref{Named Features,,,elisp,The Emacs Lisp Manual})---with a Guix +package and any relevant Elisp configuration. Thus, the +@code{emacs-package} record can encapsulate all configuration for an +Emacs package in an atomic way. + +@item +@code{emacs-configuration}, a record type used to specify general +configuration for the Emacs initialization files, such as configuration +that is not specific to any single Emacs package. + +@item +@code{emacs-server}, a record type used to specify configuration for +Emacs servers (@pxref{Emacs Server,,, emacs,The GNU Emacs Manual}). + +@item +@code{emacs-package-serializer}, a record type used to control how +@code{emacs-package} objects are serialized to the Emacs user +initialization file. There are currently two predefined package +serializers to choose from, @code{%emacs-simple-package-serializer} and +@code{%emacs-use-package-serializer}, but you can define your own as +well. +@end itemize + +Here is a sample Guix home configuration that utilizes the +@code{home-emacs-service-type}: + +@lisp +(use-modules (gnu home) + (gnu services) + (guix gexp) + (gnu home services) + (gnu home services emacs) + (gnu packages emacs-xyz) + (gnu packages aspell) + (gnu packages file) + (gnu packages compression)) + +(home-environment + (services + (list + (service + home-emacs-service-type + (home-emacs-configuration + (user-emacs-directory "~/.local/state/emacs/") + (package-serializer %emacs-use-package-serializer) + (default-init + (emacs-configuration + (variables + '((confirm-kill-emacs . y-or-n-p) + (visible-bell . #t) + (initial-scratch-message . #f))) + (modes + '((tool-bar-mode . #f) + (tooltip-mode . #f) + (menu-bar-mode . #f) + (fringe-mode . 16) + (repeat-mode . #t))) + (keys + '(("C-x C-b" . ibuffer))) + (keys-override + '(("M-" . scroll-down-line) + ("M-" . scroll-up-line) + ("C-M-S-" + . my--scroll-other-window-down) + ("C-M-S-" + . my--scroll-other-window))) + (extra-init + (list + (elisp (defun my--scroll-other-window-down () + (interactive) + (scroll-other-window-down 1))) + (elisp (defun my--scroll-other-window () + (interactive) + (scroll-other-window 1))))))) + (configured-packages + (list + (emacs-package + (name 'flyspell) + ;; `flyspell' is built into Emacs, but the dependencies + ;; `aspell' and `aspell-dict-en' are not. + (extra-packages + (list aspell aspell-dict-en)) + (hooks + '((prog-mode-hook . flyspell-prog-mode)))) + (emacs-package + (name 'windmove) + ;; Autoload a function used by `my--display-buffer-down'. + (autoloads + '(windmove-display-in-direction)) + (keys-override + '(("C-M-" . windmove-left) + ("C-M-" . windmove-right) + ("C-M-" . windmove-up) + ("C-M-" . windmove-down) + ("C-x " + . my--display-buffer-down))) + (keys-local + (list + (emacs-keymap + (name 'windmove-repeat-map) + ;; Make a repeat map for the windmove commands. + (repeat? #t) + (keys '(("" . windmove-left) + ("" . windmove-right) + ("" . windmove-up) + ("" . windmove-down)))))) + (extra-init + (list + (elisp (defun my--display-buffer-down (&optional arg + buf) + (interactive + "P\nbSwitch to buffer in window below: ") + (windmove-display-in-direction 'down arg) + (switch-to-buffer buf)))))) + (emacs-package + (name 'dired) + ;; External packages used by Dired + (extra-packages (list file unzip)) + (keys-local + (list + (emacs-keymap + (name 'dired-mode-map) + (keys '(("b" + . dired-create-empty-file)))))) + (options + '((dired-isearch-filenames . dwim) + (dired-kill-when-opening-new-dired-buffer . #t)))) + (emacs-package + (name 'vertico) + (package emacs-vertico) + (options + '((vertico-cycle . #t))) + (extra-init + (list (elisp (vertico-mode)))))))))))) +@end lisp + +@noindent +The configuration above will install and configure Emacs, additionally +installing the @code{aspell}, @code{aspell-dict-en}, @code{file}, +@code{unzip}, and @code{emacs-vertico} packages. + +The @code{home-emacs-service-type} can be extended using the +@code{home-emacs-extension} record type. Here is an example: + +@lisp +(define %gnus-init-file + (elisp-file "gnus.el" + (list + (elisp (setq gnus-select-method '(nnnil ""))) + (elisp (setq gnus-secondary-select-methods + '((nnml "") + (nntp "news.gmane.io")))) + (elisp (setq mail-sources + '((imap :server "mail.example.net" + :user "user@@example.net" + :port 993 + :stream tls))))))) + +(home-environment + (services + (list + ;; ... + (simple-service + 'emacs-mail-service + home-emacs-service-type + (home-emacs-extension + (default-init + (emacs-configuration + (extra-files + `(("gnus.el" . ,%gnus-init-file) + ("signature" + . ,(local-file + "/home/user/src/guix-config/files/signature")))) + (variables + `((gnus-init-file + . ,(elisp (locate-user-emacs-file + "gnus.el"))) + (mail-user-agent . gnus-user-agent) + (read-mail-command . gnus))))) + (configured-packages + (list + (emacs-package + (name 'smtpmail) + (options + '((smtpmail-servers-requiring-authorization + . "mail\\.example\\.net") + (smtpmail-smtp-server . "mail.example.net") + (smtpmail-smtp-service . 587) + (smtpmail-smtp-user + . "user@@example.net")))) + (emacs-package + (name 'message) + (options + `((message-send-mail-function + . smtpmail-send-it) + (message-signature-file + . ,(elisp (locate-user-emacs-file + "signature")))))))) + (servers + (list + (emacs-server + (name "mail") + (default-init + (emacs-configuration + (extra-init + (list + (elisp (add-hook 'server-after-make-frame-hook + (function gnus)))))))))))))))) +@end lisp + +@noindent +The configuration above extends the Emacs home service by configuring +the @code{smtpmail} and @code{message} packages, creating a +configuration file for the Emacs Gnus Newsreader, and creating a +Shepherd service called @samp{emacs-mail} which runs an Emacs server +that opens Gnus when a client frame is started. +@end defvar + +The record types for configuring the Emacs home service are described in +detail below. + +Note that for these record types, configuration fields that accept +``association list'' values expect proper assocation lists. An entry of +the form @code{(@var{a} . @var{b})} specifies a value of @var{b} for key +@var{a}, but an entry of the form @code{(@var{a} @var{b})} specifies a +value that is a list which contains @var{b} as its only element (this +can also be written as @code{(@var{a} . (@var{b}))}). + +@deftp {Data Type} home-emacs-configuration +Available @code{home-emacs-configuration} fields are: + +@table @asis +@item @code{emacs} (default: @code{emacs}) (type: package) +The package providing the @file{/bin/emacs} command. + +@item @code{user-emacs-directory} (default: @code{"~/.config/emacs/"}) (type: string) +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. + +@item @code{native-compile?} (default: @code{#t}) (type: boolean) +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}. + +@item @code{load-custom?} (default: @code{#t}) (type: boolean) +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. + +@item @code{extra-packages} (default: @code{()}) (type: 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. + +@item @code{package-serializer} (default: @code{%emacs-simple-package-serializer}) (type: emacs-package-serializer) +The serializer to use for configuration specified by +@code{emacs-package} objects. + +@deftp {Data Type} emacs-package-serializer +Available @code{emacs-package-serializer} fields are: + +@table @asis +@item @code{name} (type: symbol) +A symbol identifying the serializer. + +@item @code{procedure} (type: 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. + +@item @code{dependencies} (default: @code{()}) (type: 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. + +@item @code{indent-forms} (default: @code{()}) (type: 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. + +@item @code{description} (default: @code{""}) (type: string) +A brief description of the serializer. + +@end table + +@end deftp + +@item @code{indent-forms} (default: @code{()}) (type: 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. + +@item @code{propagated-init} (default: @code{()}) (type: 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. + +@item @code{default-init} (type: 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. + +@deftp {Data Type} emacs-configuration +Available @code{emacs-configuration} fields are: + +@table @asis +@item @code{early-init} (default: @code{()}) (type: 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. + +@item @code{extra-init-files} (default: @code{()}) (type: 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. + +@item @code{extra-files} (default: @code{()}) (type: 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. + +@item @code{variables} (default: @code{()}) (type: 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. Note that it is an error to specify an Elisp +expression value that contains only comments or whitespace for this +field. + +@item @code{modes} (default: @code{()}) (type: 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. + +@item @code{keys} (default: @code{()}) (type: 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-"}, @samp{" "}, +and @samp{""} (@pxref{Keymaps,,, elisp,The Emacs Lisp Manual}). +Binding definitions should be symbols for Emacs commands. + +@item @code{keys-override} (default: @code{()}) (type: 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. + +@item @code{extra-init} (default: @code{()}) (type: 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. + +@end table + +@end deftp + +@item @code{configured-packages} (default: @code{()}) (type: 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. + +@deftp {Data Type} emacs-package +Available @code{emacs-package} fields are: + +@table @asis +@item @code{name} (type: symbol) +The symbol naming the Emacs package or library, as would be used with +Emacs @code{require}. + +@item @code{package} (default: @code{()}) (type: 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). + +@item @code{extra-packages} (default: @code{()}) (type: 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}. + +@item @code{extra-files} (default: @code{()}) (type: 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. + +@item @code{install?} (default: @code{#t}) (type: boolean) +Whether to install @code{package} and @code{extra-packages}. + +@item @code{load-force?} (default: @code{#f}) (type: boolean) +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. + +@item @code{load-predicates} (default: @code{()}) (type: 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. + +@item @code{load-after-packages} (default: @code{()}) (type: 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}. + +@item @code{load-paths} (default: @code{()}) (type: 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. + +@item @code{autoloads} (default: @code{()}) (type: 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. + +@item @code{autoloads-interactive} (default: @code{()}) (type: 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. + +@item @code{keys-global} (default: @code{()}) (type: alist) +An association list of key sequences (as strings or vectors) and Emacs +commands to bind in the global keymap. + +@item @code{keys-global-keymaps} (default: @code{()}) (type: 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. + +@item @code{keys-override} (default: @code{()}) (type: 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. + +@item @code{keys-local} (default: @code{()}) (type: list-of-emacs-keymaps) +A list of key binding configurations for specific keymaps, each +contained in an @code{emacs-keymap} object. + +@deftp {Data Type} emacs-keymap +Available @code{emacs-keymap} fields are: + +@table @asis +@item @code{name} (default: @code{global-map}) (type: symbol) +The symbol of the Emacs keymap in which to bind keys. + +@item @code{package-name} (default: @code{()}) (type: 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. + +@item @code{repeat?} (default: @code{#f}) (type: boolean) +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. + +@item @code{repeat-exit} (default: @code{()}) (type: 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. + +@item @code{repeat-enter} (default: @code{()}) (type: 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. + +@item @code{disabled-commands} (default: @code{()}) (type: 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 + +@item @code{keys} (default: @code{()}) (type: 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. +@end table + +@end deftp + +@item @code{options} (default: @code{()}) (type: 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. + +@item @code{faces} (default: @code{()}) (type: alist) +An association list of face symbols and face specs. @xref{Defining +Faces,,,elisp,The Emacs Lisp Manual} for the format of face specs. + +@item @code{hooks} (default: @code{()}) (type: 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. + +@item @code{auto-modes} (default: @code{()}) (type: 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. + +@item @code{magic-modes} (default: @code{()}) (type: 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. + +@item @code{extra-after-load} (default: @code{()}) (type: 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. + +@item @code{extra-init} (default: @code{()}) (type: 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. + +@item @code{extra-keywords} (default: @code{()}) (type: 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. + +@end table + +@end deftp + +@item @code{servers} (default: @code{()}) (type: list-of-emacs-servers) +A list of configurations for Emacs servers. + +@deftp {Data Type} emacs-server +Available @code{emacs-server} fields are: + +@table @asis +@item @code{name} (type: 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{.}. + +@item @code{inherit-directory?} (default: @code{#t}) (type: boolean) +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. + +@item @code{inherit-init?} (default: @code{#t}) (type: boolean) +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. + +@item @code{inherit-configured-packages?} (default: @code{#t}) (type: boolean) +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. + +@item @code{load-custom?} (default: @code{#t}) (type: boolean) +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. + +@item @code{extra-packages} (default: @code{()}) (type: list-of-file-likes) +A list of extra packages or file-like objects to install, without +associated configuration. + +@item @code{auto-start?} (default: @code{#t}) (type: boolean) +Whether to start the server automatically. + +@item @code{debug?} (default: @code{#f}) (type: boolean) +Whether to enable the Emacs Lisp debugger for errors in the +initialization files of the server. + +@item @code{shepherd-requirements} (default: @code{()}) (type: 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}). + +@item @code{default-init} (type: emacs-configuration) +Configuration used to create initialization files specifically for this +server. + +@item @code{configured-packages} (default: @code{()}) (type: 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. + +@end table + +@end deftp + +@end table + +@end deftp + +@deftp {Data Type} home-emacs-extension +Available @code{home-emacs-extension} fields are: + +@table @asis +@item @code{extra-packages} (default: @code{()}) (type: 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. + +@item @code{indent-forms} (default: @code{()}) (type: 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 specifying the number of argument +expressions for @var{symbol}. + +@item @code{servers} (default: @code{()}) (type: 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. + +@item @code{default-init} (type: 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. + +@item @code{configured-packages} (default: @code{()}) (type: 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. + +@end table + +@end deftp + +@cindex Emacs package serializers, for Emacs home services +As we have seen, we can customize how configuration for Emacs packages +is serialized to the Emacs user initialization file by using the +@code{package-serializer} field of the @code{home-emacs-configuration} +record. There are two predefined package serializers, the +@code{%emacs-simple-package-serializer} and the +@code{%emacs-use-package-serializer}. + +@defvar %emacs-simple-package-serializer +An Emacs package configuration serializer that configures Emacs using +minimal, built-in Emacs mechanisms, instead of complex macros such as +@code{use-package}. +@end defvar + +@defvar %emacs-use-package-serializer +An Emacs package configuration serializer that configures Emacs with the +@code{use-package} macro. +@end defvar + +@cindex Emacs package serializers, defining +We can also create custom package serializers by defining our own +@code{emacs-package-serializer} records. The two mandatory fields are +the @code{name} and the @code{procedure} fields. @code{name} is an +arbitrary symbol (currently unused), and @code{procedure} is a procedure +that takes two arguments, an @code{emacs-package} object to be +serialized and the @code{package} object providing GNU Emacs for the +home profile. The procedure must return a list of Elisp expressions or +G-expressions. + +The second argument to the package serializer procedure is useful if we +want to condition the serialized output based on the Emacs version in +use, for example, to use features introduced in newer versions of Emacs +when they available. Many new features are introduced in Emacs release +29.1, and a predicate for handling this is provided by the @code{(gnu +home services emacs)} module: @code{emacs-version-<29?} (see below). + +When defining a new package serializer, it is advisable to refer to the +documentation for the @code{emacs-package} record type, which lays out +some implementation guidelines that package serializers should follow +for each field. It is up to you to implement your serializer in a way +that is consistent with those guidelines, or not. + +Here is an example of a hypothetical @code{%emacs-null-package-serializer} that only serializes a simple comment naming each package: + +@lisp +(define (emacs-package->null-elisp config emacs) + "Return from `emacs-package' CONFIG a list of Elisp expressions that +configures EMACS by serializing only comments." + (match-record config + (name) + (let ((comment-string (string-append ";;; " + (symbol->string name) + "\n"))) + (list (elisp (unelisp-comment comment-string))))))) + +(define %emacs-null-package-serializer + (emacs-package-serializer + (name 'emacs-null-package) + (procedure emacs-package->null-elisp) + (description "An Emacs package serializer that doesn't do anything."))) +@end lisp + +@deffn {Procedure} emacs-version-<29? emacs +Return true if the version of @var{emacs}, a @code{package} object, is +less than 29, and return false otherwise. +@end deffn + +@cindex importing configuration, for Emacs home services + +You may have existing Emacs initialization files, but translating them +into Scheme configuration records can be tedious. The @code{(gnu home +services emacs)} module provides a utility function to aid in this +process: @code{elisp-file->home-emacs-configuration}. + +The following example prints a Scheme snippet that returns a +@code{home-emacs-configuration} record corresponding to the given Emacs +initialization file: + +@lisp +(elisp-file->home-emacs-configuration (current-output-port) + "/home/user/.config/emacs/init.el") +@end lisp + +@deffn {Procedure} elisp-file->home-emacs-configuration port file +Write to @var{port} a Scheme snippet creating a +@code{home-emacs-configuration} record from the Elisp file named +@var{file}. +@end deffn + @node Guix Home Services @subsection Guix Home Services diff --git a/gnu/home/services/emacs.scm b/gnu/home/services/emacs.scm new file mode 100644 index 0000000000..300b5ec53f --- /dev/null +++ b/gnu/home/services/emacs.scm @@ -0,0 +1,3040 @@ +;;; GNU Guix --- Functional package management for GNU + +;;; Copyright © 2023 ( +;;; Copyright © 2023 David Wilson +;;; Copyright © 2023 Kierin Bell +;;; +;;; 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 . + +(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: + + +;;; +;;; Elisp expression objects. +;;; + +(define-record-type* %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 `', `', and `' 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 ? + (if (blank? result) '() result))) + +(define-gexp-compiler (elisp-compiler (elisp ) system target) + ;; "Compile" an `elisp' object by stripping `', + ;; `', and `' 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 `' 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*))))))) + + +;;; +;;; Elisp files. +;;; + +(define-record-type* %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 ( 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 , , + ;; or 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 ) + system target) + (match-record 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)) + + +;;; +;;; 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)) + + +;;; +;;; 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-\"}, @samp{\" \"}, and +@samp{\"\"} (@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?)) + + +;;; +;;; 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 + (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 + (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 + (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 + (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 + (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."))) + + +;;; +;;; 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 + (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 + (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 + (dependencies) + (filter-map (match-lambda + ((dep . pred) + (and (apply pred (list emacs)) + dep))) + dependencies))) + + (define (emacs-package->installable-packages config) + (match-record config + (package extra-packages install?) + (if install? + (append (if (null? package) + '() + (list package)) + extra-packages) + '()))) + + (define (server->installable-packages config) + (match-record config + (configured-packages extra-packages) + (append + (append-map emacs-package->installable-packages configured-packages) + extra-packages))) + + (match-record config + (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 + (emacs user-emacs-directory servers) + (map + (lambda (server) + (match-record 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 + (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 + (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 + (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 + (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 + (extra-files) + (map (cut extra-file->home-files-entry <> directory) + extra-files))) + + (define (server->home-files-entries server directory) + (match-record 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 + (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."))) + + +;;; +;;; 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 + (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 + (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 + (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 + (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)))) + + +;;; +;;; 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 diff --git a/gnu/local.mk b/gnu/local.mk index 06a376a99a..e8c976327a 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -59,6 +59,7 @@ # Copyright © 2023 Zheng Junjie <873216071@qq.com> # Copyright © 2023 Ivana Drazovic # Copyright © 2023 Andy Tai +# Copyright © 2023 Kierin Bell # # This file is part of GNU Guix. # @@ -91,6 +92,7 @@ GNU_SYSTEM_MODULES = \ %D%/home.scm \ %D%/home/services.scm \ %D%/home/services/desktop.scm \ + %D%/home/services/emacs.scm \ %D%/home/services/symlink-manager.scm \ %D%/home/services/fontutils.scm \ %D%/home/services/gnupg.scm \ diff --git a/guix/read-print.scm b/guix/read-print.scm index 25be289d60..1749179338 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021-2023 Ludovic Courtès +;;; Copyright © 2023 Kierin Bell ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +22,7 @@ (define-module (guix read-print) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (ice-9 vlist) + #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -30,6 +32,7 @@ (define-module (guix read-print) #:select (formatted-message &fix-hint &error-location location)) + #:use-module (language elisp parser) #:export (pretty-print-with-comments pretty-print-with-comments/splice read-with-comments @@ -150,9 +153,17 @@ (define (read-until-end-of-line port) ((? space?) (loop)) (chr (unread-char chr port))))) -(define* (read-with-comments port #:key (blank-line? #t)) +(define* (read-with-comments port + #:key + (blank-line? #t) + (elisp? #f) + (unelisp-extensions? #f)) "Like 'read', but include objects when they're encountered. When -BLANK-LINE? is true, assume PORT is at the beginning of a new line." +BLANK-LINE? is true, assume PORT is at the beginning of a new line. + +When ELISP? is true, read Elisp, and when UNELISP-EXTENSIONS? is true, convert + objects into lists suitable for use with the `elisp' macro in the `(gnu +home services emacs)' module." ;; Note: Instead of implementing this functionality in 'read' proper, which ;; is the best approach long-term, this code is a layer on top of 'read', ;; such that we don't have to rely on a specific Guile version. @@ -172,18 +183,38 @@ (define* (read-with-comments port #:key (blank-line? #t)) (&fix-hint (hint (G_ "Did you forget a closing parenthesis?"))))))) - (define (reverse/dot lst) + (define (invalid-array-error) + (raise (make-compound-condition + (formatted-message (G_ "invalid array syntax")) + (condition + (&error-location + (location (match (port-filename port) + (#f #f) + (file (location file + (port-line port) + (port-column port)))))) + (&fix-hint + (hint (G_ "Did you mean to write a dotted list?"))))))) + + (define (reverse/dot lst array?) ;; Reverse LST and make it an improper list if it contains DOT. (let loop ((result '()) (lst lst)) (match lst - (() result) + (() + (if array? + (list->array 1 result) + result)) (((? dot?) . rest) - (if (pair? rest) - (let ((dotted (reverse rest))) - (set-cdr! (last-pair dotted) (car result)) - dotted) - (car result))) + (if array? + (invalid-array-error) + (if (pair? rest) + (let ((dotted (reverse rest))) + (set-cdr! (last-pair dotted) (car result)) + dotted) + (car result)))) + ((('%set-lexical-binding-mode . _) . rest) + (loop result rest)) ((x . rest) (loop (cons x result) rest))))) (let loop ((blank-line? blank-line?) @@ -194,27 +225,29 @@ (define* (read-with-comments port #:key (blank-line? #t)) (chr (cond ((eqv? chr #\newline) (if blank-line? - (read-vertical-space port) + (unless (and elisp? unelisp-extensions?) + (read-vertical-space port)) (loop #t return))) ((eqv? chr #\page) ;; Assume that a page break is on a line of its own and read ;; subsequent white space and newline. (read-until-end-of-line port) - (page-break)) + (unless (and elisp? unelisp-extensions?) (page-break))) ((char-set-contains? char-set:whitespace chr) (loop blank-line? return)) ((memv chr '(#\( #\[)) (let/ec return - (let liip ((lst '())) + (let liip ((lst '()) + (arr? (and elisp? (eqv? chr #\[)))) (define item (loop (match lst (((? blank?) . _) #t) (_ #f)) (lambda () - (return (reverse/dot lst))))) + (return (reverse/dot lst arr?))))) (if (eof-object? item) (missing-closing-paren-error) - (liip (cons item lst)))))) + (liip (cons item lst) arr?))))) ((memv chr '(#\) #\])) (return)) ((eq? chr #\') @@ -222,26 +255,62 @@ (define* (read-with-comments port #:key (blank-line? #t)) ((eq? chr #\`) (list 'quasiquote (loop #f return))) ((eq? chr #\#) - (match (read-char port) - (#\~ (list 'gexp (loop #f return))) - (#\$ (list (match (peek-char port) - (#\@ - (read-char port) ;consume - 'ungexp-splicing) - (_ - 'ungexp)) - (loop #f return))) - (#\+ (list (match (peek-char port) - (#\@ - (read-char port) ;consume - 'ungexp-native-splicing) - (_ - 'ungexp-native)) - (loop #f return))) - (chr - (unread-char chr port) - (unread-char #\# port) - (read port)))) + (cond + ((and elisp? unelisp-extensions?) + ;; Return list for `elisp' macro in `(gnu home services emacs)' + (match (read-char port) + (#\$ + (match (read-char port) + (#\@ + (list 'unelisp-splicing (read port))) + (chr + (unread-char chr port) + (list 'unelisp (read port))))) + (#\; + (unread-char #\; port) + (list 'unelisp-comment (read-line port 'concat))) + (#\> + (list 'unelisp-newline)) + (#\^ + (match (read-char port) + (#\L + (list 'unelisp-page-break)) + (chr + (unread-char chr port) + (unread-char #\^ port) + (unread-char #\# port) + (read-elisp port)))) + (chr + (unread-char chr port) + (unread-char #\# port) + (read-elisp port)))) + (elisp? + ;; Read normal Elisp + (unread-char #\# port) + (read-elisp port)) + (else + ;; Read Scheme + (match (read-char port) + (#\~ + (list 'gexp (loop #f return))) + (#\$ (list (match (peek-char port) + (#\@ + (read-char port) ;consume + 'ungexp-splicing) + (_ + 'ungexp)) + (loop #f return))) + (#\+ (list (match (peek-char port) + (#\@ + (read-char port) ;consume + 'ungexp-native-splicing) + (_ + 'ungexp-native)) + (loop #f return))) + (chr + (unread-char chr port) + (unread-char #\# port) + (read port)))))) ((eq? chr #\,) (list (match (peek-char port) (#\@ @@ -251,22 +320,62 @@ (define* (read-with-comments port #:key (blank-line? #t)) 'unquote)) (loop #f return))) ((eqv? chr #\;) - (unread-char chr port) - (string->comment (read-line port 'concat) - (not blank-line?))) + (if (and elisp? unelisp-extensions?) + (begin + (read-line port 'concat) ;consume + (loop blank-line? return)) + (begin + (unread-char chr port) + (string->comment (read-line port 'concat) + (not blank-line?))))) + ((eqv? chr #\?) + (if elisp? + (begin + ;; Elisp character; improve upon `read-elisp' by returning + ;; Scheme characters instead of integers. + + ;; Character read syntax support by `read-elisp': + + ;; ?X (supported), ?\uXXXX (supported), ?\uXXXXXXXX + ;; (supported), ?\X (supported), ?\XXX (octal, supported), + ;; ?\N{NAME} (returns same as ?\N), ?\N{U+X} (returns same + ;; as ?\N), or \xXX (unsupported, signals error) + + ;; `integer->char' will signal error if integer is not in + ;; range 0-#xD7FF or #xE000-#x10FFFF. + (unread-char #\? port) + (integer->char (read-elisp port))) + (begin + ;; Scheme symbol + (unread-char #\? port) + (read port)))) (else - (unread-char chr port) - (match (read port) - ((and token '#{.}#) - (if (eq? chr #\.) dot token)) - (token token)))))))) - -(define (read-with-comments/sequence port) + (cond + ;; Unlike for Scheme `read', `.' is an invalid read syntax for + ;; `read-elisp'. + ((and elisp? + (eqv? chr #\.) + (char-set-contains? char-set:whitespace ;redundant + (peek-char port))) + dot) + (elisp? + (unread-char chr port) + (read-elisp port)) + (else + (unread-char chr port) + (match (read port) + ((and token '#{.}#) + (if (eq? chr #\.) dot token)) + (token token)))))))))) + +(define* (read-with-comments/sequence port #:key elisp?) "Read from PORT until the end-of-file is reached and return the list of expressions and blanks that were read." (let loop ((lst '()) (blank-line? #t)) - (match (read-with-comments port #:blank-line? blank-line?) + (match (read-with-comments port + #:blank-line? blank-line? + #:elisp? elisp?) ((? eof-object?) (reverse! lst)) ((? blank? blank) @@ -371,8 +480,220 @@ (define %newline-forms ('set-xorg-configuration '()) ('services '(home-environment)) ('home-bash-configuration '(service)) + ('home-emacs-configuration '()) ('introduction '(channel)))) +(define %elisp-special-forms + ;; Forms that should be indented specially in Elisp, adapted from the + ;; `lisp-indent-function' property for each symbol by adding 1 to each + ;; integer value and substituting 3 for `defun', for compatibility with + ;; `%special-forms'. This is a non-exhaustive list, generated by mapping + ;; over the obarray of a minimal Emacs environment, and then removing + ;; symbols that are obsolete or unlikely to ever appear in an Emacs package + ;; or configuration file. + (vhashq + ('and-let* 2) + ('atomic-change-group 1) + ('autoload 3) + ('benchmark-progn 1) + ('benchmark-run 2) + ('benchmark-run-compiled 2) + ('byte-compile-maybe-guarded 2) + ('catch 2) + ('cl-block 2) + ('cl-callf 3) + ('cl-callf2 4) + ('cl-case 2) + ('cl-defgeneric 3) + ('cl-define-compiler-macro 3) + ('cl-defmacro 3) + ('cl-defmethod 4) + ('cl-defstruct 2) + ('cl-defsubst 3) + ('cl-deftype 3) + ('cl-defun 3) + ('cl-destructuring-bind 3) + ('cl-do 3) + ('cl-do* 3) + ('cl-do-all-symbols 2) + ('cl-do-symbols 2) + ('cl-dolist 2) + ('cl-dotimes 2) + ('cl-ecase 2) + ('cl-etypecase 2) + ('cl-eval-when 2) + ('cl-flet 2) + ('cl-flet* 2) + ('cl-generic-define-context-rewriter 4) + ('cl-generic-define-generalizer 2) + ('cl-iter-defun 3) + ('cl-labels 2) + ('cl-letf 2) + ('cl-letf* 2) + ('cl-macrolet 2) + ('cl-multiple-value-bind 3) + ('cl-multiple-value-setq 2) + ('cl-once-only 2) + ('cl-progv 3) + ('cl-return-from 2) + ('cl-symbol-macrolet 2) + ('cl-the 2) + ('cl-typecase 2) + ('cl-with-gensyms 2) + ('combine-after-change-calls 1) + ('combine-change-calls 3) + ('condition-case 3) + ('condition-case-unless-debug 3) + ('def-edebug-elem-spec 2) + ('def-edebug-spec 2) + ('defadvice 3) + ('defalias 3) + ('defclass 3) + ('defconst 3) + ('defcustom 3) + ('defface 3) + ('defgroup 3) + ('defimage 3) + ('define-abbrev 3) + ('define-abbrev-table 3) + ('define-advice 3) + ('define-alternatives 3) + ('define-auto-insert 3) + ('define-button-type 3) + ('define-category 3) + ('define-char-code-property 3) + ('define-derived-mode 3) + ('define-fringe-bitmap 3) + ('define-generic-mode 2) + ('define-globalized-minor-mode 3) + ('define-inline 3) + ('define-keymap 3) + ('define-mail-user-agent 3) + ('define-minor-mode 3) + ('define-multisession-variable 3) + ('define-obsolete-function-alias 3) + ('define-obsolete-variable-alias 3) + ('define-short-documentation-group 3) + ('define-skeleton 3) + ('define-widget 3) + ('define-widget-keywords 3) + ('defmacro 3) + ('defmath 3) + ('defsubst 3) + ('deftheme 2) + ('defun 3) + ('defvar 3) + ('defvar-keymap 2) + ('defvar-local 3) + ('defvaralias 3) + ('delay-mode-hooks 1) + ('dlet 2) + ('dolist 2) + ('dolist-with-progress-reporter 3) + ('dotimes 2) + ('dotimes-with-progress-reporter 3) + ('easy-menu-define 3) + ('easy-mmode-defmap 2) + ('easy-mmode-defsyntax 2) + ('ert-deftest 3) + ('eval-after-load 2) + ('eval-and-compile 1) + ('eval-when-compile 1) + ('gv-define-expander 2) + ('gv-define-setter 3) + ('gv-letplace 3) + ('if 2) ; Changed from 3 + ('if-let 2) ; Changed from 3 + ('if-let* 2) ; Changed from 3 + ('ignore-error 2) + ('ignore-errors 1) + ('isearch-define-mode-toggle 4) + ('keymap-set-after 4) + ('lambda 2) ; Changed from 3 + ('let 2) + ('let* 2) + ('let-alist 2) + ('let-when-compile 2) + ('letrec 2) + ('macroexp-let2 4) + ('macroexp-let2* 3) + ('minibuffer-with-setup-hook 2) + ('named-let 3) + ('oclosure-define 2) + ('oclosure-lambda 3) + ('pcase 2) + ('pcase-defmacro 3) + ('pcase-dolist 2) + ('pcase-exhaustive 2) + ('pcase-lambda 4) + ('pcase-let 2) + ('pcase-let* 2) + ('prog1 2) + ('prog2 3) + ('progn 1) + ('rx-define 3) + ('rx-let 2) + ('rx-let-eval 2) + ('save-current-buffer 1) + ('save-excursion 1) + ('save-mark-and-excursion 1) + ('save-match-data 1) + ('save-restriction 1) + ('save-selected-window 1) + ('save-window-excursion 1) + ('seq-doseq 2) + ('seq-let 3) + ('thread-first 1) + ('thread-last 1) + ('track-mouse 1) + ('unless 2) + ('unwind-protect 2) + ('use-package 2) ; Changed from 3 + ('when 2) + ('when-let 2) + ('when-let* 2) + ('while 2) + ('while-let 2) + ('while-no-input 1) + ('with-auto-compression-mode 1) + ('with-buffer-unmodified-if-unchanged 1) + ('with-case-table 2) + ('with-category-table 2) + ('with-coding-priority 2) + ('with-current-buffer 2) + ('with-current-buffer-window 4) + ('with-decoded-time-value 2) + ('with-delayed-message 2) + ('with-demoted-errors 2) + ('with-displayed-buffer-window 4) + ('with-environment-variables 2) + ('with-eval-after-load 2) + ('with-existing-directory 1) + ('with-file-modes 2) + ('with-help-window 2) + ('with-local-quit 1) + ('with-locale-environment 2) + ('with-memoization 2) + ('with-minibuffer-completions-window 1) + ('with-minibuffer-selected-window 1) + ('with-mutex 2) + ('with-no-warnings 1) + ('with-output-to-string 1) + ('with-output-to-temp-buffer 2) + ('with-selected-frame 2) + ('with-selected-window 2) + ('with-silent-modifications 1) + ('with-slots 3) + ('with-suppressed-warnings 2) + ('with-syntax-table 2) + ('with-temp-buffer 1) + ('with-temp-buffer-window 4) + ('with-temp-file 2) + ('with-temp-message 2) + ('with-timeout 2) + ('with-undo-amalgamate 1) + ('with-window-non-dedicated 2))) + (define (prefix? candidate lst) "Return true if CANDIDATE is a prefix of LST." (let loop ((candidate candidate) @@ -386,17 +707,29 @@ (define (prefix? candidate lst) (and (equal? head1 head2) (loop rest1 rest2)))))))) -(define (special-form-lead symbol context) +(define* (special-form-lead symbol context + #:key + elisp? + (special-forms '())) "If SYMBOL is a special form in the given CONTEXT, return its number of arguments; otherwise return #f. CONTEXT is a stack of symbols lexically -surrounding SYMBOL." - (match (vhash-assq symbol %special-forms) - (#f #f) - ((_ . alist) - (any (match-lambda - ((prefix . level) - (and (prefix? prefix context) (- level 1)))) - alist)))) +surrounding SYMBOL. If ELISP? is true, return the number of arguments for the +Emacs Lisp form matching SYMBOL. If SYMBOL is a key in the alist +SPECIAL-FORMS, return the value of the first matching alist entry instead." + ;; XXX: A value N in SPECIAL-FORMS is equivalent to a value of N+1 in the + ;; `%special-forms' or `%elisp-special-forms' vhashes; this makes + ;; SPECIAL-FORMS similar to the `lisp-indent-function' symbol property in + ;; Emacs and probably less confusing. + (or (assq-ref special-forms symbol) + (match (vhash-assq symbol (if elisp? + %elisp-special-forms + %special-forms)) + (#f #f) + ((_ . alist) + (any (match-lambda + ((prefix . level) + (and (prefix? prefix context) (- level 1)))) + alist))))) (define (newline-form? symbol context) "Return true if parenthesized expressions starting with SYMBOL must be @@ -424,8 +757,11 @@ (define %natural-whitespace-string-forms ;; and backslashes are escaped; newlines, tabs, etc. are left as-is. '(synopsis description G_ N_)) -(define (printed-string str context) - "Return the read syntax for STR depending on CONTEXT." +(define %elisp-natural-whitespace-string-forms + '(defun)) + +(define* (printed-string str context #:key elisp?) + "Return the read syntax for STR depending on CONTEXT and ELISP?." (define (preserve-newlines? str) (and (> (string-length str) 40) (string-index str #\newline))) @@ -436,7 +772,9 @@ (define (printed-string str context) (escaped-string str) (object->string str))) ((head . _) - (if (or (memq head %natural-whitespace-string-forms) + (if (or (memq head (if elisp? + %elisp-natural-whitespace-string-forms + %natural-whitespace-string-forms)) (preserve-newlines? str)) (escaped-string str) (object->string str))))) @@ -529,13 +867,126 @@ (define %special-non-extended-symbols ;; extended symbols: 1+, 1-, 123/, etc. (make-regexp "^[0-9]+[[:graph:]]+$" regexp/icase)) -(define (symbol->display-string symbol context) +(define %elisp-special-symbol-chars + ;; Characters that need to be backslash-escaped within an Elisp symbol (see + ;; (elisp) Symbol Type). + (char-set-complement (char-set-union char-set:letter+digit + (char-set #\- #\+ #\= #\( #\/ + #\_ #\~ #\! #\@ #\$ + #\% #\^ #\& #\: #\< + #\> #\{ #\} #\? #\*)))) + +(define %elisp-confusable-number-symbols + ;; Symbols that must begin with a backslash in order to prevent them from + ;; being read as Elisp numbers. + (make-regexp (string-append + "(^[+-]?[0-9]+(\\.[0-9]*[eE]?(\\+NaN|\\+INF|[0-9]+)?)?$)" + "|(^[0-9]+[eE][0-9]+$)"))) + +(define* (symbol->display-string symbol context #:key elisp?) "Return the most appropriate representation of SYMBOL, resorting to extended symbol notation only when strictly necessary." (let ((str (symbol->string symbol))) - (if (regexp-exec %special-non-extended-symbols str) - str ;no need for the #{...}# notation - (object->string symbol)))) + (if elisp? + (let ((str* (list->string + (string-fold-right (lambda (chr lst) + (if (char-set-contains? + %elisp-special-symbol-chars + chr) + (cons* #\\ chr lst) + (cons chr lst))) + '() + str)))) + (if (regexp-exec %elisp-confusable-number-symbols str*) + (string-append "\\" str*) + str*)) + (if (regexp-exec %special-non-extended-symbols str) + str ;no need for the #{...}# notation + (object->string symbol))))) + +(define %elisp-basic-chars + ;; Characters that can safely be specified using the Elisp character read + ;; syntax without backslash-escapes. + (char-set-union char-set:letter+digit + (char-set #\~ #\! #\@ #\$ #\% #\^ + #\& #\* #\- #\_ #\= #\+ + #\{ #\} #\/ #\? #\< #\>))) + +(define %elisp-simple-escape-chars + ;; Whitespace, control, and other special characters that can be specified + ;; using the `?\X' Elisp read syntax, where X is a single character that has + ;; a special meaning. + (char-set #\alarm #\backspace #\tab #\newline #\vtab #\page #\return + #\esc #\space #\\ #\delete)) + +(define (atom->elisp-string obj) + "Return a string representation of atom OBJ that is suitable for the Emacs +Lisp reader. Pairs and arrays should be serialized with +`pretty-print-with-comments' instead." + (match obj + (#t + "t") + (() "()") + ((? nil?) + "nil") + ((? char?) + (cond + ((char-set-contains? %elisp-basic-chars obj) + (list->string (list #\? obj))) + ((char-set-contains? %elisp-simple-escape-chars obj) + (list->string (list #\? #\\ (case obj + ((#\alarm) #\a) + ((#\backspace) #\b) + ((#\tab) #\t) + ((#\newline) #\n) + ((#\vtab) #\v) + ((#\page) #\f) + ((#\return) #\r) + ((#\esc) #\e) + ((#\space) #\s) + ((#\\) #\\) + ((#\delete) #\d))))) + (else + (let ((num (char->integer obj))) + (if (<= num 65535) + (format #f "?\\u~4,'0x" num) + (format #f "?\\U~:@(~8,'0x~)" num)))))) + ((? string?) + (printed-string obj '() #:elisp? #t)) + ((? symbol?) + (symbol->display-string obj '() #:elisp? #t)) + ((? keyword?) + (string-append ":" (symbol->display-string (keyword->symbol obj) + '() #:elisp? #t))) + ((? number? num) + (match num + ((? exact-integer?) + ;; E.g., 123 + (object->string num)) + ((? exact?) + ;; E.g., 1/2 + (object->string (exact->inexact num))) + ((? rational?) + ;; E.g., 1.5 + (object->string num)) + ((? nan?) + ;; Not implemented by `read-elisp'. + "0.0e+NaN") + ((? inf?) + ;; Not implemented by `read-elisp'. + (if (negative? num) + "-1.0e+INF" + "1.0e+INF")) + (_ + ;; Complex numbers + (raise + (formatted-message (G_ "cannot serialize complex number to Elisp: ~a") + num))))) + (_ + ;; Not an atom. + (raise + (formatted-message (G_ "Error serializing object to Elisp: ~a") + obj))))) (define* (pretty-print-with-comments port obj #:key @@ -544,7 +995,9 @@ (define* (pretty-print-with-comments port obj (format-vertical-space identity) (indent 0) (max-width 78) - (long-list 5)) + (long-list 5) + (elisp? #f) + (special-forms '())) "Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns and assuming the current column is INDENT. Comments present in OBJ are included in the output. @@ -552,15 +1005,54 @@ (define* (pretty-print-with-comments port obj Lists longer than LONG-LIST are written as one element per line. Comments are passed through FORMAT-COMMENT before being emitted; a useful value for FORMAT-COMMENT is 'canonicalize-comment'. Vertical space is passed through -FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." +FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'. + +If ELISP? is true, OBJ is printed as Emacs Lisp, simulating the indentation +used by Emacs for many common forms. + +To specify additional rules for special indentation, use SPECIAL-FORMS, an +association list where each entry is a pair of the form (SYMBOL . INDENT). +When SYMBOL occurs at the beginning of a list in OBJ, the first INDENT +expressions after SYMBOL will be indented as arguments and the rest will be +indented as body expressions. When ELISP? is true, arguments that cannot be +printed on the same line as SYMBOL will be indented 4 columns beyond the base +indentation of the enclosing list, and body expressions will be indented 2 +columns beyond the base indentation." + + (define gexp-syntax? + (if (not elisp?) + (cut memq <> '(gexp ungexp ungexp-native ungexp-splicing + ungexp-native-splicing)) + (const #f))) + + (define elisp-syntax? + (if elisp? + (cut eq? <> 'function) + (const #f))) + + (define (read-syntax? obj) + (or (memq obj '(quote + unquote + unquote-splicing)) + (gexp-syntax? obj) + (elisp-syntax? obj))) + (define (list-of-lists? head tail) ;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of - ;; 'let' bindings. + ;; 'let' bindings or an alist. (match head - ((thing _ ...) ;proper list - (and (not (memq thing - '(quote quasiquote unquote unquote-splicing))) - (pair? tail))) + ((thing . _) + (and (not (read-syntax? thing)) + (match tail + (((? pair?) . _) + #t) + (_ #f)))) + (_ #f))) + + (define list?* + (match-lambda + (((not (? read-syntax?)) . _) + #t) (_ #f))) (define (starts-with-line-comment? lst) @@ -569,44 +1061,165 @@ (define* (pretty-print-with-comments port obj ((x . _) (and (comment? x) (not (comment-margin? x)))) (_ #f))) + (define (array?* obj) + (and (array? obj) + (not (string? obj)))) + + (define (symbol->display-string* symbol context) + (symbol->display-string symbol context #:elisp? elisp?)) + + (define (printed-string* str context) + (printed-string str context #:elisp? elisp?)) + + (define (length* x) + ;; Return the length of list or dotted list X. + (let lp ((lst x) + (len 0)) + (match lst + (() + len) + ((not (? pair?)) + (+ len 1)) + ((head . tail) + (lp tail (+ len 1)))))) + + (define (dotted-list->list exp) + (let lp ((lst exp) + (acc '())) + (match lst + (() + (reverse acc)) + ((not (? pair?)) + (lp '() (cons lst acc))) + ((head . tail) + (lp tail (cons head acc)))))) + (let loop ((indent indent) (column indent) (delimited? #t) ;true if comes after a delimiter (context '()) ;list of "parent" symbols (obj obj)) - (define (print-sequence context indent column lst delimited?) + (define (print-sequence context indent column lst delimited? + force-newline?) + (define dotted? (dotted-list? lst)) (define long? - (> (length lst) long-list)) + ;; For lists that are function calls, omit heads from long list count, + ;; but include them for lists that aren't function calls. + (> (+ (length* lst) + (if (or dotted? + (match context + (((not (? symbol?)) . _) + #t) + ((_ 'quote . _) + #t) + (_ #f))) + 1 0)) + long-list)) (let print ((lst lst) (first? #t) (delimited? delimited?) - (column column)) - (match lst - (() - column) - ((item . tail) - (define newline? - ;; Insert a newline if ITEM is itself a list, or if TAIL is long, - ;; but only if ITEM is not the first item. Also insert a newline - ;; before a keyword. - (and (or (pair? item) long? - (and (keyword? item) - (not (eq? item #:allow-other-keys)))) - (not first?) (not delimited?) - (not (blank? item)))) - - (when newline? - (newline port) - (display (make-string indent #\space) port)) - (let ((column (if newline? indent column))) - (print tail - (keyword? item) ;keep #:key value next to one another - (blank? item) - (loop indent column - (or newline? delimited?) - context - item))))))) + (column column) + (unquote? #f) ;end of list when, e.g., `(a b . ,c) + (kw? #f)) ;previous item was a keyword + (cond + ((null? lst) + column) + ((blank? lst) + ;; Comments or whitespace cannot occur at the end of a dotted list. + column) + ((or unquote? (not (pair? lst))) + ;; End of improper list. + (let ((newline? (or long? + (sequence-would-protrude? + (+ column 2 (if unquote? 1 0)) + lst) + (read-syntax-would-protrude? + (+ column 2 (if unquote? 1 0)) + lst)))) + (if newline? + (begin + (newline port) + (display (make-string indent #\space) port)) + (display " " port)) + (display ". " port) + (when unquote? (display "," port)) + (let ((column (+ (if newline? + (+ indent 2) + (+ column 3)) + (if unquote? 1 0)))) + (loop indent column + #t + context + lst)))) + (else + (match lst + (('unquote obj) + ;; A form like `(a b . ,OBJ) was expanded into (quasiquote (a b + ;; unquote OBJ)), which will still be properly expanded by + ;; `quasiquote' into (a b . OBJ). + (print obj #f #f column #t kw?)) + ((item . tail) + (define kw-item?* + (if elisp? + (cond + ((keyword? item) #t) + ((symbol? item) (string-prefix? ":" (symbol->string item))) + (else #f)) + (and (keyword? item) + (not (eq? item #:allow-other-keys))))) + (define newline? + ;; Insert a newline if ITEM is itself a list, or if TAIL is + ;; long, but only if ITEM is not the first item. Also insert a + ;; newline before a keyword, and before a read syntax (e.g., + ;; `'', `#~', '#'') that would protrude. We need to test + ;; before invocation of `print-sequence' whether the first ITEM + ;; would protrude, since INDENT must then be less than usual. + ;; We thread the results of that test to here with + ;; FORCE-NEWLINE?. + (or (and first? force-newline?) + (and (or (list?* item) + long? + (read-syntax-would-protrude? + (+ column 1) item) + kw-item?*) + (or dotted? ;newline after head of improper list + (not first?) + (and first? + (match context + (((and (not (? symbol?)) + (not (? keyword?))) . _) + ;; Allow newline before first item when + ;; head of list is not a symbol. + ;; E.g.: + ;; (use-package foo + ;; :bind (("C-c f f" . foo) ;\n + ;; :map foo-map + ;; ("C-c f g" . foo-status))) + #t) + ((_ 'quote _ ...) + ;; E.g.: + ;; '(a ;\n + ;; b) + #t) + (_ #f)))) + (not kw?) ;previous ITEM not a keyword + (not delimited?) + (not (blank? item))))) + + (when newline? + (newline port) + (display (make-string indent #\space) port)) + (let ((column (if newline? indent column))) + (print tail + #f + (blank? item) + (loop indent column + (or newline? delimited?) + context + item) + #f + kw-item?*)))))))) (define (sequence-would-protrude? indent lst) ;; Return true if elements of LST written at INDENT would protrude @@ -614,21 +1227,41 @@ (define* (pretty-print-with-comments port obj ;; negatives to avoid actually rendering all of LST. (find (match-lambda ((? string? str) - (>= (+ (string-width str) 2 indent) max-width)) + (>= (+ (string-width (printed-string* str '())) + 2 indent) + max-width)) ((? symbol? symbol) - (>= (+ (string-width (symbol->display-string symbol context)) + (>= (+ (string-width (symbol->display-string* symbol context)) indent) max-width)) ((? boolean?) (>= (+ 2 indent) max-width)) (() (>= (+ 2 indent) max-width)) - (_ ;don't know + (_ ;don't know #f)) - lst)) + (if (dotted-list? lst) (dotted-list->list lst) lst))) + + (define (read-syntax-would-protrude? indent lst) + (match lst + ((or ((? read-syntax? syntax) exp) + (((? read-syntax? syntax) exp) . _)) + (sequence-would-protrude? (+ indent (case syntax + ((quote) 1) + ((unquote) 1) + ((ungexp-splicing) 3) + ((ungexp-native-splicing) 3) + (else 2))) + exp)) + (_ #f))) + + (define (special-form-lead* head) + (special-form-lead head context + #:elisp? elisp? + #:special-forms special-forms)) (define (special-form? head) - (special-form-lead head context)) + (special-form-lead* head)) (match obj ((? comment? comment) @@ -665,7 +1298,8 @@ (define* (pretty-print-with-comments port obj (('quote lst) (unless delimited? (display " " port)) (display "'" port) - (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (loop indent (+ column (if delimited? 1 2)) + #t (cons 'quote context) lst)) (('quasiquote lst) (unless delimited? (display " " port)) (display "`" port) @@ -678,33 +1312,36 @@ (define* (pretty-print-with-comments port obj (unless delimited? (display " " port)) (display ",@" port) (loop indent (+ column (if delimited? 2 3)) #t context lst)) - (('gexp lst) + (((? gexp-syntax? head) obj) (unless delimited? (display " " port)) - (display "#~" port) - (loop indent (+ column (if delimited? 2 3)) #t context lst)) - (('ungexp obj) + (match head + ('gexp + (display "#~" port) + (loop indent (+ column (if delimited? 2 3)) #t context obj)) + ('ungexp + (display "#$" port) + (loop indent (+ column (if delimited? 2 3)) #t context obj)) + ('ungexp-native + (display "#+" port) + (loop indent (+ column (if delimited? 2 3)) #t context obj)) + ('ungexp-splicing + (display "#$@" port) + (loop indent (+ column (if delimited? 3 4)) #t context obj)) + ('ungexp-native-splicing + (display "#+@" port) + (loop indent (+ column (if delimited? 3 4)) #t context obj)))) + (((? elisp-syntax? head) obj) (unless delimited? (display " " port)) - (display "#$" port) + (display "#'" port) (loop indent (+ column (if delimited? 2 3)) #t context obj)) - (('ungexp-native obj) - (unless delimited? (display " " port)) - (display "#+" port) - (loop indent (+ column (if delimited? 2 3)) #t context obj)) - (('ungexp-splicing lst) - (unless delimited? (display " " port)) - (display "#$@" port) - (loop indent (+ column (if delimited? 3 4)) #t context lst)) - (('ungexp-native-splicing lst) - (unless delimited? (display " " port)) - (display "#+@" port) - (loop indent (+ column (if delimited? 3 4)) #t context lst)) (((? special-form? head) arguments ...) ;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second ;; and following arguments are less indented. - (let* ((lead (special-form-lead head context)) + (let* ((lead (special-form-lead* head)) (context (cons head context)) - (head (symbol->display-string head (cdr context))) - (total (length arguments))) + (head (symbol->display-string* head (cdr context))) + (total (length arguments)) + (body (drop arguments (min lead total)))) (unless delimited? (display " " port)) (display "(" port) (display head port) @@ -714,43 +1351,93 @@ (define* (pretty-print-with-comments port obj ;; Print the first LEAD arguments. (let* ((indent (+ column 2 (if delimited? 0 1))) + (old-column column) (column (+ column 1 (if (zero? lead) 0 1) (if delimited? 0 1) (string-length head))) - (initial-indent column)) + (initial-indent (if elisp? + ;; Indent arguments 4 columns, like Emacs + (+ old-column 4 (if delimited? 0 1)) + column))) (define new-column (let inner ((n lead) (arguments (take arguments (min lead total))) - (column column)) + (column column) + (newline? #f)) (if (zero? n) - (begin - (newline port) - (display (make-string indent #\space) port) - indent) + (if (null? body) ;no newline when body is empty + column + (begin + (newline port) + (display (make-string indent #\space) port) + indent)) (match arguments (() column) ((head . tail) + (when newline? + ;; Print a newline when previous argument was a list. + (newline port) + (display (make-string initial-indent #\space) port)) (inner (- n 1) tail - (loop initial-indent column - (= n lead) + (loop initial-indent + (if newline? initial-indent column) + (or newline? (= n lead)) context - head))))))) + head) + (list?* head))))))) ;; Print the remaining arguments. (let ((column (print-sequence context indent new-column - (drop arguments (min lead total)) - #t))) + body + #t #f))) (display ")" port) (+ column 1))))) - ((head tail ...) + ((? array?* obj) + ;; Vectors, arrays, bytevectors, bitvectors. + (if elisp? + (let* ((lst (array->list obj)) + (overflow? (>= column max-width)) + (column (if overflow? + (+ indent 1) + (+ column (if delimited? 1 2))))) + (if overflow? + (begin + (newline port) + (display (make-string indent #\space) port)) + (unless delimited? (display " " port))) + + (display "[" port) + + (let ((column (print-sequence context column column lst #t #f))) + (display "]" port) + (+ column 1))) + ;; For Scheme, `object->string' prints the proper Guile syntax for + ;; the specific type of array, but with long arrays on one line. + (let* ((str (object->string obj)) + (len (string-width str))) + (if (and (> (+ column 1 len) max-width) + (not delimited?)) + (begin + (newline port) + (display (make-string indent #\space) port) + (display str port) + (+ indent len)) + (begin + (unless delimited? (display " " port)) + (display str port) + (+ column (if delimited? 0 1) len)))))) + ((head . tail) + ;; Lists and improper lists. (let* ((overflow? (>= column max-width)) (column (if overflow? (+ indent 1) (+ column (if delimited? 1 2)))) - (newline? (or (newline-form? head context) - (list-of-lists? head tail) ;'let' bindings + ;; Newline for `let' bindings, alists, long lists of constants. + (newline? (or (and (not (null? tail)) + (or (newline-form? head context) + (list-of-lists? head tail))) (starts-with-line-comment? tail))) (context (cons head context))) (if overflow? @@ -761,11 +1448,29 @@ (define* (pretty-print-with-comments port obj (display "(" port) (let* ((new-column (loop column column #t context head)) + (force-newline? (and (not newline?) + (or (read-syntax-would-protrude? + (+ new-column 1) tail) + (match tail + (((and lst + ((not (? read-syntax?)) . _)) + . _) + ;; Newline before initial list + ;; argument with long element(s). + (sequence-would-protrude? + (+ new-column 1) lst)) + (_ #f))))) (indent (if (or (>= new-column max-width) + force-newline? + newline? (not (symbol? head)) + (match context + ((_ 'quote _ ...) + #t) + (_ #f)) + (dotted-list? (cons head tail)) (sequence-would-protrude? - (+ new-column 1) tail) - newline?) + (+ new-column 1) tail)) column (+ new-column 1)))) (when newline? @@ -776,18 +1481,22 @@ (define* (pretty-print-with-comments port obj (let ((column (print-sequence context indent (if newline? indent new-column) - tail newline?))) + tail newline? force-newline?))) (display ")" port) (+ column 1))))) (_ (let* ((str (cond ((string? obj) - (printed-string obj context)) + (printed-string* obj context)) ((integer? obj) - (integer->string obj context)) + (if elisp? + (atom->elisp-string obj) + (integer->string obj context))) ((symbol? obj) - (symbol->display-string obj context)) + (symbol->display-string* obj context)) (else - (object->string obj)))) + (if elisp? + (atom->elisp-string obj) + (object->string obj))))) (len (string-width str))) (if (and (> (+ column 1 len) max-width) (not delimited?)) diff --git a/tests/home/services/emacs.scm b/tests/home/services/emacs.scm new file mode 100644 index 0000000000..caa70ef6fd --- /dev/null +++ b/tests/home/services/emacs.scm @@ -0,0 +1,345 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Kierin Bell +;;; +;;; 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 . + +(define-module (tests home services emacs) + #:use-module (gnu home services emacs) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix gexp) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix tests) + #:use-module (guix read-print) + #:use-module (gnu packages guile) + #:use-module (ice-9 textual-ports) + #:use-module (srfi srfi-64)) + +(test-begin "emacs-home-services") + +;;; Test `elisp' syntax + +(test-equal "test `elisp' syntax, symbol" + 't + (elisp->sexp (elisp t))) + +(test-equal "test `elisp' syntax, basic list" + '(a b c) + (elisp->sexp (elisp (a b c)))) + +(test-equal "test `elisp' syntax, substitute symbol" + 'a + (let ((foo 'a)) + (elisp->sexp (elisp (unelisp foo))))) + +(test-equal "test `elisp' syntax, substitute splicing" + '(a b c) + (let ((foo '(a b c))) + (elisp->sexp (elisp ((unelisp-splicing foo)))))) + +(test-equal "test `elisp' syntax, comment" + (comment ";comment\n") + (elisp->sexp (elisp (unelisp-comment ";comment\n")))) + +(test-equal "test `elisp' syntax, nested comment" + `(a ,(comment ";comment\n") b) + (elisp->sexp (elisp (a (unelisp-comment ";comment\n") b)))) + +(test-equal "test `elisp' syntax, newline" + (vertical-space 0) + (elisp->sexp (elisp (unelisp-newline)))) + +(test-equal "test `elisp' syntax, page break" + (page-break) + (elisp->sexp (elisp (unelisp-page-break)))) + +(test-equal "elisp->sexp, nested objects" + '(a (b c)) + (elisp->sexp (elisp (a (unelisp (elisp (b (unelisp (elisp c))))))))) + +;;; Test #% reader extension + +(test-equal "test hash extension, symbol" + 't + (elisp->sexp #%t)) + +(test-equal "test hash extension, basic list" + '(a b c) + (elisp->sexp #%(a b c))) + +(test-equal "test hash extension, dotted list" + '(a . b) + (elisp->sexp #%(a . b))) + +(test-equal "test hash extension, substitute symbol" + 'a + (let ((foo 'a)) + (elisp->sexp #%#$foo))) + +(test-equal "test hash extension, substitute splicing" + '(a b c) + (let ((foo '(a b c))) + (elisp->sexp #%(#$@foo)))) + +(test-equal "test hash extension, basic vector" + #(a b c) + (elisp->sexp #%[a b c])) + +(test-equal "test hash extension, basic character" + #\a + (elisp->sexp #%?a)) + +(test-equal "test hash extension, comment" + (elisp->sexp (elisp (unelisp-comment ";comment\n"))) + (elisp->sexp #%#;comment + )) + +(test-equal "test hash extension, nested comment" + (elisp->sexp (elisp (a (unelisp-comment ";comment\n") b))) + (elisp->sexp #%(a #;comment + b))) + +(test-equal "test hash extension, page break" + (elisp->sexp (elisp (unelisp-newline))) + (elisp->sexp #%#>)) + +(test-equal "test hash extension, page break" + (elisp->sexp (elisp (unelisp-page-break))) + (elisp->sexp #%#^L)) + +(test-equal "test hash extension, nested" + '(a (b c)) + (elisp->sexp #%(a #$#%(b #$#%c)))) + +;;; Test home Emacs service configuration + +(define (input->home-emacs-configuration . x) + (apply (@@ (gnu home services emacs) input->home-emacs-configuration) x)) + +(define (home-emacs-configuration->code . x) + (apply (@@ (gnu home services emacs) home-emacs-configuration->code) x)) + +(define-syntax-rule (test-import-emacs-configuration str config) + "Test equality of `home-emacs-configuration' generated from Elisp string STR +with record CONFIG" + (test-equal "test Emacs home configuration import " + (home-emacs-configuration->code (call-with-input-string str + input->home-emacs-configuration)) + (home-emacs-configuration->code config))) + +(test-import-emacs-configuration + "(setq my--foo 1) +(setq my--bar 'symbol) +(setq my--baz (list 'a ;comment + 'b 'c)) +(setq my--quux '(a b . c)) +(setq my--quuux #'my--fun) +(setopt foo-var my--foo) + +(foo-mode -1) +(bar-mode 1) +(baz-mode) +(quux-mode my--foo) + + +(bind-key* \"M-\" 'scroll-down-line) +(bind-key* \"M-\" 'scroll-up-line t) +;;; Top-level comment +(global-set-key (kbd \"C-c b\") 'bar) +(global-set-key [remap bar] 'baz) +(keymap-global-set \"C-c v\" 'quux) +(bind-key \"C-c c\" 'quuux) +(bind-key [t] #'quuuux 'global-map t) + +(use-package foo + :demand t + ;; Inconvenient comment + :hook prog-mode + :custom + (foo-bar 'baz) + (foo-baz baz) + :init + ;; Ding + (ding) + + (message \"Ding\")) + +(use-package bar + :if (eq system-type 'gnu/linx) + :after foo + :load-path \"~/src/bar\" + :autoload bar-internal + :commands bar-status bar + :bind* ((\"C-x n\" . bar-status)) + :bind ((\"C-c n\" . bar) + :map bar-mode + (\"C-@\" . bar-bar) + :map bar-status-mode + (\"C-n\" . bar-next) + (\"C-c C-c\" . bar-do) + :repeat-map bar-repeat-map + (\"n\" . bar-next) + (\"c\" . bar-do)) + :bind-keymap (\"C-c b\" . bar-mode-map) + :custom + (bar-bool t) + (bar-string \"bar\") + (bar-list '(bar-1 bar-2 bar-3)) + (bar-list-2 `(,@bar-list bar-4)) + (bar-var my--foo) + :custom-face + (bar-face ((t (:slant italic)))) + (bar-highlight-face ((((class color) (background light)) + :background \"goldenrod1\") + (((class color) (background dark)) + :background \"DarkGoldenrod4\") + (t :inverse-video t))) + :hook ((prog-mode foo-mode) . bar-mode) + :mode \"\\\\.bar\\\\'\" + :magic \">>BAR<<\" + :magic-fallback \"<>\" + :config + ;; Extra configuration + (add-to-list 'bar-extensions 'foo-bar) + :catch (lambda (_ _) + (message \"Error package initialization\"))) + +(use-package baz + :unless (eq system-name \"bar\") + :after (foo bar) + :load-path (\"~/src/my/baz\" \"~/src/baz\") + :autoload (baz-1 baz-2) + :commands (baz) + :custom + ((baz-option t) + (bar-list '((baz-1 . baz-2))) + (baz-var my--foo)) + :hook ((prog-mode . baz-mode) + (bar-mode . baz-mode)) + :mode (\"\\\\.baz\\\\'\" . baz-mode) + :magic (\">>BAZ<<\" \"!XXBAZXX\")) + +(defun my--fun-1 (arg) + arg) + +(defun my--fun () + (prog1 (my--fun-1 'foo) + (ding))) +" + (home-emacs-configuration + (default-init + (emacs-configuration + (variables `((my--foo . 1) + (my--bar . symbol) + (my--baz . ,(elisp (list 'a + (unelisp-comment ";comment\n") 'b + 'c))) + (my--quux a b . c) + (my--quuux . ,(elisp (function my--fun))) + (foo-var . ,(elisp my--foo)))) + (modes `((foo-mode . #f) + (bar-mode . #t) + (baz-mode . #t) + (quux-mode . ,(elisp my--foo)))) + (keys '(("C-c b" . bar) + (#(remap bar) . baz) + ("C-c v" . quux) + ("C-c c" . quuux) + (#(t) . quuuux))) + (keys-override '(("M-" . scroll-down-line) + ("M-" . scroll-up-line))) + (extra-init + (list (elisp (defun my--fun-1 + (arg) arg)) + (elisp (defun my--fun () + (prog1 (my--fun-1 'foo) + (ding)))))))) + (configured-packages + (list (emacs-package + (name 'foo) + (load-force? #t) + (options `((foo-bar . baz) + (foo-baz . ,(elisp baz)))) + (hooks '((prog-mode . foo-mode))) + (extra-init + (list (elisp (unelisp-comment ";; Ding\n")) + (elisp (ding)) + (elisp (unelisp-newline)) + (elisp (message "Ding"))))) + (emacs-package + (name 'bar) + (load-predicates (list (elisp (eq system-type 'gnu/linx)))) + (load-after-packages '(foo)) + (load-paths '("~/src/bar")) + (autoloads '(bar-internal)) + (autoloads-interactive '(bar-status bar)) + (keys-global '(("C-c n" . bar))) + (keys-global-keymaps '(("C-c b" . bar-mode-map))) + (keys-override '(("C-x n" . bar-status))) + (keys-local (list (emacs-keymap + (name 'bar-mode) + (keys '(("C-@" . bar-bar)))) + (emacs-keymap + (name 'bar-status-mode) + (keys '(("C-n" . bar-next) + ("C-c C-c" . bar-do)))) + (emacs-keymap + (name 'bar-repeat-map) + (repeat? #t) + (keys '(("n" . bar-next) + ("c" . bar-do)))))) + (options `((bar-bool . #t) + (bar-string . "bar") + (bar-list bar-1 bar-2 bar-3) + (bar-list-2 . ,(elisp `(,@bar-list bar-4))) + (bar-var . ,(elisp my--foo)))) + (faces '((bar-face (t (:slant italic))) + (bar-highlight-face (((class color) + (background light)) + :background "goldenrod1") + (((class color) + (background dark)) + :background "DarkGoldenrod4") + (t :inverse-video t)))) + (hooks '((prog-mode . bar-mode) + (foo-mode . bar-mode))) + (auto-modes '(("\\.bar\\'" . bar))) + (magic-modes '((">>BAR<<" . bar))) + (extra-after-load + (list (elisp (unelisp-comment ";; Extra configuration\n")) + (elisp (add-to-list 'bar-extensions 'foo-bar)))) + (extra-keywords + `((:magic-fallback ,(elisp "<>")) + (:catch ,(elisp (lambda (_ _) + (message "Error package initialization"))))))) + (emacs-package + (name 'baz) + (load-predicates (list (elisp (not (eq system-name "bar"))))) + (load-after-packages '(foo bar)) + (load-paths '("~/src/my/baz" "~/src/baz")) + (autoloads '(baz-1 baz-2)) + (autoloads-interactive '(baz)) + (options `((baz-option . #t) + (bar-list (baz-1 . baz-2)) + (baz-var . ,(elisp my--foo)))) + (hooks '((prog-mode . baz-mode) + (bar-mode . baz-mode))) + (auto-modes '(("\\.baz\\'" . baz-mode))) + (magic-modes '((">>BAZ<<" . baz) + ("!XXBAZXX" . baz)))))))) + +(test-end "emacs-home-services") diff --git a/tests/read-print.scm b/tests/read-print.scm index 9e1d8038f1..479569e50d 100644 --- a/tests/read-print.scm +++ b/tests/read-print.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021-2023 Ludovic Courtès +;;; Copyright © 2023 Kierin Bell ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,7 +34,7 @@ (define-syntax-rule (test-pretty-print str args ...) (lambda (port) (let ((exp (call-with-input-string str read-with-comments))) - (pretty-print-with-comments port exp args ...)))))) + (pretty-print-with-comments port exp args ...)))))) (define-syntax-rule (test-pretty-print/sequence str args ...) "Likewise, but read and print entire sequences rather than individual @@ -45,6 +46,20 @@ (define-syntax-rule (test-pretty-print/sequence str args ...) read-with-comments/sequence))) (pretty-print-with-comments/splice port lst args ...)))))) +(define (read-with-comments-elisp port) + (read-with-comments port #:elisp? #t)) + +(define-syntax-rule (test-pretty-print-elisp str args ...) + "Test equality after a round-trip as with `test-pretty-print', but read and write Elisp." + (test-equal str + (call-with-output-string + (lambda (port) + (let ((exp (call-with-input-string str + read-with-comments-elisp))) + (pretty-print-with-comments port exp + #:elisp? #t + args ...)))))) + (test-begin "read-print") @@ -108,14 +123,71 @@ (define-syntax-rule (test-pretty-print/sequence str args ...) (read-with-comments port))))) (test-pretty-print "(list 1 2 3 4)") -(test-pretty-print "((a . 1) (b . 2))") +(test-pretty-print "\ +((a b) + (c d))") +(test-pretty-print "\ +((a . 1) + (b . 2))") +(test-pretty-print "((a b) c d)") (test-pretty-print "(a b c . boom)") +(test-pretty-print "`(a b . ,c)") +(test-pretty-print "`(a . ,(list a b c))") +(test-pretty-print "#(a b c)") + +(test-pretty-print "\ +(long-regexp-var-with-backlashes + \"[!?;.]\\\\|--\\\\|\\\\w\\\\{3,\\\\}\\\\.\\\\|:[[:blank:]]+\")" + #:max-width 78) + +(test-pretty-print "\ +((alist-key . alist-val) + (long-regexp-entry-with-backlashes + . \"[!?;.]\\\\|--\\\\|\\\\w\\\\{3,\\\\}\\\\.\\\\|:[[:blank:]]+\"))" + #:max-width 78) + +(test-pretty-print "\ +(long-variable-name-with-function-value + #~long-gexp-with-hash-read-syntax)" + #:max-width 50) + (test-pretty-print "(list 1 2 3 4)" #:long-list 3 #:indent 20) +(test-pretty-print "(1 2 3 4 5)" + #:long-list 5) +(test-pretty-print "\ +(1 + 2 + 3 + 4 + 5 + 6)" + #:long-list 5) +(test-pretty-print "(single constant)") +(test-pretty-print "\ +'(list + 2 + 3 + 4 + 5 + 6)" + #:long-list 5) +(test-pretty-print "\ +(1 + 2 + 3 + 4 + 5 + . 6)" + #:long-list 5) +(test-pretty-print "\ +(list + (initial-list-argument-with-long-element))" + #:max-width 40) (test-pretty-print "\ (list abc def)" @@ -305,8 +377,7 @@ (define-syntax-rule (test-pretty-print/sequence str args ...) (lambda _ #t)))) ((#:configure-flags flags) - `(cons \"--without-any-problem\" - ,flags)))") + `(cons \"--without-any-problem\" ,flags)))") (test-pretty-print "\ (vertical-space one: @@ -432,4 +503,164 @@ (define-module (foo bar) ;; two lines.\n") def))))) +(test-equal "read-with-comments, Elisp: integer" + 1 + (call-with-input-string "1" + read-with-comments-elisp)) + +(test-equal "read-with-comments, Elisp: float" + 1.0 + (call-with-input-string "1.0" + read-with-comments-elisp)) + +(test-equal "read-with-comments, Elisp: basic character" + #\a + (call-with-input-string "?a" + read-with-comments-elisp)) + +(test-equal "read-with-comments, Elisp: control character" + #\alarm + (call-with-input-string "?\\a" + read-with-comments-elisp)) + +(test-equal "read-with-comments, Elisp: codepoint character" + #\x2014 + (call-with-input-string "?\\u2014" + read-with-comments-elisp)) + +(test-equal "read-with-comments, Elisp: dot notation" + (cons 'a 'b) + (call-with-input-string "(a . b)" + read-with-comments-elisp)) + +(test-equal "read-with-comments, Elisp: vector" + #(a b c) + (call-with-input-string "[a b c]" + read-with-comments-elisp)) + +(test-equal "read-with-comments, Elisp: vector with comment" + (list->array 1 `(a ,(comment ";comment\n" #t) b c)) + (call-with-input-string "\ +[a ;comment +b c]" + read-with-comments-elisp)) + +(test-pretty-print-elisp "?a") +(test-pretty-print-elisp "?\\a") +(test-pretty-print-elisp "?à") +(test-pretty-print-elisp "?\\u2014") +(test-pretty-print-elisp "224") +(test-pretty-print-elisp "224.5") +(test-pretty-print-elisp "-224.5") +(test-pretty-print-elisp "\"string\"") +(test-pretty-print-elisp "symbol") +(test-pretty-print-elisp "'quoted-symbol") +(test-pretty-print-elisp "symbol\\.with\\,escapes") +(test-pretty-print-elisp "123non-confusable-symbol") +(test-pretty-print-elisp "\\123e0") +(test-pretty-print-elisp ":keyword*") + +(test-pretty-print-elisp "(a b c)") +(test-pretty-print-elisp "(a . b)") +(test-pretty-print-elisp "(a b . c)") +(test-pretty-print-elisp "`(a b ,c)") +(test-pretty-print-elisp "`(a b . ,c)") +(test-pretty-print-elisp "(a b 'c)") + +(test-pretty-print-elisp "\ +(foo arg1 + #'longer-than + arg3 arg4)" + #:max-width 15) +(test-pretty-print-elisp "\ +(foo + (list + longer) + b c)" + #:max-width 10) +(test-pretty-print-elisp "\ +(foo + #'longer-than + arg1 arg2)" + #:max-width 10) +(test-pretty-print-elisp "\ +(a + #'longer-than + b . c)" + #:max-width 10) + +(test-pretty-print-elisp "\ +(defun foo (x y) + ;; Comment + (let ((z (+ x y))) + (* z z)))") + +(test-pretty-print-elisp "[a b c]") +(test-pretty-print-elisp "\ +[long-symbol + b c d]" + #:max-width 10) +(test-pretty-print-elisp "\ +[(long + list xx) + b c d]" + #:max-width 10) + +(test-pretty-print-elisp "\ +(defun foo () + (dlet ((x '((a b . \"c\")))) + x))") + +(test-pretty-print-elisp "\ +(defvar foo value)") + +(test-pretty-print-elisp "\ +(defvar foo #'foo-function + \"Foo function.\")") + +(test-pretty-print-elisp "\ +(if (fboundp 'foo-function) + (ding) + (autoload #'foo-function \"foo\" + \"Return foo.\"))") + +(test-pretty-print-elisp "\ +(long-variable-name-with-function-value + #'long-function-name-with-hash-read-syntax)" + #:max-width 78) +(test-pretty-print-elisp "\ +(a b ; Comment + c + d + + e + f)" + #:long-list 5) + +(test-pretty-print-elisp "\ +[a + b ; Comment + c + d + + e + f]" + #:long-list 5) + +(test-pretty-print-elisp "\ +(use-package foo + :bind ((\"C-c n\" . foo)) + :custom (foo-bar 'bar) + (foo-baz my--baz) + :init (ding))" + #:special-forms '((use-package . 1))) + +;; Newline after list arguments for special forms +(test-pretty-print-elisp "\ +(with-current-buffer-window (setq buf + (get-buffer-create buf-name)) + (cd-absolute directory) + (call-process-shell-command \"ls -l | sort -t _ -k 2\" nil t) + (dired-virtual directory))") + (test-end) base-commit: a33a335c89ce3766e2bd662bffc897bd0da2b9cd -- 2.40.1