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
|
;;; 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 import elm)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (guix utils)
#:use-module (guix base32)
#:use-module (guix hash)
#:use-module (guix http-client)
#:use-module (guix memoization)
#:use-module (guix diagnostics)
#:use-module (guix i18n)
#:use-module (guix import utils)
#:use-module (guix git)
#:use-module (guix import json)
#:autoload (gcrypt hash) (hash-algorithm sha256)
#:use-module (json)
#:use-module (guix build-system elm)
#:export (elm-recursive-import
%elm-package-registry
%current-elm-checkout
elm->guix-package))
(define %registry-url
;; It is much nicer to fetch this small (< 40 KB gzipped)
;; file once than to do many HTTP requests.
"https://package.elm-lang.org/all-packages")
(define %elm-package-registry
;; This is a parameter to support both testing and memoization.
;; In pseudo-code, it has the contract:
;; (parameter/c (-> json/c)
;; (promise/c (vhash/c string? (listof string?))))
;; To set the parameter, provide a thunk that returns a value suitable
;; as an argument to 'json->registry-vhash'. Accessing the parameter
;; returns a promise wrapping the resulting vhash.
(make-parameter
(lambda ()
(cond
((json-fetch %registry-url #:http-fetch http-fetch/cached))
(else
(raise (formatted-message
(G_ "error downloading Elm package registry from ~a")
%registry-url)))))
(lambda (thunk)
(delay (json->registry-vhash (thunk))))))
(define (json->registry-vhash jsobject)
"Parse the '(json)' module's representation of the Elm package registry to a
vhash mapping package names to lists of available versions, sorted from latest
to oldest."
(fold (lambda (entry vh)
(match entry
((name . vec)
(vhash-cons name
(sort (vector->list vec) version>?)
vh))))
vlist-null
jsobject))
(define (json->direct-dependencies jsobject)
"Parse the '(json)' module's representation of an 'elm.json' file's
'dependencies' or 'test-dependencies' field to a list of strings naming direct
dependencies, handling both the 'package' and 'application' grammars."
(cond
;; *unspecified*
((not (pair? jsobject))
'())
;; {"type":"application"}
((every (match-lambda
(((or "direct" "indirect") (_ . _) ...)
#t)
(_
#f))
jsobject)
(map car (or (assoc-ref jsobject "direct") '())))
;; {"type":"package"}
(else
(map car jsobject))))
;; <project-info> handles both {"type":"package"} and {"type":"application"}
(define-json-mapping <project-info> make-project-info project-info?
json->project-info
(dependencies project-info-dependencies
"dependencies" json->direct-dependencies)
(test-dependencies project-info-test-dependencies
"test-dependencies" json->direct-dependencies)
;; "synopsis" and "license" may be missing for {"type":"application"}
(synopsis project-info-synopsis
"summary" (lambda (x)
(if (string? x)
x
"")))
(license project-info-license
"license" (lambda (x)
(if (string? x)
(spdx-string->license x)
#f))))
(define %current-elm-checkout
;; This is a parameter for testing purposes.
(make-parameter
(lambda (name version)
(define-values (checkout _commit _relation)
;; Elm requires that packages use this very specific format
(update-cached-checkout (string-append "https://github.com/" name)
#:ref `(tag . ,version)))
checkout)))
(define (make-elm-package-sexp name version)
"Return two values: the `package' s-expression for the Elm package with the
given NAME and VERSION, and a list of Elm packages it depends on."
(define checkout
((%current-elm-checkout) name version))
(define info
(call-with-input-file (string-append checkout "/elm.json")
json->project-info))
(define dependencies
(project-info-dependencies info))
(define test-dependencies
(project-info-test-dependencies info))
(define guix-name
(elm->package-name name))
(values
`(package
(name ,guix-name)
(version ,version)
(source (elm-package-origin
,name
version ;; no ,
(base32
,(bytevector->nix-base32-string
(file-hash* checkout
#:algorithm (hash-algorithm sha256)
#:recursive? #t)))))
(build-system elm-build-system)
,@(maybe-propagated-inputs (map elm->package-name dependencies))
,@(maybe-inputs (map elm->package-name test-dependencies))
(home-page ,(string-append "https://package.elm-lang.org/packages/"
name "/" version))
(synopsis ,(project-info-synopsis info))
(description
;; Try to use the first paragraph of README.md (which Elm requires),
;; or fall back to synopsis otherwise.
,(beautify-description
(match (chunk-lines (call-with-input-file
(string-append checkout "/README.md")
read-lines))
((_ par . _)
(string-join par " "))
(_
(project-info-synopsis info)))))
,@(let ((inferred-name (infer-elm-package-name guix-name)))
(if (equal? inferred-name name)
'()
`((properties '((upstream-name . ,name))))))
(license ,(project-info-license info)))
(append dependencies test-dependencies)))
(define elm->guix-package
(memoize
(lambda* (package-name #:key version #:allow-other-keys)
"Fetch the metadata for PACKAGE-NAME, an Elm package registered at
package.elm.org, and return two values: the `package' s-expression
corresponding to that package (or #f on failure) and a list of Elm
dependencies."
(cond
((vhash-assoc package-name (force (%elm-package-registry)))
=> (match-lambda
((_found latest . _versions)
(make-elm-package-sexp package-name (or version latest)))))
(else
(values #f '()))))))
(define* (elm-recursive-import package-name #:optional version)
(recursive-import package-name
#:version version
#:repo->guix-package elm->guix-package
#:guix-name elm->package-name))
|
