381 lines
17 KiB
Scheme
381 lines
17 KiB
Scheme
|
;;; 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))
|