summaryrefslogtreecommitdiff
path: root/guix/build/elm-build-system.scm
blob: 02d7c029dd9b84e7f81d6d14e4dde9c7a6b1b2a4 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
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))