1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
4 ;;; This file is part of GNU Guix.
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (guix import opam)
20 #:use-module (ice-9 ftw)
21 #:use-module (ice-9 match)
22 #:use-module (ice-9 peg)
23 #:use-module (ice-9 receive)
24 #:use-module ((ice-9 rdelim) #:select (read-line))
25 #:use-module (ice-9 textual-ports)
26 #:use-module (ice-9 vlist)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-2)
29 #:use-module (web uri)
30 #:use-module (guix build-system)
31 #:use-module (guix build-system ocaml)
32 #:use-module (guix http-client)
33 #:use-module (guix git)
34 #:use-module (guix ui)
35 #:use-module (guix packages)
36 #:use-module (guix upstream)
37 #:use-module (guix utils)
38 #:use-module (guix import utils)
39 #:use-module ((guix licenses) #:prefix license:)
40 #:export (opam->guix-package
44 ;; The following patterns are exported for testing purposes.
51 ;; Define a PEG parser for the opam format
52 (define-peg-pattern comment none (and "#" (* STRCHR) "\n"))
53 (define-peg-pattern SP none (or " " "\n" comment))
54 (define-peg-pattern SP2 body (or " " "\n"))
55 (define-peg-pattern QUOTE none "\"")
56 (define-peg-pattern QUOTE2 body "\"")
57 (define-peg-pattern COLON none ":")
58 ;; A string character is any character that is not a quote, or a quote preceded by a backslash.
59 (define-peg-pattern STRCHR body
60 (or " " "!" "\n" (and (ignore "\\") "\"")
61 (and (ignore "\\") "\\") (range #\# #\頋)))
62 (define-peg-pattern operator all (or "=" "!" "<" ">"))
64 (define-peg-pattern records body (* (and (or record weird-record) (* SP))))
65 (define-peg-pattern record all (and key COLON (* SP) value))
66 (define-peg-pattern weird-record all (and key (* SP) dict))
67 (define-peg-pattern key body (+ (or (range #\a #\z) "-")))
68 (define-peg-pattern value body (and (or conditional-value ground-value operator) (* SP)))
69 (define-peg-pattern choice-pat all (and (ignore "(") (* SP) choice (* SP) (ignore ")")))
70 (define-peg-pattern choice body
71 (or (and (or conditional-value ground-value) (* SP) (ignore "|") (* SP) choice)
74 (define-peg-pattern ground-value body (and (or multiline-string string-pat choice-pat list-pat var) (* SP)))
75 (define-peg-pattern conditional-value all (and ground-value (* SP) condition))
76 (define-peg-pattern string-pat all (and QUOTE (* STRCHR) QUOTE))
77 (define-peg-pattern list-pat all (and (ignore "[") (* SP) (* (and value (* SP))) (ignore "]")))
78 (define-peg-pattern var all (+ (or (range #\a #\z) "-")))
79 (define-peg-pattern multiline-string all
80 (and QUOTE QUOTE QUOTE (* SP)
81 (* (or SP2 STRCHR (and QUOTE2 (not-followed-by QUOTE))
82 (and QUOTE2 QUOTE2 (not-followed-by QUOTE))))
84 (define-peg-pattern dict all (and (ignore "{") (* SP) records (* SP) (ignore "}")))
86 (define-peg-pattern condition body (and (ignore "{") condition-form (ignore "}")))
88 (define-peg-pattern condition-form body
91 (or condition-and condition-or condition-form2)
93 (define-peg-pattern condition-form2 body
94 (and (* SP) (or condition-greater-or-equal condition-greater
95 condition-lower-or-equal condition-lower
96 condition-neq condition-eq condition-not
97 condition-content) (* SP)))
99 ;(define-peg-pattern condition-operator all (and (ignore operator) (* SP) condition-string))
100 (define-peg-pattern condition-greater-or-equal all (and (ignore (and ">" "=")) (* SP) condition-string))
101 (define-peg-pattern condition-greater all (and (ignore ">") (* SP) condition-string))
102 (define-peg-pattern condition-lower-or-equal all (and (ignore (and "<" "=")) (* SP) condition-string))
103 (define-peg-pattern condition-lower all (and (ignore "<") (* SP) condition-string))
104 (define-peg-pattern condition-and all (and condition-form2 (* SP) (? (ignore "&")) (* SP) condition-form))
105 (define-peg-pattern condition-or all (and condition-form2 (* SP) (ignore "|") (* SP) condition-form))
106 (define-peg-pattern condition-eq all (and (? condition-content) (* SP) (ignore "=") (* SP) condition-content))
107 (define-peg-pattern condition-neq all (and (? condition-content) (* SP) (ignore (and "!" "=")) (* SP) condition-content))
108 (define-peg-pattern condition-not all (and (ignore (and "!")) (* SP) condition-content))
109 (define-peg-pattern condition-content body (or condition-paren condition-string condition-var))
110 (define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!"))))
111 (define-peg-pattern condition-paren body (and "(" condition-form ")"))
112 (define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE))
113 (define-peg-pattern condition-var all (+ (or (range #\a #\z) "-" ":")))
115 (define (get-opam-repository)
116 "Update or fetch the latest version of the opam repository and return the
117 path to the repository."
118 (receive (location commit _)
119 (update-cached-checkout "https://github.com/ocaml/opam-repository")
122 (define (latest-version versions)
123 "Find the most recent version from a list of versions."
124 (fold (lambda (a b) (if (version>? a b) a b)) (car versions) versions))
126 (define (find-latest-version package repository)
127 "Get the latest version of a package as described in the given repository."
128 (let* ((dir (string-append repository "/packages/" package))
129 (versions (scandir dir (lambda (name) (not (string-prefix? "." name))))))
133 (string-join (cdr (string-split dir #\.)) "."))
135 ;; Workaround for janestreet re-versionning
136 (let ((v-versions (filter (lambda (version) (string-prefix? "v" version)) versions)))
137 (if (null? v-versions)
138 (latest-version versions)
139 (string-append "v" (latest-version (map (lambda (version) (substring version 1)) v-versions))))))
141 (format #t (G_ "Package not found in opam repository: ~a~%") package)
144 (define (get-metadata opam-file)
145 (with-input-from-file opam-file
147 (peg:tree (match-pattern records (get-string-all (current-input-port)))))))
149 (define (substitute-char str what with)
150 (string-join (string-split str what) with))
152 (define (ocaml-name->guix-name name)
155 ((equal? name "ocamlfind") "ocaml-findlib")
156 ((string-prefix? "ocaml" name) name)
157 ((string-prefix? "conf-" name) (substring name 5))
158 (else (string-append "ocaml-" name)))
161 (define (metadata-ref file lookup)
162 (fold (lambda (record acc)
165 (if (equal? key lookup)
167 (('list-pat . stuff) stuff)
168 (('string-pat stuff) stuff)
169 (('multiline-string stuff) stuff)
170 (('dict records ...) records))
174 (define (native? condition)
176 (('condition-var var)
182 ((or ('condition-or cond-left cond-right) ('condition-and cond-left cond-right))
183 (or (native? cond-left)
184 (native? cond-right)))
187 (define (dependency->input dependency)
189 (('string-pat str) str)
190 ;; Arbitrary select the first dependency
191 (('choice-pat choice ...) (dependency->input (car choice)))
192 (('conditional-value val condition)
193 (if (native? condition) "" (dependency->input val)))))
195 (define (dependency->native-input dependency)
197 (('string-pat str) "")
198 ;; Arbitrary select the first dependency
199 (('choice-pat choice ...) (dependency->input (car choice)))
200 (('conditional-value val condition)
201 (if (native? condition) (dependency->input val) ""))))
203 (define (dependency->name dependency)
205 (('string-pat str) str)
206 ;; Arbitrary select the first dependency
207 (('choice-pat choice ...) (dependency->input (car choice)))
208 (('conditional-value val condition)
209 (dependency->name val))))
211 (define (dependency-list->names lst)
215 (string-prefix? "conf-" name)
216 (equal? name "ocaml")
217 (equal? name "findlib"))))
218 (map dependency->name lst)))
220 (define (ocaml-names->guix-names names)
221 (map ocaml-name->guix-name
222 (remove (lambda (name)
223 (or (equal? "" name))
224 (equal? "ocaml" name))
227 (define (depends->inputs depends)
228 (filter (lambda (name)
229 (and (not (equal? "" name))
230 (not (equal? "ocaml" name))
231 (not (equal? "ocamlfind" name))))
232 (map dependency->input depends)))
234 (define (depends->native-inputs depends)
235 (filter (lambda (name) (not (equal? "" name)))
236 (map dependency->native-input depends)))
238 (define (dependency-list->inputs lst)
241 (list dependency (list 'unquote (string->symbol dependency))))
242 (ocaml-names->guix-names lst)))
244 (define* (opam-fetch name #:optional (repository (get-opam-repository)))
245 (and-let* ((repository repository)
246 (version (find-latest-version name repository))
247 (file (string-append repository "/packages/" name "/" name "." version "/opam")))
248 `(("metadata" ,@(get-metadata file))
249 ("version" . ,(if (string-prefix? "v" version)
250 (substring version 1)
253 (define* (opam->guix-package name #:key (repository (get-opam-repository)))
254 "Import OPAM package NAME from REPOSITORY (a directory name) or, if
255 REPOSITORY is #f, from the official OPAM repository. Return a 'package' sexp
257 (and-let* ((opam-file (opam-fetch name repository))
258 (version (assoc-ref opam-file "version"))
259 (opam-content (assoc-ref opam-file "metadata"))
260 (url-dict (metadata-ref opam-content "url"))
261 (source-url (metadata-ref url-dict "src"))
262 (requirements (metadata-ref opam-content "depends"))
263 (dependencies (dependency-list->names requirements))
264 (native-dependencies (depends->native-inputs requirements))
265 (inputs (dependency-list->inputs (depends->inputs requirements)))
266 (native-inputs (dependency-list->inputs
267 ;; Do not add dune nor jbuilder since they are
268 ;; implicit inputs of the dune-build-system.
271 (not (member name '("dune" "jbuilder"))))
272 native-dependencies))))
273 ;; If one of these are required at build time, it means we
274 ;; can use the much nicer dune-build-system.
275 (let ((use-dune? (or (member "dune" (append dependencies native-dependencies))
276 (member "jbuilder" (append dependencies native-dependencies)))))
277 (call-with-temporary-output-file
279 (and (url-fetch source-url temp)
282 (name ,(ocaml-name->guix-name name))
283 (version ,(if (string-prefix? "v" version)
284 (substring version 1)
290 (sha256 (base32 ,(guix-hash-url temp)))))
291 (build-system ,(if use-dune?
293 'ocaml-build-system))
296 `((propagated-inputs ,(list 'quasiquote inputs))))
297 ,@(if (null? native-inputs)
299 `((native-inputs ,(list 'quasiquote native-inputs))))
300 ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name)))
303 ,(list 'quasiquote `((upstream-name . ,name))))))
304 (home-page ,(metadata-ref opam-content "homepage"))
305 (synopsis ,(metadata-ref opam-content "synopsis"))
306 (description ,(metadata-ref opam-content "description"))
310 (not (member name '("dune" "jbuilder"))))
313 (define (opam-recursive-import package-name)
314 (recursive-import package-name #f
315 #:repo->guix-package (lambda (name repo)
316 (opam->guix-package name))
317 #:guix-name ocaml-name->guix-name))
319 (define (guix-name->opam-name name)
320 (if (string-prefix? "ocaml-" name)
324 (define (guix-package->opam-name package)
325 "Given an OCaml PACKAGE built from OPAM, return the name of the
327 (let ((upstream-name (assoc-ref
328 (package-properties package)
330 (name (package-name package)))
333 (guix-name->opam-name name))))
335 (define (opam-package? package)
336 "Return true if PACKAGE is an OCaml package from OPAM"
338 (member (build-system-name (package-build-system package)) '(dune ocaml))
339 (not (string-prefix? "ocaml4" (package-name package)))))
341 (define (latest-release package)
342 "Return an <upstream-source> for the latest release of PACKAGE."
343 (and-let* ((opam-name (guix-package->opam-name package))
344 (opam-file (opam-fetch opam-name))
345 (version (assoc-ref opam-file "version"))
346 (opam-content (assoc-ref opam-file "metadata"))
347 (url-dict (metadata-ref opam-content "url"))
348 (source-url (metadata-ref url-dict "src")))
350 (package (package-name package))
352 (urls (list source-url)))))
354 (define %opam-updater
357 (description "Updater for OPAM packages")
359 (latest latest-release)))