summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorFederico Beffa <beffa@fbengineering.ch>2015-04-26 11:22:29 +0200
committerFederico Beffa <beffa@fbengineering.ch>2015-06-09 09:48:38 +0200
commita4154748730b28fd98ff30d968c755c37802a49a (patch)
treea2d2375001ab676cf98172aabb139d05762ba45c
parent0705f79c6f45108961b901e50f828a978fa0e4e8 (diff)
import: hackage: Refactor parsing code and add new options.
* guix/import/cabal.scm: New file. * guix/import/hackage.scm: Update to use the new Cabal parsing module. * tests/hackage.scm: Update tests. * guix/scripts/import/hackage.scm: Add new '--cabal-environment' and '--stdin' options. * doc/guix.texi: ... and document them. * Makefile.am (MODULES): Add 'guix/import/cabal.scm', 'guix/import/hackage.scm' and 'guix/scripts/import/hackage.scm'. (SCM_TESTS): Add 'tests/hackage.scm'.
-rw-r--r--Makefile.am4
-rw-r--r--doc/guix.texi22
-rw-r--r--guix/import/cabal.scm815
-rw-r--r--guix/import/hackage.scm703
-rw-r--r--guix/scripts/import/hackage.scm66
-rw-r--r--tests/hackage.scm88
6 files changed, 1017 insertions, 681 deletions
diff --git a/Makefile.am b/Makefile.am
index 6478aeb8e03..2b84467b0cc 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -93,6 +93,8 @@ MODULES = \
93 guix/import/utils.scm \ 93 guix/import/utils.scm \
94 guix/import/gnu.scm \ 94 guix/import/gnu.scm \
95 guix/import/snix.scm \ 95 guix/import/snix.scm \
96 guix/import/cabal.scm \
97 guix/import/hackage.scm \
96 guix/scripts/download.scm \ 98 guix/scripts/download.scm \
97 guix/scripts/build.scm \ 99 guix/scripts/build.scm \
98 guix/scripts/archive.scm \ 100 guix/scripts/archive.scm \
@@ -108,6 +110,7 @@ MODULES = \
108 guix/scripts/lint.scm \ 110 guix/scripts/lint.scm \
109 guix/scripts/import/gnu.scm \ 111 guix/scripts/import/gnu.scm \
110 guix/scripts/import/nix.scm \ 112 guix/scripts/import/nix.scm \
113 guix/scripts/import/hackage.scm \
111 guix/scripts/environment.scm \ 114 guix/scripts/environment.scm \
112 guix/scripts/publish.scm \ 115 guix/scripts/publish.scm \
113 guix.scm \ 116 guix.scm \
@@ -178,6 +181,7 @@ SCM_TESTS = \
178 tests/build-utils.scm \ 181 tests/build-utils.scm \
179 tests/packages.scm \ 182 tests/packages.scm \
180 tests/snix.scm \ 183 tests/snix.scm \
184 tests/hackage.scm \
181 tests/store.scm \ 185 tests/store.scm \
182 tests/monads.scm \ 186 tests/monads.scm \
183 tests/gexp.scm \ 187 tests/gexp.scm \
diff --git a/doc/guix.texi b/doc/guix.texi
index c62e44e341d..be7a292f084 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3754,16 +3754,30 @@ dependencies.
3754Specific command-line options are: 3754Specific command-line options are:
3755 3755
3756@table @code 3756@table @code
3757@item --stdin
3758@itemx -s
3759Read a Cabal file from the standard input.
3757@item --no-test-dependencies 3760@item --no-test-dependencies
3758@itemx -t 3761@itemx -t
3759Do not include dependencies only required to run the test suite. 3762Do not include dependencies required by the test suites only.
3763@item --cabal-environment=@var{alist}
3764@itemx -e @var{alist}
3765@var{alist} is a Scheme alist defining the environment in which the
3766Cabal conditionals are evaluated. The accepted keys are: @code{os},
3767@code{arch}, @code{impl} and a string representing the name of a flag.
3768The value associated with a flag has to be either the symbol
3769@code{true} or @code{false}. The value associated with other keys
3770has to conform to the Cabal file format definition. The default value
3771associated with the keys @code{os}, @code{arch} and @code{impl} is
3772@samp{linux}, @samp{x86_64} and @samp{ghc} respectively.
3760@end table 3773@end table
3761 3774
3762The command below imports meta-data for the latest version of the 3775The command below imports meta-data for the latest version of the
3763@code{HTTP} Haskell package without including test dependencies: 3776@code{HTTP} Haskell package without including test dependencies and
3777specifying the value of the flag @samp{network-uri} as @code{false}:
3764 3778
3765@example 3779@example
3766guix import hackage -t HTTP 3780guix import hackage -t -e "'((\"network-uri\" . false))" HTTP
3767@end example 3781@end example
3768 3782
3769A specific package version may optionally be specified by following the 3783A specific package version may optionally be specified by following the
@@ -3772,8 +3786,6 @@ package name by a hyphen and a version number as in the following example:
3772@example 3786@example
3773guix import hackage mtl-2.1.3.1 3787guix import hackage mtl-2.1.3.1
3774@end example 3788@end example
3775
3776Currently only indentation structured Cabal files are supported.
3777@end table 3789@end table
3778 3790
3779The structure of the @command{guix import} code is modular. It would be 3791The structure of the @command{guix import} code is modular. It would be
diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
new file mode 100644
index 00000000000..dfeba88312e
--- /dev/null
+++ b/guix/import/cabal.scm
@@ -0,0 +1,815 @@
1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
3;;;
4;;; This file is part of GNU Guix.
5;;;
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.
10;;;
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.
15;;;
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/>.
18
19(define-module (guix import cabal)
20 #:use-module (ice-9 match)
21 #:use-module (ice-9 regex)
22 #:use-module (ice-9 rdelim)
23 #:use-module (ice-9 receive)
24 #:use-module (srfi srfi-26)
25 #:use-module (srfi srfi-34)
26 #:use-module (srfi srfi-35)
27 #:use-module (srfi srfi-11)
28 #:use-module (srfi srfi-1)
29 #:use-module (srfi srfi-9)
30 #:use-module (srfi srfi-9 gnu)
31 #:use-module (system base lalr)
32 #:use-module (rnrs enums)
33 #:export (read-cabal
34 eval-cabal
35
36 cabal-package?
37 cabal-package-name
38 cabal-package-version
39 cabal-package-license
40 cabal-package-home-page
41 cabal-package-source-repository
42 cabal-package-synopsis
43 cabal-package-description
44 cabal-package-executables
45 cabal-package-library
46 cabal-package-test-suites
47 cabal-package-flags
48 cabal-package-eval-environment
49
50 cabal-source-repository?
51 cabal-source-repository-use-case
52 cabal-source-repository-type
53 cabal-source-repository-location
54
55 cabal-flag?
56 cabal-flag-name
57 cabal-flag-description
58 cabal-flag-default
59 cabal-flag-manual
60
61 cabal-dependency?
62 cabal-dependency-name
63 cabal-dependency-version
64
65 cabal-executable?
66 cabal-executable-name
67 cabal-executable-dependencies
68
69 cabal-library?
70 cabal-library-dependencies
71
72 cabal-test-suite?
73 cabal-test-suite-name
74 cabal-test-suite-dependencies))
75
76;; Part 1:
77;;
78;; Functions used to read a Cabal file.
79
80;; Comment:
81;;
82;; The use of virtual closing braces VCCURLY and some lexer functions were
83;; inspired from http://hackage.haskell.org/package/haskell-src
84
85;; Object containing information about the structure of a block: (i) delimited
86;; by braces or by indentation, (ii) minimum indentation.
87(define-record-type <parse-context>
88 (make-parse-context mode indentation)
89 parse-context?
90 (mode parse-context-mode) ; 'layout or 'no-layout
91 (indentation parse-context-indentation)) ; #f for 'no-layout
92
93;; <parse-context> mode set universe
94(define-enumeration context (layout no-layout) make-context)
95
96(define (make-stack)
97 "Creates a simple stack closure. Actions on the generated stack are
98requested by calling it with one of the following symbols as the first
99argument: 'empty?, 'push!, 'top, 'pop! and 'clear!. The action 'push! is the
100only one requiring a second argument corresponding to the object to be added
101to the stack."
102 (let ((stack '()))
103 (lambda (msg . args)
104 (cond ((eqv? msg 'empty?) (null? stack))
105 ((eqv? msg 'push!) (set! stack (cons (first args) stack)))
106 ((eqv? msg 'top) (if (null? stack) '() (first stack)))
107 ((eqv? msg 'pop!) (match stack
108 ((e r ...) (set! stack (cdr stack)) e)
109 (_ #f)))
110 ((eqv? msg 'clear!) (set! stack '()))
111 (else #f)))))
112
113;; Stack to track the structure of nested blocks and simple interface
114(define context-stack (make-parameter (make-stack)))
115
116(define (context-stack-empty?) ((context-stack) 'empty?))
117
118(define (context-stack-push! e) ((context-stack) 'push! e))
119
120(define (context-stack-top) ((context-stack) 'top))
121
122(define (context-stack-pop!) ((context-stack) 'pop!))
123
124(define (context-stack-clear!) ((context-stack) 'clear!))
125
126;; Indentation of the line being parsed.
127(define current-indentation (make-parameter 0))
128
129;; Signal to reprocess the beginning of line, in case we need to close more
130;; than one indentation level.
131(define check-bol? (make-parameter #f))
132
133;; Name of the file being parsed. Used in error messages.
134(define cabal-file-name (make-parameter "unknowk"))
135
136;; Specify the grammar of a Cabal file and generate a suitable syntax analyser.
137(define (make-cabal-parser)
138 "Generate a parser for Cabal files."
139 (lalr-parser
140 ;; --- token definitions
141 (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION
142 (right: IF FLAG EXEC TEST-SUITE SOURCE-REPO BENCHMARK LIB OCURLY)
143 (left: OR)
144 (left: PROPERTY AND)
145 (right: ELSE NOT))
146 ;; --- rules
147 (body (properties sections) : (append $1 $2))
148 (sections (sections flags) : (append $1 $2)
149 (sections source-repo) : (append $1 (list $2))
150 (sections executables) : (append $1 $2)
151 (sections test-suites) : (append $1 $2)
152 (sections benchmarks) : (append $1 $2)
153 (sections lib-sec) : (append $1 (list $2))
154 () : '())
155 (flags (flags flag-sec) : (append $1 (list $2))
156 (flag-sec) : (list $1))
157 (flag-sec (FLAG OCURLY properties CCURLY) : `(section flag ,$1 ,$3)
158 (FLAG open properties close) : `(section flag ,$1 ,$3)
159 (FLAG) : `(section flag ,$1 '()))
160 (source-repo (SOURCE-REPO OCURLY properties CCURLY)
161 : `(section source-repository ,$1 ,$3)
162 (SOURCE-REPO open properties close)
163 : `(section source-repository ,$1 ,$3))
164 (properties (properties PROPERTY) : (append $1 (list $2))
165 (PROPERTY) : (list $1))
166 (executables (executables exec-sec) : (append $1 (list $2))
167 (exec-sec) : (list $1))
168 (exec-sec (EXEC OCURLY exprs CCURLY) : `(section executable ,$1 ,$3)
169 (EXEC open exprs close) : `(section executable ,$1 ,$3))
170 (test-suites (test-suites ts-sec) : (append $1 (list $2))
171 (ts-sec) : (list $1))
172 (ts-sec (TEST-SUITE OCURLY exprs CCURLY) : `(section test-suite ,$1 ,$3)
173 (TEST-SUITE open exprs close) : `(section test-suite ,$1 ,$3))
174 (benchmarks (benchmarks bm-sec) : (append $1 (list $2))
175 (bm-sec) : (list $1))
176 (bm-sec (BENCHMARK OCURLY exprs CCURLY) : `(section benchmark ,$1 ,$3)
177 (BENCHMARK open exprs close) : `(section benchmark ,$1 ,$3))
178 (lib-sec (LIB OCURLY exprs CCURLY) : `(section library ,$3)
179 (LIB open exprs close) : `(section library ,$3))
180 (exprs (exprs PROPERTY) : (append $1 (list $2))
181 (PROPERTY) : (list $1)
182 (exprs if-then-else) : (append $1 (list $2))
183 (if-then-else) : (list $1)
184 (exprs if-then) : (append $1 (list $2))
185 (if-then) : (list $1))
186 (if-then-else (IF tests OCURLY exprs CCURLY ELSE OCURLY exprs CCURLY)
187 : `(if ,$2 ,$4 ,$8)
188 (IF tests open exprs close ELSE OCURLY exprs CCURLY)
189 : `(if ,$2 ,$4 ,$8)
190 ;; The 'open' token after 'tests' is shifted after an 'exprs'
191 ;; is found. This is because, instead of 'exprs' a 'OCURLY'
192 ;; token is a valid alternative. For this reason, 'open'
193 ;; pushes a <parse-context> with a line indentation equal to
194 ;; the indentation of 'exprs'.
195 ;;
196 ;; Differently from this, without the rule above this
197 ;; comment, when an 'ELSE' token is found, the 'open' token
198 ;; following the 'ELSE' would be shifted immediately, before
199 ;; the 'exprs' is found (because there are no other valid
200 ;; tokens). The 'open' would therefore create a
201 ;; <parse-context> with the indentation of 'ELSE' and not
202 ;; 'exprs', creating an inconsistency. We therefore allow
203 ;; mixed style conditionals.
204 (IF tests open exprs close ELSE open exprs close)
205 : `(if ,$2 ,$4 ,$8))
206 (if-then (IF tests OCURLY exprs CCURLY) : `(if ,$2 ,$4 ())
207 (IF tests open exprs close) : `(if ,$2 ,$4 ()))
208 (tests (TEST OPAREN ID CPAREN) : `(,$1 ,$3)
209 (TEST OPAREN ID RELATION VERSION CPAREN)
210 : `(,$1 ,(string-append $3 " " $4 " " $5))
211 (TEST OPAREN ID RELATION VERSION AND RELATION VERSION CPAREN)
212 : `(and (,$1 ,(string-append $3 " " $4 " " $5))
213 (,$1 ,(string-append $3 " " $7 " " $8)))
214 (NOT tests) : `(not ,$2)
215 (tests AND tests) : `(and ,$1 ,$3)
216 (tests OR tests) : `(or ,$1 ,$3)
217 (OPAREN tests CPAREN) : $2)
218 (open () : (context-stack-push!
219 (make-parse-context (context layout)
220 (current-indentation))))
221 (close (VCCURLY))))
222
223(define (peek-next-line-indent port)
224 "This function can be called when the next character on PORT is #\newline
225and returns the indentation of the line starting after the #\newline
226character. Discard (and consume) empty and comment lines."
227 (let ((initial-newline (string (read-char port))))
228 (let loop ((char (peek-char port))
229 (word ""))
230 (cond ((eqv? char #\newline) (read-char port)
231 (loop (peek-char port) ""))
232 ((or (eqv? char #\space) (eqv? char #\tab))
233 (let ((c (read-char port)))
234 (loop (peek-char port) (string-append word (string c)))))
235 ((comment-line port char) (loop (peek-char port) ""))
236 (else
237 (let ((len (string-length word)))
238 (unread-string (string-append initial-newline word) port)
239 len))))))
240
241(define* (read-value port value min-indent #:optional (separator " "))
242 "The next character on PORT must be #\newline. Append to VALUE the
243following lines with indentation larger than MIN-INDENT."
244 (let loop ((val (string-trim-both value))
245 (x (peek-next-line-indent port)))
246 (if (> x min-indent)
247 (begin
248 (read-char port) ; consume #\newline
249 (loop (string-append
250 val (if (string-null? val) "" separator)
251 (string-trim-both (read-delimited "\n" port 'peek)))
252 (peek-next-line-indent port)))
253 val)))
254
255(define (lex-white-space port bol)
256 "Consume white spaces and comment lines on PORT. If a new line is started return #t,
257otherwise return BOL (beginning-of-line)."
258 (let loop ((c (peek-char port))
259 (bol bol))
260 (cond
261 ((and (not (eof-object? c))
262 (or (char=? c #\space) (char=? c #\tab)))
263 (read-char port)
264 (loop (peek-char port) bol))
265 ((and (not (eof-object? c)) (char=? c #\newline))
266 (read-char port)
267 (loop (peek-char port) #t))
268 ((comment-line port c)
269 (lex-white-space port bol))
270 (else
271 bol))))
272
273(define (lex-bol port)
274 "Process the beginning of a line on PORT: update current-indentation and
275check the end of an indentation based context."
276 (let ((loc (make-source-location (cabal-file-name) (port-line port)
277 (port-column port) -1 -1)))
278 (current-indentation (source-location-column loc))
279 (case (get-offside port)
280 ((less-than)
281 (check-bol? #t) ; need to check if closing more than 1 indent level.
282 (unless (context-stack-empty?) (context-stack-pop!))
283 (make-lexical-token 'VCCURLY loc #f))
284 (else
285 (lex-token port)))))
286
287(define (bol? port) (or (check-bol?) (= (port-column port) 0)))
288
289(define (comment-line port c)
290 "If PORT starts with a comment line, consume it up to, but not including
291#\newline. C is the next character on PORT."
292 (cond ((and (not (eof-object? c)) (char=? c #\-))
293 (read-char port)
294 (let ((c2 (peek-char port)))
295 (if (char=? c2 #\-)
296 (read-delimited "\n" port 'peek)
297 (begin (unread-char c port) #f))))
298 (else #f)))
299
300(define-enumeration ordering (less-than equal greater-than) make-ordering)
301
302(define (get-offside port)
303 "In an indentation based context return the symbol 'greater-than, 'equal or
304'less-than to signal if the current column number on PORT is greater-, equal-,
305or less-than the indentation of the current context."
306 (let ((x (port-column port)))
307 (match (context-stack-top)
308 (($ <parse-context> 'layout indentation)
309 (cond
310 ((> x indentation) (ordering greater-than))
311 ((= x indentation) (ordering equal))
312 (else (ordering less-than))))
313 (_ (ordering greater-than)))))
314
315;; (Semi-)Predicates for individual tokens.
316
317(define (is-relation? c)
318 (and (char? c) (any (cut char=? c <>) '(#\< #\> #\=))))
319
320(define (make-rx-matcher pat)
321 "Compile PAT into a regular expression and creates a function matching a
322string against the created regexp."
323 (let ((rx (make-regexp pat))) (cut regexp-exec rx <>)))
324
325(define is-property (make-rx-matcher "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$"))
326
327(define is-flag (make-rx-matcher "^[Ff]lag +([a-zA-Z0-9_-]+)"))
328
329(define is-src-repo
330 (make-rx-matcher "^[Ss]ource-[Rr]epository +([a-zA-Z0-9_-]+)"))
331
332(define is-exec (make-rx-matcher "^[Ee]xecutable +([a-zA-Z0-9_-]+)"))
333
334(define is-test-suite (make-rx-matcher "^[Tt]est-[Ss]uite +([a-zA-Z0-9_-]+)"))
335
336(define is-benchmark (make-rx-matcher "^[Bb]enchmark +([a-zA-Z0-9_-]+)"))
337
338(define is-lib (make-rx-matcher "^[Ll]ibrary *"))
339
340(define is-else (make-rx-matcher "^else"))
341
342(define (is-if s) (string=? s "if"))
343
344(define (is-and s) (string=? s "&&"))
345
346(define (is-or s) (string=? s "||"))
347
348(define (is-id s)
349 (let ((cabal-reserved-words
350 '("if" "else" "library" "flag" "executable" "test-suite"
351 "source-repository" "benchmark")))
352 (and (every (cut string-ci<> s <>) cabal-reserved-words)
353 (not (char=? (last (string->list s)) #\:)))))
354
355(define (is-test s port)
356 (let ((tests-rx (make-regexp "os|arch|flag|impl"))
357 (c (peek-char port)))
358 (and (regexp-exec tests-rx s) (char=? #\( c))))
359
360;; Lexers for individual tokens.
361
362(define (lex-relation loc port)
363 (make-lexical-token 'RELATION loc (read-while is-relation? port)))
364
365(define (lex-version loc port)
366 (make-lexical-token 'VERSION loc
367 (read-while char-numeric? port
368 (cut char=? #\. <>) char-numeric?)))
369
370(define* (read-while is? port #:optional
371 (is-if-followed-by? (lambda (c) #f))
372 (is-allowed-follower? (lambda (c) #f)))
373 "Read from PORT as long as: (i) either the read character satisfies the
374predicate IS?, or (ii) it satisfies the predicate IS-IF-FOLLOWED-BY? and the
375character immediately following it satisfies IS-ALLOWED-FOLLOWER?. Returns a
376string with the read characters."
377 (let loop ((c (peek-char port))
378 (res '()))
379 (cond ((and (not (eof-object? c)) (is? c))
380 (let ((c (read-char port)))
381 (loop (peek-char port) (append res (list c)))))
382 ((and (not (eof-object? c)) (is-if-followed-by? c))
383 (let ((c (read-char port))
384 (c2 (peek-char port)))
385 (if (and (not (eof-object? c2)) (is-allowed-follower? c2))
386 (loop c2 (append res (list c)))
387 (begin (unread-char c) (list->string res)))))
388 (else (list->string res)))))
389
390(define (lex-property k-v-rx-res loc port)
391 (let ((key (string-downcase (match:substring k-v-rx-res 1)))
392 (value (match:substring k-v-rx-res 2)))
393 (make-lexical-token
394 'PROPERTY loc
395 (list key `(,(read-value port value (current-indentation)))))))
396
397(define (lex-rx-res rx-res token loc)
398 (let ((name (string-downcase (match:substring rx-res 1))))
399 (make-lexical-token token loc name)))
400
401(define (lex-flag flag-rx-res loc) (lex-rx-res flag-rx-res 'FLAG loc))
402
403(define (lex-src-repo src-repo-rx-res loc)
404 (lex-rx-res src-repo-rx-res 'SOURCE-REPO loc))
405
406(define (lex-exec exec-rx-res loc) (lex-rx-res exec-rx-res 'EXEC loc))
407
408(define (lex-test-suite ts-rx-res loc) (lex-rx-res ts-rx-res 'TEST-SUITE loc))
409
410(define (lex-benchmark bm-rx-res loc) (lex-rx-res bm-rx-res 'BENCHMARK loc))
411
412(define (lex-lib loc) (make-lexical-token 'LIB loc #f))
413
414(define (lex-else loc) (make-lexical-token 'ELSE loc #f))
415
416(define (lex-if loc) (make-lexical-token 'IF loc #f))
417
418(define (lex-and loc) (make-lexical-token 'AND loc #f))
419
420(define (lex-or loc) (make-lexical-token 'OR loc #f))
421
422(define (lex-id w loc) (make-lexical-token 'ID loc w))
423
424(define (lex-test w loc) (make-lexical-token 'TEST loc (string->symbol w)))
425
426;; Lexer for tokens recognizable by single char.
427
428(define* (is-ref-char->token ref-char next-char token loc port
429 #:optional (hook-fn #f))
430 "If the next character NEXT-CHAR on PORT is REF-CHAR, then read it,
431execute HOOK-FN if it isn't #f and return a lexical token of type TOKEN with
432location information LOC."
433 (cond ((char=? next-char ref-char)
434 (read-char port)
435 (when hook-fn (hook-fn))
436 (make-lexical-token token loc (string next-char)))
437 (else #f)))
438
439(define (is-ocurly->token c loc port)
440 (is-ref-char->token #\{ c 'OCURLY loc port
441 (lambda ()
442 (context-stack-push! (make-parse-context
443 (context no-layout) #f)))))
444
445(define (is-ccurly->token c loc port)
446 (is-ref-char->token #\} c 'CCURLY loc port (lambda () (context-stack-pop!))))
447
448(define (is-oparen->token c loc port)
449 (is-ref-char->token #\( c 'OPAREN loc port))
450
451(define (is-cparen->token c loc port)
452 (is-ref-char->token #\) c 'CPAREN loc port))
453
454(define (is-not->token c loc port)
455 (is-ref-char->token #\! c 'NOT loc port))
456
457(define (is-version? c) (char-numeric? c))
458
459;; Main lexer functions
460
461(define (lex-single-char port loc)
462 "Process tokens which can be recognised by peeking the next character on
463PORT. If no token can be recognized return #f. LOC is the current port
464location."
465 (let* ((c (peek-char port)))
466 (cond ((eof-object? c) (read-char port) '*eoi*)
467 ((is-ocurly->token c loc port))
468 ((is-ccurly->token c loc port))
469 ((is-oparen->token c loc port))
470 ((is-cparen->token c loc port))
471 ((is-not->token c loc port))
472 ((is-version? c) (lex-version loc port))
473 ((is-relation? c) (lex-relation loc port))
474 (else
475 #f))))
476
477(define (lex-word port loc)
478 "Process tokens which can be recognized by reading the next word form PORT.
479LOC is the current port location."
480 (let* ((w (read-delimited " ()\t\n" port 'peek)))
481 (cond ((is-if w) (lex-if loc))
482 ((is-test w port) (lex-test w loc))
483 ((is-and w) (lex-and loc))
484 ((is-or w) (lex-or loc))
485 ((is-id w) (lex-id w loc))
486 (else (unread-string w port) #f))))
487
488(define (lex-line port loc)
489 "Process tokens which can be recognised by reading a line from PORT. LOC is
490the current port location."
491 (let* ((s (read-delimited "\n{}" port 'peek)))
492 (cond
493 ((is-property s) => (cut lex-property <> loc port))
494 ((is-flag s) => (cut lex-flag <> loc))
495 ((is-src-repo s) => (cut lex-src-repo <> loc))
496 ((is-exec s) => (cut lex-exec <> loc))
497 ((is-test-suite s) => (cut lex-test-suite <> loc))
498 ((is-benchmark s) => (cut lex-benchmark <> loc))
499 ((is-lib s) (lex-lib loc))
500 ((is-else s) (lex-else loc))
501 (else
502 #f))))
503
504(define (lex-token port)
505 (let* ((loc (make-source-location (cabal-file-name) (port-line port)
506 (port-column port) -1 -1)))
507 (or (lex-single-char port loc) (lex-word port loc) (lex-line port loc))))
508
509;; Lexer- and error-function generators
510
511(define (errorp)
512 "Generates the lexer error function."
513 (let ((p (current-error-port)))
514 (lambda (message . args)
515 (format p "~a" message)
516 (if (and (pair? args) (lexical-token? (car args)))
517 (let* ((token (car args))
518 (source (lexical-token-source token))
519 (line (source-location-line source))
520 (column (source-location-column source)))
521 (format p "~a " (or (lexical-token-value token)
522 (lexical-token-category token)))
523 (when (and (number? line) (number? column))
524 (format p "(at line ~a, column ~a)" (1+ line) column)))
525 (for-each display args))
526 (format p "~%"))))
527
528(define (make-lexer port)
529 "Generate the Cabal lexical analyser reading from PORT."
530 (let ((p port))
531 (lambda ()
532 (let ((bol (lex-white-space p (bol? p))))
533 (check-bol? #f)
534 (if bol (lex-bol p) (lex-token p))))))
535
536(define* (read-cabal #:optional (port (current-input-port))
537 (file-name #f))
538 "Read a Cabal file from PORT. FILE-NAME is a string used in error messages.
539If #f use the function 'port-filename' to obtain it."
540 (let ((cabal-parser (make-cabal-parser)))
541 (parameterize ((cabal-file-name
542 (or file-name (port-filename port) "standard input"))
543 (current-indentation 0)
544 (check-bol? #f)
545 (context-stack (make-stack)))
546 (cabal-parser (make-lexer port) (errorp)))))
547
548;; Part 2:
549;;
550;; Evaluate the S-expression returned by 'read-cabal'.
551
552;; This defines the object and interface that we provide to access the Cabal
553;; file information. Note that this does not include all the pieces of
554;; information of the Cabal file, but only the ones we currently are
555;; interested in.
556(define-record-type <cabal-package>
557 (make-cabal-package name version license home-page source-repository
558 synopsis description
559 executables lib test-suites
560 flags eval-environment)
561 cabal-package?
562 (name cabal-package-name)
563 (version cabal-package-version)
564 (license cabal-package-license)
565 (home-page cabal-package-home-page)
566 (source-repository cabal-package-source-repository)
567 (synopsis cabal-package-synopsis)
568 (description cabal-package-description)
569 (executables cabal-package-executables)
570 (lib cabal-package-library) ; 'library' is a Scheme keyword
571 (test-suites cabal-package-test-suites)
572 (flags cabal-package-flags)
573 (eval-environment cabal-package-eval-environment)) ; alist
574
575(set-record-type-printer! <cabal-package>
576 (lambda (package port)
577 (format port "#<cabal-package ~a-~a>"
578 (cabal-package-name package)
579 (cabal-package-version package))))
580
581(define-record-type <cabal-source-repository>
582 (make-cabal-source-repository use-case type location)
583 cabal-source-repository?
584 (use-case cabal-source-repository-use-case)
585 (type cabal-source-repository-type)
586 (location cabal-source-repository-location))
587
588;; We need to be able to distinguish the value of a flag from the Scheme #t
589;; and #f values.
590(define-record-type <cabal-flag>
591 (make-cabal-flag name description default manual)
592 cabal-flag?
593 (name cabal-flag-name)
594 (description cabal-flag-description)
595 (default cabal-flag-default) ; 'true or 'false
596 (manual cabal-flag-manual)) ; 'true or 'false
597
598(set-record-type-printer! <cabal-flag>
599 (lambda (package port)
600 (format port "#<cabal-flag ~a default:~a>"
601 (cabal-flag-name package)
602 (cabal-flag-default package))))
603
604(define-record-type <cabal-dependency>
605 (make-cabal-dependency name version)
606 cabal-dependency?
607 (name cabal-dependency-name)
608 (version cabal-dependency-version))
609
610(define-record-type <cabal-executable>
611 (make-cabal-executable name dependencies)
612 cabal-executable?
613 (name cabal-executable-name)
614 (dependencies cabal-executable-dependencies)) ; list of <cabal-dependency>
615
616(define-record-type <cabal-library>
617 (make-cabal-library dependencies)
618 cabal-library?
619 (dependencies cabal-library-dependencies)) ; list of <cabal-dependency>
620
621(define-record-type <cabal-test-suite>
622 (make-cabal-test-suite name dependencies)
623 cabal-test-suite?
624 (name cabal-test-suite-name)
625 (dependencies cabal-test-suite-dependencies)) ; list of <cabal-dependency>
626
627(define (cabal-flags->alist flag-list)
628 "Retrun an alist associating the flag name to its default value from a
629list of <cabal-flag> objects."
630 (map (lambda (flag) (cons (cabal-flag-name flag) (cabal-flag-default flag)))
631 flag-list))
632
633(define (eval-cabal cabal-sexp env)
634 "Given the CABAL-SEXP produced by 'read-cabal', evaluate all conditionals
635and return a 'cabal-package' object. The values of all tests can be
636overwritten by specifying the desired value in ENV. ENV must be an alist.
637The accepted keys are: \"os\", \"arch\", \"impl\" and a name of a flag. The
638value associated with a flag has to be either \"true\" or \"false\". The
639value associated with other keys has to conform to the Cabal file format
640definition."
641 (define (os name)
642 (let ((env-os (or (assoc-ref env "os") "linux")))
643 (string-match env-os name)))
644
645 (define (arch name)
646 (let ((env-arch (or (assoc-ref env "arch") "x86_64")))
647 (string-match env-arch name)))
648
649 (define (comp-name+version haskell)
650 "Extract the compiler name and version from the string HASKELL."
651 (let* ((matcher-fn (make-rx-matcher "([a-zA-Z0-9_]+)-([0-9.]+)"))
652 (name (or (and=> (matcher-fn haskell) (cut match:substring <> 1))
653 haskell))
654 (version (and=> (matcher-fn haskell) (cut match:substring <> 2))))
655 (values name version)))
656
657 (define (comp-spec-name+op+version spec)
658 "Extract the compiler specification from SPEC. Return the compiler name,
659the ordering operation and the version."
660 (let* ((with-ver-matcher-fn (make-rx-matcher
661 "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *"))
662 (without-ver-matcher-fn (make-rx-matcher "([a-zA-Z0-9_-]+)"))
663 (name (or (and=> (with-ver-matcher-fn spec)
664 (cut match:substring <> 1))
665 (match:substring (without-ver-matcher-fn spec) 1)))
666 (operator (and=> (with-ver-matcher-fn spec)
667 (cut match:substring <> 2)))
668 (version (and=> (with-ver-matcher-fn spec)
669 (cut match:substring <> 3))))
670 (values name operator version)))
671
672 (define (impl haskell)
673 (let*-values (((comp-name comp-ver)
674 (comp-name+version (or (assoc-ref env "impl") "ghc")))
675 ((spec-name spec-op spec-ver)
676 (comp-spec-name+op+version haskell)))
677 (if (and spec-ver comp-ver)
678 (eval-string
679 (string-append "(string" spec-op " \"" comp-name "\""
680 " \"" spec-name "-" spec-ver "\")"))
681 (string-match spec-name comp-name))))
682
683 (define (cabal-flags)
684 (make-cabal-section cabal-sexp 'flag))
685
686 (define (flag name)
687 (let ((value (or (assoc-ref env name)
688 (assoc-ref (cabal-flags->alist (cabal-flags)) name))))
689 (if (eq? value 'false) #f #t)))
690
691 (define (eval sexp)
692 (match sexp
693 (() '())
694 ;; nested 'if'
695 ((('if predicate true-group false-group) rest ...)
696 (append (if (eval predicate)
697 (eval true-group)
698 (eval false-group))
699 (eval rest)))
700 (('if predicate true-group false-group)
701 (if (eval predicate)
702 (eval true-group)
703 (eval false-group)))
704 (('flag name) (flag name))
705 (('os name) (os name))
706 (('arch name) (arch name))
707 (('impl name) (impl name))
708 (('not name) (not (eval name)))
709 ;; 'and' and 'or' aren't functions, thus we can't use apply
710 (('and args ...) (fold (lambda (e s) (and e s)) #t (eval args)))
711 (('or args ...) (fold (lambda (e s) (or e s)) #f (eval args)))
712 ;; no need to evaluate flag parameters
713 (('section 'flag name parameters)
714 (list 'section 'flag name parameters))
715 ;; library does not have a name parameter
716 (('section 'library parameters)
717 (list 'section 'library (eval parameters)))
718 (('section type name parameters)
719 (list 'section type name (eval parameters)))
720 (((? string? name) values)
721 (list name values))
722 ((element rest ...)
723 (cons (eval element) (eval rest)))
724 (_ (raise (condition
725 (&message (message "Failed to evaluate Cabal file. \
726See the manual for limitations.")))))))
727
728 (define (cabal-evaluated-sexp->package evaluated-sexp)
729 (let* ((name (lookup-join evaluated-sexp "name"))
730 (version (lookup-join evaluated-sexp "version"))
731 (license (lookup-join evaluated-sexp "license"))
732 (home-page (lookup-join evaluated-sexp "homepage"))
733 (home-page-or-hackage
734 (if (string-null? home-page)
735 (string-append "http://hackage.haskell.org/package/" name)
736 home-page))
737 (source-repository (make-cabal-section evaluated-sexp
738 'source-repository))
739 (synopsis (lookup-join evaluated-sexp "synopsis"))
740 (description (lookup-join evaluated-sexp "description"))
741 (executables (make-cabal-section evaluated-sexp 'executable))
742 (lib (make-cabal-section evaluated-sexp 'library))
743 (test-suites (make-cabal-section evaluated-sexp 'test-suite))
744 (flags (make-cabal-section evaluated-sexp 'flag))
745 (eval-environment '()))
746 (make-cabal-package name version license home-page-or-hackage
747 source-repository synopsis description executables lib
748 test-suites flags eval-environment)))
749
750 ((compose cabal-evaluated-sexp->package eval) cabal-sexp))
751
752(define (make-cabal-section sexp section-type)
753 "Given an SEXP as produced by 'read-cabal', produce a list of objects
754pertaining to SECTION-TYPE sections. SECTION-TYPE must be one of:
755'executable, 'flag, 'test-suite, 'source-repository or 'library."
756 (filter-map (cut match <>
757 (('section (? (cut equal? <> section-type)) name parameters)
758 (case section-type
759 ((test-suite) (make-cabal-test-suite
760 name (dependencies parameters)))
761 ((executable) (make-cabal-executable
762 name (dependencies parameters)))
763 ((source-repository) (make-cabal-source-repository
764 name
765 (lookup-join parameters "type")
766 (lookup-join parameters "location")))
767 ((flag)
768 (let* ((default (lookup-join parameters "default"))
769 (default-true-or-false
770 (if (and default (string-ci=? "false" default))
771 'false
772 'true))
773 (description (lookup-join parameters "description"))
774 (manual (lookup-join parameters "manual"))
775 (manual-true-or-false
776 (if (and manual (string-ci=? "true" manual))
777 'true
778 'false)))
779 (make-cabal-flag name description
780 default-true-or-false
781 manual-true-or-false)))
782 (else #f)))
783 (('section (? (cut equal? <> section-type) lib) parameters)
784 (make-cabal-library (dependencies parameters)))
785 (_ #f))
786 sexp))
787
788(define* (lookup-join key-values-list key #:optional (delimiter " "))
789 "Lookup and joint all values pertaining to keys of value KEY in
790KEY-VALUES-LIST. The optional DELIMITER is used to specify a delimiter string
791to be added between the values found in different key/value pairs."
792 (string-join
793 (filter-map (cut match <>
794 (((? (lambda(x) (equal? x key))) value)
795 (string-join value delimiter))
796 (_ #f))
797 key-values-list)
798 delimiter))
799
800(define dependency-name-version-rx
801 (make-regexp "([a-zA-Z0-9_-]+) *(.*)"))
802
803(define (dependencies key-values-list)
804 "Return a list of 'cabal-dependency' objects for the dependencies found in
805KEY-VALUES-LIST."
806 (let ((deps (string-tokenize (lookup-join key-values-list "build-depends" ",")
807 (char-set-complement (char-set #\,)))))
808 (map (lambda (d)
809 (let ((rx-result (regexp-exec dependency-name-version-rx d)))
810 (make-cabal-dependency
811 (match:substring rx-result 1)
812 (match:substring rx-result 2))))
813 deps)))
814
815;;; cabal.scm ends here
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 1b27803dba0..b5574a8d9fe 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -18,28 +18,19 @@
18 18
19(define-module (guix import hackage) 19(define-module (guix import hackage)
20 #:use-module (ice-9 match) 20 #:use-module (ice-9 match)
21 #:use-module (ice-9 regex)
22 #:use-module (ice-9 rdelim)
23 #:use-module (ice-9 receive)
24 #:use-module (ice-9 pretty-print)
25 #:use-module (srfi srfi-26) 21 #:use-module (srfi srfi-26)
26 #:use-module (srfi srfi-34)
27 #:use-module (srfi srfi-35)
28 #:use-module (srfi srfi-11) 22 #:use-module (srfi srfi-11)
29 #:use-module (srfi srfi-1) 23 #:use-module (srfi srfi-1)
30 #:use-module ((guix download) #:select (download-to-store)) 24 #:use-module ((guix download) #:select (download-to-store))
31 #:use-module ((guix utils) #:select (package-name->name+version)) 25 #:use-module ((guix utils) #:select (package-name->name+version))
32 #:use-module (guix import utils) 26 #:use-module (guix import utils)
27 #:use-module (guix import cabal)
33 #:use-module (guix store) 28 #:use-module (guix store)
34 #:use-module (guix hash) 29 #:use-module (guix hash)
35 #:use-module (guix base32) 30 #:use-module (guix base32)
36 #:use-module ((guix utils) #:select (call-with-temporary-output-file)) 31 #:use-module ((guix utils) #:select (call-with-temporary-output-file))
37 #:export (hackage->guix-package)) 32 #:export (hackage->guix-package))
38 33
39;; Part 1:
40;;
41;; Functions used to read a Cabal file.
42
43(define ghc-standard-libraries 34(define ghc-standard-libraries
44 ;; List of libraries distributed with ghc (7.8.4). We include GHC itself as 35 ;; List of libraries distributed with ghc (7.8.4). We include GHC itself as
45 ;; some packages list it. 36 ;; some packages list it.
@@ -75,588 +66,12 @@
75 66
76(define package-name-prefix "ghc-") 67(define package-name-prefix "ghc-")
77 68
78(define key-value-rx
79 ;; Regular expression matching "key: value"
80 (make-regexp "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$"))
81
82(define sections-rx
83 ;; Regular expression matching a section "head sub-head ..."
84 (make-regexp "([a-zA-Z0-9\\(\\)-]+)"))
85
86(define comment-rx
87 ;; Regexp matching Cabal comment lines.
88 (make-regexp "^ *--"))
89
90(define (has-key? line)
91 "Check if LINE includes a key."
92 (regexp-exec key-value-rx line))
93
94(define (comment-line? line)
95 "Check if LINE is a comment line."
96 (regexp-exec comment-rx line))
97
98(define (line-indentation+rest line)
99 "Returns two results: The number of indentation spaces and the rest of the
100line (without indentation)."
101 (let loop ((line-lst (string->list line))
102 (count 0))
103 ;; Sometimes values are spread over multiple lines and new lines start
104 ;; with a comma ',' with the wrong indentation. See e.g. haddock-api.
105 (if (or (null? line-lst)
106 (not (or
107 (eqv? (first line-lst) #\space)
108 (eqv? (first line-lst) #\,) ; see, e.g., haddock-api.cabal
109 (eqv? (first line-lst) #\tab))))
110 (values count (list->string line-lst))
111 (loop (cdr line-lst) (+ count 1)))))
112
113(define (multi-line-value lines seed)
114 "Function to read a value split across multiple lines. LINES are the
115remaining input lines to be read. SEED is the value read on the same line as
116the key. Return two values: A list with values and the remaining lines to be
117processed."
118 (define (multi-line-value-with-min-indent lines seed min-indent)
119 (if (null? lines)
120 (values '() '())
121 (let-values (((current-indent value) (line-indentation+rest (first lines)))
122 ((next-line-indent next-line-value)
123 (if (null? (cdr lines))
124 (values #f "")
125 (line-indentation+rest (second lines)))))
126 (if (or (not next-line-indent) (< next-line-indent min-indent)
127 (regexp-exec condition-rx next-line-value))
128 (values (reverse (cons value seed)) (cdr lines))
129 (multi-line-value-with-min-indent (cdr lines) (cons value seed)
130 min-indent)))))
131
132 (let-values (((current-indent value) (line-indentation+rest (first lines))))
133 (multi-line-value-with-min-indent lines seed current-indent)))
134
135(define (read-cabal port)
136 "Parses a Cabal file from PORT. Return a list of list pairs:
137
138(((head1 sub-head1 ... key1) (value))
139 ((head2 sub-head2 ... key2) (value2))
140 ...).
141
142We try do deduce the Cabal format from the following document:
143https://www.haskell.org/cabal/users-guide/developing-packages.html
144
145Keys are case-insensitive. We therefore lowercase them. Values are
146case-sensitive. Currently only indentation-structured files are parsed.
147Braces structured files are not handled." ;" <- make emacs happy.
148 (define (read-and-trim-line port)
149 (let ((line (read-line port)))
150 (if (string? line)
151 (string-trim-both line #\return)
152 line)))
153
154 (define (strip-insignificant-lines port)
155 (let loop ((line (read-and-trim-line port))
156 (result '()))
157 (cond
158 ((eof-object? line)
159 (reverse result))
160 ((or (string-null? line) (comment-line? line))
161 (loop (read-and-trim-line port) result))
162 (else
163 (loop (read-and-trim-line port) (cons line result))))))
164
165 (let loop
166 ((lines (strip-insignificant-lines port))
167 (indents '()) ; only includes indents at start of section heads.
168 (sections '())
169 (result '()))
170 (let-values
171 (((current-indent line)
172 (if (null? lines)
173 (values 0 "")
174 (line-indentation+rest (first lines))))
175 ((next-line-indent next-line)
176 (if (or (null? lines) (null? (cdr lines)))
177 (values 0 "")
178 (line-indentation+rest (second lines)))))
179 (if (null? lines)
180 (reverse result)
181 (let ((rx-result (has-key? line)))
182 (cond
183 (rx-result
184 (let ((key (string-downcase (match:substring rx-result 1)))
185 (value (match:substring rx-result 2)))
186 (cond
187 ;; Simple single line "key: value".
188 ((= next-line-indent current-indent)
189 (loop (cdr lines) indents sections
190 (cons
191 (list (reverse (cons key sections)) (list value))
192 result)))
193 ;; Multi line "key: value\n value cont...".
194 ((> next-line-indent current-indent)
195 (let*-values (((value-lst lines)
196 (multi-line-value (cdr lines)
197 (if (string-null? value)
198 '()
199 `(,value)))))
200 ;; multi-line-value returns to the first line after the
201 ;; multi-value.
202 (loop lines indents sections
203 (cons
204 (list (reverse (cons key sections)) value-lst)
205 result))))
206 ;; Section ended.
207 (else
208 ;; Indentation is reduced. Check by how many levels.
209 (let* ((idx (and=> (list-index
210 (lambda (x) (= next-line-indent x))
211 indents)
212 (cut + <>
213 (if (has-key? next-line) 1 0))))
214 (sec
215 (if idx
216 (drop sections idx)
217 (raise
218 (condition
219 (&message
220 (message "unable to parse Cabal file"))))))
221 (ind (drop indents idx)))
222 (loop (cdr lines) ind sec
223 (cons
224 (list (reverse (cons key sections)) (list value))
225 result)))))))
226 ;; Start of a new section.
227 ((or (null? indents)
228 (> current-indent (first indents)))
229 (loop (cdr lines) (cons current-indent indents)
230 (cons (string-downcase line) sections) result))
231 (else
232 (loop (cdr lines) indents
233 (cons (string-downcase line) (cdr sections))
234 result))))))))
235
236(define condition-rx
237 ;; Regexp for conditionals.
238 (make-regexp "^if +(.*)$"))
239
240(define (split-section section)
241 "Split SECTION in individual words with exception for the predicate of an
242'if' conditional."
243 (let ((rx-result (regexp-exec condition-rx section)))
244 (if rx-result
245 `("if" ,(match:substring rx-result 1))
246 (map match:substring (list-matches sections-rx section)))))
247
248(define (join-sections sec1 sec2)
249 (fold-right cons sec2 sec1))
250
251(define (pre-process-keys key)
252 (match key
253 (() '())
254 ((sec1 rest ...)
255 (join-sections (split-section sec1) (pre-process-keys rest)))))
256
257(define (pre-process-entry-keys entry)
258 (match entry
259 ((key value)
260 (list (pre-process-keys key) value))
261 (() '())))
262
263(define (pre-process-entries-keys entries)
264 "ENTRIES is a list of list pairs, a keys list and a valules list, as
265produced by 'read-cabal'. Split each element of the keys list into individual
266words. This pre-processing is used to read flags."
267 (match entries
268 ((entry rest ...)
269 (cons (pre-process-entry-keys entry)
270 (pre-process-entries-keys rest)))
271 (()
272 '())))
273
274(define (get-flags pre-processed-entries)
275 "PRE-PROCESSED-ENTRIES is a list of list pairs, a keys list and a values
276list, as produced by 'read-cabal' and pre-processed by
277'pre-process-entries-keys'. Return a list of pairs with the name of flags and
278their default value (one of \"False\" or \"True\") as specified in the Cabal file:
279
280((\"flag1-name\" . \"False-or-True\") ...)." ;" <- make emacs happy
281 (match pre-processed-entries
282 (() '())
283 (((("flag" flag-name "default") (flag-val)) rest ...)
284 (cons (cons flag-name flag-val)
285 (get-flags rest)))
286 ((entry rest ... )
287 (get-flags rest))
288 (_ #f)))
289
290;; Part 2:
291;;
292;; Functions to read information from the Cabal object created by 'read-cabal'
293;; and convert Cabal format dependencies conditionals into equivalent
294;; S-expressions.
295
296(define tests-rx
297 ;; Cabal test keywords
298 (make-regexp "(os|arch|flag|impl) *\\(([ a-zA-Z0-9_.<>=-]+)\\)"))
299
300(define parens-rx
301 ;; Parentheses within conditions
302 (make-regexp "\\((.+)\\)"))
303
304(define or-rx
305 ;; OR operator in conditions
306 (make-regexp " +\\|\\| +"))
307
308(define and-rx
309 ;; AND operator in conditions
310 (make-regexp " +&& +"))
311
312(define not-rx
313 ;; NOT operator in conditions
314 (make-regexp "^!.+"))
315
316(define (bi-op-args str match-lst)
317 "Return a list with the arguments of (logic) bianry operators. MATCH-LST
318is the result of 'list-match' against a binary operator regexp on STR."
319 (let ((operators (length match-lst)))
320 (map (lambda (from to)
321 (substring str from to))
322 (cons 0 (map match:end match-lst))
323 (append (map match:start match-lst) (list (string-length str))))))
324
325(define (bi-op->sexp-like bi-op args)
326 "BI-OP is a string with the name of a Scheme operator which in a Cabal file
327is represented by a binary operator. ARGS are the arguments of said operator.
328Return a string representing an S-expression of the operator applied to its
329arguments."
330 (if (= (length args) 1)
331 (first args)
332 (string-append "(" bi-op
333 (fold (lambda (arg seed) (string-append seed " " arg))
334 "" args) ")")))
335
336(define (not->sexp-like arg)
337 "If the string ARG is prefixed by a Cabal negation operator, convert it to
338an equivalent Scheme S-expression string."
339 (if (regexp-exec not-rx arg)
340 (string-append "(not "
341 (substring arg 1 (string-length arg))
342 ")")
343 arg))
344
345(define (parens-less-cond->sexp-like conditional)
346 "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme
347syntax. This procedure accepts only simple conditionals without parentheses."
348 ;; The outher operation is the one with the lowest priority: OR
349 (bi-op->sexp-like
350 "or"
351 ;; each OR argument may be an AND operation
352 (map (lambda (or-arg)
353 (let ((m-lst (list-matches and-rx or-arg)))
354 ;; is there an AND operation?
355 (if (> (length m-lst) 0)
356 (bi-op->sexp-like
357 "and"
358 ;; expand NOT operators when there are ANDs
359 (map not->sexp-like (bi-op-args or-arg m-lst)))
360 ;; ... and when there aren't.
361 (not->sexp-like or-arg))))
362 ;; list of OR arguments
363 (bi-op-args conditional (list-matches or-rx conditional)))))
364
365(define test-keyword-ornament "__")
366
367(define (conditional->sexp-like conditional)
368 "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme
369syntax."
370 ;; First we substitute TEST-KEYWORD-ORNAMENT for parentheses around tests
371 ;; keywords so that parentheses are only used to set precedences. This
372 ;; substantially simplify parsing.
373 (let ((conditional
374 (regexp-substitute/global #f tests-rx conditional
375 'pre 1 test-keyword-ornament 2
376 test-keyword-ornament 'post)))
377 (let loop ((sub-cond conditional))
378 (let ((rx-result (regexp-exec parens-rx sub-cond)))
379 (cond
380 (rx-result
381 (parens-less-cond->sexp-like
382 (string-append
383 (match:prefix rx-result)
384 (loop (match:substring rx-result 1))
385 (match:suffix rx-result))))
386 (else
387 (parens-less-cond->sexp-like sub-cond)))))))
388
389(define (eval-flags sexp-like-cond flags)
390 "SEXP-LIKE-COND is a string representing an S-expression conditional. FLAGS
391is a list of flag name and value pairs as produced by 'get-flags'. Substitute
392\"#t\" or \"#f\" according to the value of flags. (Default to \"True\")."
393 (fold-right
394 (lambda (flag sexp)
395 (match flag
396 ((name . value)
397 (let ((rx (make-regexp
398 (string-append "flag" test-keyword-ornament name
399 test-keyword-ornament))))
400 (regexp-substitute/global
401 #f rx sexp
402 'pre (if (string-ci= value "False") "#f" "#t") 'post)))
403 (_ sexp)))
404 sexp-like-cond
405 (cons '("[a-zA-Z0-9_-]+" . "True") flags)))
406
407(define (eval-tests->sexp sexp-like-cond)
408 "In the string SEXP-LIKE-COND substitute test keywords \"os(...)\" and
409\"arch(...)\" with equivalent Scheme checks. Retrun an S-expression."
410 (with-input-from-string
411 (fold-right
412 (lambda (test sexp)
413 (match test
414 ((type pre-match post-match)
415 (let ((rx (make-regexp
416 (string-append type test-keyword-ornament "(\\w+)"
417 test-keyword-ornament))))
418 (regexp-substitute/global
419 #f rx sexp
420 'pre pre-match 2 post-match 'post)))
421 (_ sexp)))
422 sexp-like-cond
423 ;; (%current-system) returns, e.g., "x86_64-linux" or "i686-linux".
424 '(("(os|arch)" "(string-match \"" "\" (%current-system))")))
425 read))
426
427(define (eval-impl sexp-like-cond)
428 "Check for the Cabal test \"impl(...)\" in the string SEXP-LIKE-COND.
429Assume the module declaring the generated package includes a local variable
430called \"haskell-implementation\" with a string value of the form NAME-VERSION
431against which we compare."
432 (with-output-to-string
433 (lambda ()
434 (write
435 (with-input-from-string
436 (fold-right
437 (lambda (test sexp)
438 (match test
439 ((pre-match post-match)
440 (let ((rx-with-version
441 (make-regexp
442 (string-append
443 "impl" test-keyword-ornament
444 "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *"
445 test-keyword-ornament)))
446 (rx-without-version
447 (make-regexp
448 (string-append "impl" test-keyword-ornament "(\\w+)"
449 test-keyword-ornament))))
450 (if (regexp-exec rx-with-version sexp)
451 (regexp-substitute/global
452 #f rx-with-version sexp
453 'pre pre-match 2 " " post-match " \"" 1 "-" 3 "\")" 'post)
454 (regexp-substitute/global
455 #f rx-without-version sexp
456 'pre pre-match "-match \"" 1 "\" " post-match ")" 'post))))
457 (_ sexp)))
458 sexp-like-cond
459 '(("(string" "haskell-implementation")))
460 read)))))
461
462(define (eval-cabal-keywords sexp-like-cond flags)
463 ((compose eval-tests->sexp eval-impl (cut eval-flags <> flags))
464 sexp-like-cond))
465
466(define (key->values meta key)
467 "META is the representation of a Cabal file as produced by 'read-cabal'.
468Return the list of values associated with a specific KEY (a string)."
469 (match meta
470 (() '())
471 (((((? (lambda(x) (equal? x key)))) v) r ...)
472 v)
473 (((k v) r ...)
474 (key->values (cdr meta) key))
475 (_ "key Not fount")))
476
477(define (key-start-end->entries meta key-start-rx key-end-rx)
478 "META is the representation of a Cabal file as produced by 'read-cabal'.
479Return all entries whose keys list starts with KEY-START and ends with
480KEY-END."
481 (let ((pred
482 (lambda (x)
483 (and (regexp-exec key-start-rx (first x))
484 (regexp-exec key-end-rx (last x))))))
485 ;; (equal? (list key-start key-end) (list (first x) (last x))))))
486 (match meta
487 (() '())
488 ((((? pred k) v) r ...)
489 (cons `(,k ,v)
490 (key-start-end->entries (cdr meta) key-start-rx key-end-rx)))
491 (((k v) r ...)
492 (key-start-end->entries (cdr meta) key-start-rx key-end-rx))
493 (_ "key Not fount"))))
494
495(define else-rx
496 (make-regexp "^else$"))
497
498(define (count-if-else rx-result-ls)
499 (apply + (map (lambda (m) (if m 1 0)) rx-result-ls)))
500
501(define (analyze-entry-cond entry)
502 (let* ((keys (first entry))
503 (vals (second entry))
504 (rx-cond-result
505 (map (cut regexp-exec condition-rx <>) keys))
506 (rx-else-result
507 (map (cut regexp-exec else-rx <>) keys))
508 (cond-no (count-if-else rx-cond-result))
509 (else-no (count-if-else rx-else-result))
510 (cond-idx (list-index (lambda (rx) (if rx #t #f)) rx-cond-result))
511 (else-idx (list-index (lambda (rx) (if rx #t #f)) rx-else-result))
512 (key-cond
513 (cond
514 ((or (and cond-idx else-idx (< cond-idx else-idx))
515 (and cond-idx (not else-idx)))
516 (match:substring
517 (receive (head tail)
518 (split-at rx-cond-result cond-idx) (first tail))))
519 ((or (and cond-idx else-idx (> cond-idx else-idx))
520 (and (not cond-idx) else-idx))
521 (match:substring
522 (receive (head tail)
523 (split-at rx-else-result else-idx) (first tail))))
524 (else
525 ""))))
526 (values keys vals rx-cond-result
527 rx-else-result cond-no else-no key-cond)))
528
529(define (remove-cond entry cond)
530 (match entry
531 ((k v)
532 (list (cdr (member cond k)) v))))
533
534(define (group-and-reduce-level entries group group-cond)
535 (let loop
536 ((true-group group)
537 (false-group '())
538 (entries entries))
539 (if (null? entries)
540 (values (reverse true-group) (reverse false-group) entries)
541 (let*-values (((entry) (first entries))
542 ((keys vals rx-cond-result rx-else-result
543 cond-no else-no key-cond)
544 (analyze-entry-cond entry)))
545 (cond
546 ((and (>= (+ cond-no else-no) 1) (string= group-cond key-cond))
547 (loop (cons (remove-cond entry group-cond) true-group) false-group
548 (cdr entries)))
549 ((and (>= (+ cond-no else-no) 1) (string= key-cond "else"))
550 (loop true-group (cons (remove-cond entry "else") false-group)
551 (cdr entries)))
552 (else
553 (values (reverse true-group) (reverse false-group) entries)))))))
554
555(define dependencies-rx
556 (make-regexp "([a-zA-Z0-9_-]+) *[^,]*,?"))
557
558(define (hackage-name->package-name name) 69(define (hackage-name->package-name name)
70 "Given the NAME of a Cabal package, return the corresponding Guix name."
559 (if (string-prefix? package-name-prefix name) 71 (if (string-prefix? package-name-prefix name)
560 (string-downcase name) 72 (string-downcase name)
561 (string-append package-name-prefix (string-downcase name)))) 73 (string-append package-name-prefix (string-downcase name))))
562 74
563(define (split-and-filter-dependencies ls names-to-filter)
564 "Split the comma separated list of dependencies LS coming from the Cabal
565file, filter packages included in NAMES-TO-FILTER and return a list with
566inputs suitable for the Guix package. Currently the version information is
567discarded."
568 (define (split-at-comma-and-filter d)
569 (fold
570 (lambda (m seed)
571 (let* ((name (string-downcase (match:substring m 1)))
572 (pkg-name (hackage-name->package-name name)))
573 (if (member name names-to-filter)
574 seed
575 (cons (list pkg-name (list 'unquote (string->symbol pkg-name)))
576 seed))))
577 '()
578 (list-matches dependencies-rx d)))
579
580 (fold (lambda (d p) (append (split-at-comma-and-filter d) p)) '() ls))
581
582(define* (dependencies-cond->sexp meta #:key (include-test-dependencies? #t))
583 "META is the representation of a Cabal file as produced by 'read-cabal'.
584Return an S-expression containing the list of dependencies as expected by the
585'inputs' field of a package. The generated S-expressions may include
586conditionals as defined in the cabal file. During this process we discard the
587version information of the packages."
588 (define (take-dependencies meta)
589 (let ((key-start-exe (make-regexp "executable"))
590 (key-start-lib (make-regexp "library"))
591 (key-start-tests (make-regexp "test-suite"))
592 (key-end (make-regexp "build-depends")))
593 (append
594 (key-start-end->entries meta key-start-exe key-end)
595 (key-start-end->entries meta key-start-lib key-end)
596 (if include-test-dependencies?
597 (key-start-end->entries meta key-start-tests key-end)
598 '()))))
599
600 (let ((flags (get-flags (pre-process-entries-keys meta)))
601 (augmented-ghc-std-libs (append (key->values meta "name")
602 ghc-standard-libraries)))
603 (delete-duplicates
604 (let loop ((entries (take-dependencies meta))
605 (result '()))
606 (if (null? entries)
607 (reverse result)
608 (let*-values (((entry) (first entries))
609 ((keys vals rx-cond-result rx-else-result
610 cond-no else-no key-cond)
611 (analyze-entry-cond entry)))
612 (cond
613 ((= (+ cond-no else-no) 0)
614 (loop (cdr entries)
615 (append
616 (split-and-filter-dependencies vals
617 augmented-ghc-std-libs)
618 result)))
619 (else
620 (let-values (((true-group false-group entries)
621 (group-and-reduce-level entries '()
622 key-cond))
623 ((cond-final) (eval-cabal-keywords
624 (conditional->sexp-like
625 (last (split-section key-cond)))
626 flags)))
627 (loop entries
628 (cond
629 ((or (eq? cond-final #t) (equal? cond-final '(not #f)))
630 (append (loop true-group '()) result))
631 ((or (eq? cond-final #f) (equal? cond-final '(not #t)))
632 (append (loop false-group '()) result))
633 (else
634 (let ((true-group-result (loop true-group '()))
635 (false-group-result (loop false-group '())))
636 (cond
637 ((and (null? true-group-result)
638 (null? false-group-result))
639 result)
640 ((null? false-group-result)
641 (cons `(unquote-splicing
642 (when ,cond-final ,true-group-result))
643 result))
644 ((null? true-group-result)
645 (cons `(unquote-splicing
646 (unless ,cond-final ,false-group-result))
647 result))
648 (else
649 (cons `(unquote-splicing
650 (if ,cond-final
651 ,true-group-result
652 ,false-group-result))
653 result))))))))))))))))
654
655;; Part 3:
656;;
657;; Retrive the desired package and its Cabal file from
658;; http://hackage.haskell.org and construct the Guix package S-expression.
659
660(define (hackage-fetch name-version) 75(define (hackage-fetch name-version)
661 "Return the Cabal file for the package NAME-VERSION, or #f on failure. If 76 "Return the Cabal file for the package NAME-VERSION, or #f on failure. If
662the version part is omitted from the package name, then return the latest 77the version part is omitted from the package name, then return the latest
@@ -696,33 +111,63 @@ version."
696 ((lst ...) `(list ,@(map string->license lst))) 111 ((lst ...) `(list ,@(map string->license lst)))
697 (_ #f))) 112 (_ #f)))
698 113
699(define* (hackage-module->sexp meta #:key (include-test-dependencies? #t)) 114
700 "Return the `package' S-expression for a Cabal package. META is the 115(define (cabal-dependencies->names cabal include-test-dependencies?)
116 "Return the list of dependencies names from the CABAL package object. If
117INCLUDE-TEST-DEPENDENCIES? is #f, do not include dependencies required by test
118suites."
119 (let* ((lib (cabal-package-library cabal))
120 (lib-deps (if (pair? lib)
121 (map cabal-dependency-name
122 (append-map cabal-library-dependencies lib))
123 '()))
124 (exe (cabal-package-executables cabal))
125 (exe-deps (if (pair? exe)
126 (map cabal-dependency-name
127 (append-map cabal-executable-dependencies exe))
128 '()))
129 (ts (cabal-package-test-suites cabal))
130 (ts-deps (if (pair? ts)
131 (map cabal-dependency-name
132 (append-map cabal-test-suite-dependencies ts))
133 '())))
134 (if include-test-dependencies?
135 (delete-duplicates (append lib-deps exe-deps ts-deps))
136 (delete-duplicates (append lib-deps exe-deps)))))
137
138(define (filter-dependencies dependencies own-name)
139 "Filter the dependencies included with the GHC compiler from DEPENDENCIES, a
140list with the names of dependencies. OWN-NAME is the name of the Cabal
141package being processed and is used to filter references to itself."
142 (filter (lambda (d) (not (member (string-downcase d)
143 (cons own-name ghc-standard-libraries))))
144 dependencies))
145
146(define* (hackage-module->sexp cabal #:key (include-test-dependencies? #t))
147 "Return the `package' S-expression for a Cabal package. CABAL is the
701representation of a Cabal file as produced by 'read-cabal'." 148representation of a Cabal file as produced by 'read-cabal'."
702 149
703 (define name 150 (define name
704 (first (key->values meta "name"))) 151 (cabal-package-name cabal))
705 152
706 (define version 153 (define version
707 (first (key->values meta "version"))) 154 (cabal-package-version cabal))
708
709 (define description
710 (let*-values (((description) (key->values meta "description"))
711 ((lines last)
712 (split-at description (- (length description) 1))))
713 (fold-right (lambda (line seed) (string-append line "\n" seed))
714 (first last) lines)))
715 155
716 (define source-url 156 (define source-url
717 (string-append "http://hackage.haskell.org/package/" name 157 (string-append "http://hackage.haskell.org/package/" name
718 "/" name "-" version ".tar.gz")) 158 "/" name "-" version ".tar.gz"))
719 159
720 ;; Several packages do not have an official home-page other than on Hackage. 160 (define dependencies
721 (define home-page 161 (let ((names
722 (let ((home-page-entry (key->values meta "homepage"))) 162 (map hackage-name->package-name
723 (if (null? home-page-entry) 163 ((compose (cut filter-dependencies <>
724 (string-append "http://hackage.haskell.org/package/" name) 164 (cabal-package-name cabal))
725 (first home-page-entry)))) 165 (cut cabal-dependencies->names <>
166 include-test-dependencies?))
167 cabal))))
168 (map (lambda (name)
169 (list name (list 'unquote (string->symbol name))))
170 names)))
726 171
727 (define (maybe-inputs input-type inputs) 172 (define (maybe-inputs input-type inputs)
728 (match inputs 173 (match inputs
@@ -732,6 +177,11 @@ representation of a Cabal file as produced by 'read-cabal'."
732 (list (list input-type 177 (list (list input-type
733 (list 'quasiquote inputs)))))) 178 (list 'quasiquote inputs))))))
734 179
180 (define (maybe-arguments)
181 (if (not include-test-dependencies?)
182 '((arguments `(#:tests? #f)))
183 '()))
184
735 (let ((tarball (with-store store 185 (let ((tarball (with-store store
736 (download-to-store store source-url)))) 186 (download-to-store store source-url))))
737 `(package 187 `(package
@@ -746,22 +196,33 @@ representation of a Cabal file as produced by 'read-cabal'."
746 (bytevector->nix-base32-string (file-sha256 tarball)) 196 (bytevector->nix-base32-string (file-sha256 tarball))
747 "failed to download tar archive"))))) 197 "failed to download tar archive")))))
748 (build-system haskell-build-system) 198 (build-system haskell-build-system)
749 ,@(maybe-inputs 'inputs 199 ,@(maybe-inputs 'inputs dependencies)
750 (dependencies-cond->sexp meta 200 ,@(maybe-arguments)
751 #:include-test-dependencies? 201 (home-page ,(cabal-package-home-page cabal))
752 include-test-dependencies?)) 202 (synopsis ,(cabal-package-synopsis cabal))
753 (home-page ,home-page) 203 (description ,(cabal-package-description cabal))
754 (synopsis ,@(key->values meta "synopsis")) 204 (license ,(string->license (cabal-package-license cabal))))))
755 (description ,description) 205
756 (license ,(string->license (key->values meta "license")))))) 206(define* (hackage->guix-package package-name #:key
757 207 (include-test-dependencies? #t)
758(define* (hackage->guix-package module-name 208 (port #f)
759 #:key (include-test-dependencies? #t)) 209 (cabal-environment '()))
760 "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, and return 210 "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the
761the `package' S-expression corresponding to that package, or #f on failure." 211called with keyword parameter PORT, from PORT. Return the `package'
762 (let ((module-meta (hackage-fetch module-name))) 212S-expression corresponding to that package, or #f on failure.
763 (and=> module-meta (cut hackage-module->sexp <> 213CABAL-ENVIRONMENT is an alist defining the environment in which the Cabal
764 #:include-test-dependencies? 214conditionals are evaluated. The accepted keys are: \"os\", \"arch\", \"impl\"
765 include-test-dependencies?)))) 215and the name of a flag. The value associated with a flag has to be either the
216symbol 'true' or 'false'. The value associated with other keys has to conform
217to the Cabal file format definition. The default value associated with the
218keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\"
219respectively."
220 (let ((cabal-meta (if port
221 (read-cabal port)
222 (hackage-fetch package-name))))
223 (and=> cabal-meta (compose (cut hackage-module->sexp <>
224 #:include-test-dependencies?
225 include-test-dependencies?)
226 (cut eval-cabal <> cabal-environment)))))
766 227
767;;; cabal.scm ends here 228;;; cabal.scm ends here
diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm
index f7c18cd3bf5..e5e9b0ed647 100644
--- a/guix/scripts/import/hackage.scm
+++ b/guix/scripts/import/hackage.scm
@@ -34,7 +34,9 @@
34;;; 34;;;
35 35
36(define %default-options 36(define %default-options
37 '((include-test-dependencies? . #t))) 37 '((include-test-dependencies? . #t)
38 (read-from-stdin? . #f)
39 ('cabal-environment . '())))
38 40
39(define (show-help) 41(define (show-help)
40 (display (_ "Usage: guix import hackage PACKAGE-NAME 42 (display (_ "Usage: guix import hackage PACKAGE-NAME
@@ -45,8 +47,13 @@ package will be generated. If no version suffix is pecified, then the
45generated package definition will correspond to the latest available 47generated package definition will correspond to the latest available
46version.\n")) 48version.\n"))
47 (display (_ " 49 (display (_ "
50 -e ALIST, --cabal-environment=ALIST
51 specify environment for Cabal evaluation"))
52 (display (_ "
48 -h, --help display this help and exit")) 53 -h, --help display this help and exit"))
49 (display (_ " 54 (display (_ "
55 -s, --stdin read from standard input"))
56 (display (_ "
50 -t, --no-test-dependencies don't include test only dependencies")) 57 -t, --no-test-dependencies don't include test only dependencies"))
51 (display (_ " 58 (display (_ "
52 -V, --version display version information and exit")) 59 -V, --version display version information and exit"))
@@ -67,6 +74,16 @@ version.\n"))
67 (alist-cons 'include-test-dependencies? #f 74 (alist-cons 'include-test-dependencies? #f
68 (alist-delete 'include-test-dependencies? 75 (alist-delete 'include-test-dependencies?
69 result)))) 76 result))))
77 (option '(#\s "stdin") #f #f
78 (lambda (opt name arg result)
79 (alist-cons 'read-from-stdin? #t
80 (alist-delete 'read-from-stdin?
81 result))))
82 (option '(#\e "cabal-environment") #t #f
83 (lambda (opt name arg result)
84 (alist-cons 'cabal-environment (read/eval arg)
85 (alist-delete 'cabal-environment
86 result))))
70 %standard-import-options)) 87 %standard-import-options))
71 88
72 89
@@ -84,23 +101,42 @@ version.\n"))
84 (alist-cons 'argument arg result)) 101 (alist-cons 'argument arg result))
85 %default-options)) 102 %default-options))
86 103
104 (define (run-importer package-name opts error-fn)
105 (let ((sexp (hackage->guix-package
106 package-name
107 #:include-test-dependencies?
108 (assoc-ref opts 'include-test-dependencies?)
109 #:port (if (assoc-ref opts 'read-from-stdin?)
110 (current-input-port)
111 #f)
112 #:cabal-environment
113 (assoc-ref opts 'cabal-environment))))
114 (unless sexp (error-fn))
115 sexp))
116
87 (let* ((opts (parse-options)) 117 (let* ((opts (parse-options))
88 (args (filter-map (match-lambda 118 (args (filter-map (match-lambda
89 (('argument . value) 119 (('argument . value)
90 value) 120 value)
91 (_ #f)) 121 (_ #f))
92 (reverse opts)))) 122 (reverse opts))))
93 (match args 123 (if (assoc-ref opts 'read-from-stdin?)
94 ((package-name) 124 (match args
95 (let ((sexp (hackage->guix-package 125 (()
96 package-name 126 (run-importer "stdin" opts
97 #:include-test-dependencies? 127 (lambda ()
98 (assoc-ref opts 'include-test-dependencies?)))) 128 (leave (_ "failed to import cabal file from '~a'~%"))
99 (unless sexp 129 package-name)))
100 (leave (_ "failed to download cabal file for package '~a'~%") 130 ((many ...)
101 package-name)) 131 (leave (_ "too many arguments~%"))))
102 sexp)) 132 (match args
103 (() 133 ((package-name)
104 (leave (_ "too few arguments~%"))) 134 (run-importer package-name opts
105 ((many ...) 135 (lambda ()
106 (leave (_ "too many arguments~%")))))) 136 (leave
137 (_ "failed to download cabal file for package '~a'~%"))
138 package-name)))
139 (()
140 (leave (_ "too few arguments~%")))
141 ((many ...)
142 (leave (_ "too many arguments~%")))))))
diff --git a/tests/hackage.scm b/tests/hackage.scm
index 23b854caa49..229bee35ea6 100644
--- a/tests/hackage.scm
+++ b/tests/hackage.scm
@@ -17,6 +17,7 @@
17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. 17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18 18
19(define-module (test-hackage) 19(define-module (test-hackage)
20 #:use-module (guix import cabal)
20 #:use-module (guix import hackage) 21 #:use-module (guix import hackage)
21 #:use-module (guix tests) 22 #:use-module (guix tests)
22 #:use-module (srfi srfi-64) 23 #:use-module (srfi srfi-64)
@@ -35,44 +36,44 @@ executable cabal
35 mtl >= 2.0 && < 3 36 mtl >= 2.0 && < 3
36") 37")
37 38
38;; Use TABs to indent lines and to separate keys from value.
39(define test-cabal-2 39(define test-cabal-2
40 "name: foo
41version: 1.0.0
42homepage: http://test.org
43synopsis: synopsis
44description: description
45license: BSD3
46executable cabal
47 build-depends: HTTP >= 4000.2.5 && < 4000.3,
48 mtl >= 2.0 && < 3
49")
50
51;; Use indentation with comma as found, e.g., in 'haddock-api'.
52(define test-cabal-3
53 "name: foo 40 "name: foo
54version: 1.0.0 41version: 1.0.0
55homepage: http://test.org 42homepage: http://test.org
56synopsis: synopsis 43synopsis: synopsis
57description: description 44description: description
58license: BSD3 45license: BSD3
59executable cabal 46executable cabal {
60 build-depends: 47build-depends:
61 HTTP >= 4000.2.5 && < 4000.3 48 HTTP >= 4000.2.5 && < 4000.3,
62 , mtl >= 2.0 && < 3 49 mtl >= 2.0 && < 3
50}
63") 51")
64 52
65(define test-cond-1 53;; A fragment of a real Cabal file with minor modification to check precedence
66 "(os(darwin) || !(flag(debug))) && flag(cips)") 54;; of 'and' over 'or'.
67 55(define test-read-cabal-1
68(define read-cabal 56 "name: test-me
69 (@@ (guix import hackage) read-cabal)) 57library
70 58 -- Choose which library versions to use.
71(define eval-cabal-keywords 59 if flag(base4point8)
72 (@@ (guix import hackage) eval-cabal-keywords)) 60 Build-depends: base >= 4.8 && < 5
73 61 else
74(define conditional->sexp-like 62 if flag(base4)
75 (@@ (guix import hackage) conditional->sexp-like)) 63 Build-depends: base >= 4 && < 4.8
64 else
65 if flag(base3)
66 Build-depends: base >= 3 && < 4
67 else
68 Build-depends: base < 3
69 if flag(base4point8) || flag(base4) && flag(base3)
70 Build-depends: random
71 Build-depends: containers
72
73 -- Modules that are always built.
74 Exposed-Modules:
75 Test.QuickCheck.Exception
76")
76 77
77(test-begin "hackage") 78(test-begin "hackage")
78 79
@@ -115,18 +116,25 @@ executable cabal
115(test-assert "hackage->guix-package test 2" 116(test-assert "hackage->guix-package test 2"
116 (eval-test-with-cabal test-cabal-2)) 117 (eval-test-with-cabal test-cabal-2))
117 118
118(test-assert "hackage->guix-package test 3" 119(test-assert "read-cabal test 1"
119 (eval-test-with-cabal test-cabal-3)) 120 (match (call-with-input-string test-read-cabal-1 read-cabal)
120 121 ((("name" ("test-me"))
121(test-assert "conditional->sexp-like" 122 ('section 'library
122 (match 123 (('if ('flag "base4point8")
123 (eval-cabal-keywords 124 (("build-depends" ("base >= 4.8 && < 5")))
124 (conditional->sexp-like test-cond-1) 125 (('if ('flag "base4")
125 '(("debug" . "False"))) 126 (("build-depends" ("base >= 4 && < 4.8")))
126 (('and ('or ('string-match "darwin" ('%current-system)) ('not '#f)) '#t) 127 (('if ('flag "base3")
128 (("build-depends" ("base >= 3 && < 4")))
129 (("build-depends" ("base < 3"))))))))
130 ('if ('or ('flag "base4point8")
131 ('and ('flag "base4") ('flag "base3")))
132 (("build-depends" ("random")))
133 ())
134 ("build-depends" ("containers"))
135 ("exposed-modules" ("Test.QuickCheck.Exception")))))
127 #t) 136 #t)
128 (x 137 (x (pk 'fail x #f))))
129 (pk 'fail x #f))))
130 138
131(test-end "hackage") 139(test-end "hackage")
132 140