diff options
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/bzr.scm | 8 | ||||
-rw-r--r-- | guix/build/elm-build-system.scm | 380 | ||||
-rw-r--r-- | guix/build/emacs-utils.scm | 47 |
3 files changed, 419 insertions, 16 deletions
diff --git a/guix/build/bzr.scm b/guix/build/bzr.scm index 86ee11391d..a0f5e15880 100644 --- a/guix/build/bzr.scm +++ b/guix/build/bzr.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2018, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,7 +28,7 @@ ;;; Code: (define* (bzr-fetch url revision directory - #:key (bzr-command "bzr")) + #:key (bzr-command "brz")) "Fetch REVISION from URL into DIRECTORY. REVISION must be a valid Bazaar revision identifier. Return #t on success, else throw an exception." ;; Do not attempt to write .bzr.log to $HOME, which doesn't exist. @@ -37,8 +37,6 @@ revision identifier. Return #t on success, else throw an exception." (invoke bzr-command "-Ossl.cert_reqs=none" "checkout" "--lightweight" "-r" revision url directory) (with-directory-excursion directory - (begin - (delete-file-recursively ".bzr") - #t))) + (delete-file-recursively ".bzr"))) ;;; bzr.scm ends here diff --git a/guix/build/elm-build-system.scm b/guix/build/elm-build-system.scm new file mode 100644 index 0000000000..02d7c029dd --- /dev/null +++ b/guix/build/elm-build-system.scm @@ -0,0 +1,380 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build elm-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (guix build json) + #:use-module (guix build union) + #:use-module (ice-9 ftw) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:export (%standard-phases + patch-application-dependencies + patch-json-string-escapes + read-offline-registry->vhash + elm-build)) + +;;; Commentary: +;;; +;;; Elm draws a sharp distinction between "projects" with `{"type":"package"}` +;;; vs. `{"type":"application"}` in the "elm.json" file: see +;;; <https://github.com/elm/compiler/blob/master/docs/elm.json/package.md> and +;;; <https://github.com/elm/compiler/blob/master/docs/elm.json/application.md>. +;;; For now, `elm-build-system` is designed for "package"s: packaging +;;; "application"s requires ad-hoc replacements for some phases---but see +;;; `patch-application-dependencies`, which helps to work around a known issue +;;; discussed below. It would be nice to add more streamlined support for +;;; "application"s one we have more experience building them in Guix. For +;;; example, we could incorporate the `uglifyjs` advice from +;;; <https://github.com/elm/compiler/blob/master/hints/optimize.md>. +;;; +;;; We want building an Elm "package" to produce: +;;; +;;; - a "docs.json" file with extracted documentation; and +;;; +;;; - an "artifacts.dat" file with compilation results for use in building +;;; "package"s and "application"s. +;;; +;;; Unfortunately, there isn't an entry point to the Elm compiler that builds +;;; those files directly. Building with `elm make` does something different, +;;; more oriented toward development, testing, and building "application"s. +;;; We work around this limitation by staging the "package" we're building as +;;; though it were already installed in ELM_HOME, generating a trivial Elm +;;; "application" that depends on the "package", and building the +;;; "application", which causes the files for the "package" to be built. +;;; +;;; Much of the ceremony involved is to avoid using `elm` in ways that would +;;; make it try to do network IO beyond the bare minimum functionality for +;;; which we've patched a replacement into our `elm`. On the other hand, we +;;; get to take advantage of the very regular structure required of Elm +;;; packages. +;;; +;;; *Known issue:* Elm itself supports multiple versions of "package"s +;;; coexisting simultaneously under ELM_HOME, but we do not support this yet. +;;; Sometimes, parallel versions coexisting causes `elm` to try to write to +;;; built "artifacts.dat" files. For now, two workarounds are possible: +;;; +;;; - Use `patch-application-dependencies` to rewrite an "application"'s +;;; "elm.json" file to refer to the versions of its inputs actually +;;; packaged in Guix. +;;; +;;; - Use a Guix package transformation to rewrite your "application"'s +;;; dependencies recursively, so that only one version of each Elm +;;; "package" is included in your "application"'s build environment. +;;; +;;; Patching `elm` more extensively---perhaps adding an `elm guix` +;;; subcommand`---might let us address these issues more directly. +;;; +;;; Code: +;;; + +(define %essential-elm-packages + ;; elm/json isn't essential in a fundamental sense, + ;; but it's required for a {"type":"application"}, + ;; which we are generating to trigger the build + '("elm/core" "elm/json")) + +(define* (target-elm-version #:optional elm) + "Return the version of ELM or whichever 'elm' is in $PATH. +Return #false if it cannot be determined." + (let* ((pipe (open-pipe* OPEN_READ + (or elm "elm") + "--version")) + (line (read-line pipe))) + (and (zero? (close-pipe pipe)) + (string? line) + line))) + +(define* (prepare-elm-home #:key native-inputs inputs #:allow-other-keys) + "Set the ELM_HOME environment variable and populate the indicated directory +with the union of the Elm \"package\" inputs. Also, set GUIX_ELM_VERSION to +the version of the Elm compiler in use." + (let* ((elm (search-input-file (or native-inputs inputs) "/bin/elm")) + (elm-version (target-elm-version elm))) + (setenv "GUIX_ELM_VERSION" elm-version) + (mkdir "../elm-home") + (with-directory-excursion "../elm-home" + (union-build elm-version + (search-path-as-list + (list (string-append "share/elm/" elm-version)) + (map cdr inputs)) + #:create-all-directories? #t) + (setenv "ELM_HOME" (getcwd))))) + +(define* (stage #:key native-inputs inputs #:allow-other-keys) + "Extract the installable files from the Elm \"package\" into a staging +directory and link it into the ELM_HOME tree. Also, set GUIX_ELM_PKG_NAME and +GUIX_ELM_PKG_VERSION to the name and version, respectively, of the Elm package +being built, as defined in its \"elm.json\" file." + (let* ((elm-version (getenv "GUIX_ELM_VERSION")) + (elm-home (getenv "ELM_HOME")) + (info (match (call-with-input-file "elm.json" read-json) + (('@ . alist) alist))) + (name (assoc-ref info "name")) + (version (assoc-ref info "version")) + (rel-dir (string-append elm-version "/packages/" name "/" version)) + (staged-dir (string-append elm-home "/../staged/" rel-dir))) + (setenv "GUIX_ELM_PKG_NAME" name) + (setenv "GUIX_ELM_PKG_VERSION" version) + (mkdir-p staged-dir) + (mkdir-p (string-append elm-home "/" (dirname rel-dir))) + (symlink staged-dir + (string-append elm-home "/" rel-dir)) + (copy-recursively "src" (string-append staged-dir "/src")) + (install-file "elm.json" staged-dir) + (install-file "README.md" staged-dir) + (when (file-exists? "LICENSE") + (install-file "LICENSE" staged-dir)))) + +(define (patch-json-string-escapes file) + "Work around a bug in the Elm compiler's JSON parser by attempting to +replace REVERSE-SOLIDUS--SOLIDUS escape sequences in FILE with unescaped +SOLIDUS characters." + ;; https://github.com/elm/compiler/issues/2255 + (substitute* file + (("\\\\/") + "/"))) + +(define (directory-list dir) + "Like DIRECTORY-LIST from 'racket/base': lists the contents of DIR, not +including the special \".\" and \"..\" entries." + (scandir dir (lambda (f) + (not (member f '("." "..")))))) + +(define* (make-offline-registry-file #:key inputs #:allow-other-keys) + "Generate an \"offline-package-registry.json\" file and set +GUIX_ELM_OFFLINE_REGISTRY_FILE to its path, cooperating with a patch to `elm` +to avoid attempting to download a list of all published Elm package names and +versions from the internet." + (let* ((elm-home (getenv "ELM_HOME")) + (elm-version (getenv "GUIX_ELM_VERSION")) + (registry-file + (string-append elm-home "/../offline-package-registry.json")) + (registry-alist + ;; here, we don't need to look up entries, so we build the + ;; alist directly, rather than using a vhash + (with-directory-excursion + (string-append elm-home "/" elm-version "/packages") + (append-map (lambda (org) + (with-directory-excursion org + (map (lambda (repo) + (cons (string-append org "/" repo) + (directory-list repo))) + (directory-list ".")))) + (directory-list "."))))) + (call-with-output-file registry-file + (lambda (out) + (write-json `(@ ,@registry-alist) out))) + (patch-json-string-escapes registry-file) + (setenv "GUIX_ELM_OFFLINE_REGISTRY_FILE" registry-file))) + +(define (read-offline-registry->vhash) + "Return a vhash mapping Elm \"package\" names to lists of available version +strings." + (alist->vhash + (match (call-with-input-file (getenv "GUIX_ELM_OFFLINE_REGISTRY_FILE") + read-json) + (('@ . alist) alist)))) + +(define (find-indirect-dependencies registry-vhash root-pkg root-version) + "Return the recursive dependencies of ROOT-PKG, an Elm \"package\" name, at +version ROOT-VERSION as an alist mapping Elm \"package\" names to (single) +versions. The resulting alist will not include entries for +%ESSENTIAL-ELM-PACKAGES or for ROOT-PKG itself. The REGISTRY-VHASH is used in +conjunction with the ELM_HOME environment variable to find dependencies." + (with-directory-excursion + (string-append (getenv "ELM_HOME") + "/" (getenv "GUIX_ELM_VERSION") + "/packages") + (define (get-dependencies pkg version acc) + (let* ((elm-json-alist + (match (call-with-input-file + (string-append pkg "/" version "/elm.json") + read-json) + (('@ . alist) alist))) + (deps-alist + (match (assoc-ref elm-json-alist "dependencies") + (('@ . alist) alist))) + (deps-names + (filter-map (match-lambda + ((name . range) + (and (not (member name %essential-elm-packages)) + name))) + deps-alist))) + (fold register-dependency acc deps-names))) + (define (register-dependency pkg acc) + ;; Using vhash-cons unconditionally would add duplicate entries, + ;; which would then cause problems when we must emit JSON. + ;; Plus, we can avoid needlessly duplicating work. + (if (vhash-assoc pkg acc) + acc + (match (vhash-assoc pkg registry-vhash) + ((_ version . _) + ;; in the rare case that multiple versions are present, + ;; just picking an arbitrary one seems to work well enough for now + (get-dependencies pkg version (vhash-cons pkg version acc)))))) + (vlist->list + (get-dependencies root-pkg root-version vlist-null)))) + +(define* (patch-application-dependencies #:key inputs #:allow-other-keys) + "Rewrites the \"elm.json\" file in the working directory---which must be of +`\"type\":\"application\"`, not `\"type\":\"package\"`---to refer to the +dependency versions actually provided via Guix. The +GUIX_ELM_OFFLINE_REGISTRY_FILE environment variable is used to find available +versions." + (let* ((registry-vhash (read-offline-registry->vhash)) + (rewrite-dep-version + (match-lambda + ((name . _) + (cons name (match (vhash-assoc name registry-vhash) + ((_ version) ;; no dot + version)))))) + (rewrite-direct/indirect + (match-lambda + ;; a little checking to avoid confusing misuse with "package" + ;; project dependencies, which have a different shape + (((and key (or "direct" "indirect")) + '@ . alist) + `(,key @ ,@(map rewrite-dep-version alist))))) + (rewrite-json-section + (match-lambda + (((and key (or "dependencies" "test-dependencies")) + '@ . alist) + `(,key @ ,@(map rewrite-direct/indirect alist))) + ((k . v) + (cons k v)))) + (rewrite-elm-json + (match-lambda + (('@ . alist) + `(@ ,@(map rewrite-json-section alist)))))) + (with-atomic-file-replacement "elm.json" + (lambda (in out) + (write-json (rewrite-elm-json (read-json in)) + out))) + (patch-json-string-escapes "elm.json"))) + +(define* (configure #:key native-inputs inputs #:allow-other-keys) + "Generate a trivial Elm \"application\" with a direct dependency on the Elm +\"package\" currently being built." + (let* ((info (match (call-with-input-file "elm.json" read-json) + (('@ . alist) alist))) + (name (getenv "GUIX_ELM_PKG_NAME")) + (version (getenv "GUIX_ELM_PKG_VERSION")) + (elm-home (getenv "ELM_HOME")) + (registry-vhash (read-offline-registry->vhash)) + (app-dir (string-append elm-home "/../fake-app"))) + (mkdir-p (string-append app-dir "/src")) + (with-directory-excursion app-dir + (call-with-output-file "elm.json" + (lambda (out) + (write-json + `(@ ("type" . "application") + ("source-directories" "src") ;; intentionally no dot + ("elm-version" . ,(getenv "GUIX_ELM_VERSION")) + ("dependencies" + @ ("direct" + @ ,@(map (lambda (pkg) + (match (vhash-assoc pkg registry-vhash) + ((_ pkg-version . _) + (cons pkg + (if (equal? pkg name) + version + pkg-version))))) + (if (member name %essential-elm-packages) + %essential-elm-packages + (cons name %essential-elm-packages)))) + ("indirect" + @ ,@(if (member name %essential-elm-packages) + '() + (find-indirect-dependencies registry-vhash + name + version)))) + ("test-dependencies" + @ ("direct" @) + ("indirect" @))) + out))) + (patch-json-string-escapes "elm.json") + (with-output-to-file "src/Main.elm" + ;; the most trivial possible elm program + (lambda () + (display "module Main exposing (..) +main : Program () () () +main = Platform.worker + { init = \\_ -> ( (), Cmd.none ) + , update = \\_ -> \\_ -> ( (), Cmd.none ) + , subscriptions = \\_ -> Sub.none }")))))) + +(define* (build #:key native-inputs inputs #:allow-other-keys) + "Run `elm make` to build the Elm \"application\" generated by CONFIGURE." + (with-directory-excursion (string-append (getenv "ELM_HOME") "/../fake-app") + (invoke (search-input-file (or native-inputs inputs) "/bin/elm") + "make" + "src/Main.elm"))) + +(define* (check #:key tests? #:allow-other-keys) + "Does nothing, because the `elm-test` executable has not yet been packaged +for Guix." + (when tests? + (display "elm-test has not yet been packaged for Guix\n"))) + +(define* (install #:key outputs #:allow-other-keys) + "Installs the contents of the directory generated by STAGE, including any +files added by BUILD, to the Guix package output." + (copy-recursively + (string-append (getenv "ELM_HOME") "/../staged") + (string-append (assoc-ref outputs "out") "/share/elm"))) + +(define* (validate-compiled #:key outputs #:allow-other-keys) + "Checks that the files \"artifacts.dat\" and \"docs.json\" have been +installed." + (let ((base (string-append "/share/elm/" + (getenv "GUIX_ELM_VERSION") + "/packages/" + (getenv "GUIX_ELM_PKG_NAME") + "/" + (getenv "GUIX_ELM_PKG_VERSION"))) + (expected '("artifacts.dat" "docs.json"))) + (for-each (lambda (name) + (search-input-file outputs (string-append base "/" name))) + expected))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (add-after 'unpack 'prepare-elm-home prepare-elm-home) + (delete 'bootstrap) + (add-after 'patch-source-shebangs 'stage stage) + (add-after 'stage 'make-offline-registry-file make-offline-registry-file) + (replace 'configure configure) + (delete 'patch-generated-file-shebangs) + (replace 'build build) + (replace 'check check) + (replace 'install install) + (add-before 'validate-documentation-location 'validate-compiled + validate-compiled))) + +(define* (elm-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Builds the given Elm project, applying all of the PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index 64ef40e25a..60a754b9e9 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> -;;; Copyright © 2018, 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2018, 2020, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2019 Liliana Marie Prikler <liliana.prikler@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -28,6 +28,8 @@ emacs-batch-disable-compilation emacs-generate-autoloads emacs-byte-compile-directory + + as-display emacs-substitute-sexps emacs-substitute-variables)) @@ -82,6 +84,24 @@ true, evaluate using dynamic scoping." (byte-recompile-directory (file-name-as-directory ,dir) 0 1)))) (emacs-batch-eval expr))) +(define as-display ;syntactic keyword for 'emacs-substitute-sexps' + '(as display)) + +(define-syntax replacement-helper + (syntax-rules (as-display) + ((_ (leading-regexp replacement (as-display))) + `(progn (goto-char (point-min)) + (re-search-forward ,leading-regexp) + (kill-sexp) + (insert " ") + (insert ,(format #f "~a" replacement)))) + ((_ (leading-regexp replacement)) + `(progn (goto-char (point-min)) + (re-search-forward ,leading-regexp) + (kill-sexp) + (insert " ") + (insert ,(format #f "~s" replacement)))))) + (define-syntax emacs-substitute-sexps (syntax-rules () "Substitute the S-expression immediately following the first occurrence of @@ -95,14 +115,15 @@ LEADING-REGEXP by the string returned by REPLACEMENT in FILE. For example: This replaces the default values of the `w3m-command' and `w3m-image-viewer' variables declared in `w3m.el' with the results of the `string-append' calls -above. Note that LEADING-REGEXP uses Emacs regexp syntax." - ((emacs-substitute-sexps file (leading-regexp replacement) ...) +above. Note that LEADING-REGEXP uses Emacs regexp syntax. + +Here is another example that uses the '(as-display)' subform to avoid having +the Elisp procedure symbol from being double quoted: + (emacs-substitute-sexps \"gnugo.el\" + (\"defvar gnugo-xpms\" \"#'gnugo-imgen-create-xpms\" (as-display))" + ((_ file replacement-spec ...) (emacs-batch-edit-file file - `(progn (progn (goto-char (point-min)) - (re-search-forward ,leading-regexp) - (kill-sexp) - (insert " ") - (insert ,(format #f "~S" replacement))) + `(progn ,(replacement-helper replacement-spec) ... (basic-save-buffer)))))) @@ -117,11 +138,15 @@ REPLACEMENT in FILE. For example: This replaces the default values of the `w3m-command' and `w3m-image-viewer' variables declared in `w3m.el' with the results of the `string-append' calls -above." - ((emacs-substitute-variables file (variable replacement) ...) +above. Similarly to `emacs-substitute-sexps', the '(as-display)' subform can +be used to have the replacement formatted like `display' would, which can be +useful to avoid double quotes being added when the replacement is provided as +a string." + ((_ file (variable replacement modifier ...) ...) (emacs-substitute-sexps file ((string-append "(def[a-z]+[[:space:]\n]+" variable "\\>") - replacement) + replacement + modifier ...) ...)))) ;;; emacs-utils.scm ends here |