diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/elm.scm | 172 | ||||
| -rw-r--r-- | guix/build/elm-build-system.scm | 380 |
2 files changed, 552 insertions, 0 deletions
diff --git a/guix/build-system/elm.scm b/guix/build-system/elm.scm new file mode 100644 index 0000000000..b54954bf4e --- /dev/null +++ b/guix/build-system/elm.scm @@ -0,0 +1,172 @@ +;;; 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-system elm) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix search-paths) + #:use-module (guix git-download) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (elm->package-name + guix-package->elm-name + infer-elm-package-name + elm-package-origin + %elm-build-system-modules + %elm-default-modules + elm-build + elm-build-system)) + +(define (elm->package-name name) + "Given the NAME of an Elm package, return a Guix-style package name." + (let ((converted + (string-join (string-split (string-downcase name) #\/) "-"))) + (if (string-prefix? "elm-" converted) + converted + (string-append "elm-" converted)))) + +(define (guix-package->elm-name package) + "Given an Elm PACKAGE, return the possibly-inferred upstream name, or #f the +upstream name is not specified and can't be inferred." + (or (assoc-ref (package-properties package) 'upstream-name) + (infer-elm-package-name (package-name package)))) + +(define (infer-elm-package-name guix-name) + "Given the GUIX-NAME of an Elm package, return the inferred upstream name, +or #f if it can't be inferred. If the result is not #f, supplying it to +'elm->package-name' would produce GUIX-NAME. + +See also 'guix-package->elm-name', which respects the 'upstream-name' +property." + (define (parts-join part0 parts) + (string-join (cons part0 parts) "-")) + (match (string-split guix-name #\-) + (("elm" "explorations" part0 parts ...) + (string-append "elm-explorations/" + (parts-join part0 parts))) + (("elm" owner part0 parts ...) + (string-append owner "/" (parts-join part0 parts))) + (("elm" repo) + (string-append "elm/" repo)) + (_ + #f))) + +(define (elm-package-origin elm-name version hash) + "Return an origin for the Elm package with upstream name ELM-NAME at the +given VERSION with sha256 checksum HASH." + ;; elm requires this very specific repository structure and tagging regime + (origin + (method git-fetch) + (uri (git-reference + (url (string-append "https://github.com/" elm-name)) + (commit version))) + (file-name (git-file-name (elm->package-name elm-name) version)) + (sha256 hash))) + +(define %elm-build-system-modules + ;; Build-side modules imported by default. + `((guix build elm-build-system) + (guix build json) + (guix build union) + ,@%gnu-build-system-modules)) + +(define %elm-default-modules + ;; Modules in scope in the build-side environment. + '((guix build elm-build-system) + (guix build utils) + (guix build json) + (guix build union))) + +(define (default-elm) + "Return the default Elm package for builds." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((elm (resolve-interface '(gnu packages elm)))) + (module-ref elm 'elm))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (implicit-elm-package-inputs? #t) + (elm (default-elm)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:target #:implicit-elm-package-inputs? #:elm #:inputs #:native-inputs)) + (cond + (target + ;; Cross-compilation is not yet supported. It should be easy, though, + ;; since the build products are all platform-independent. + #f) + (else + (bag + (name name) + (system system) + (host-inputs + `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ("elm" ,elm) + ;; TODO: probably don't need most of (standard-packages) + ,@(standard-packages))) + (outputs outputs) + (build elm-build) + (arguments (strip-keyword-arguments private-keywords arguments)))))) + +(define* (elm-build name inputs + #:key + source + (tests? #t) + (phases '%standard-phases) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %elm-build-system-modules) + (modules %elm-default-modules)) + "Build SOURCE using ELM." + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (elm-build #:name #$name + #:source #+source + #:system #$system + #:tests? #$tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) + +(define elm-build-system + (build-system + (name 'elm) + (description "The Elm build system") + (lower lower))) 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)) |