diff options
| author | Federico Beffa <beffa@fbengineering.ch> | 2015-04-26 11:22:29 +0200 |
|---|---|---|
| committer | Federico Beffa <beffa@fbengineering.ch> | 2015-06-09 09:48:38 +0200 |
| commit | a4154748730b28fd98ff30d968c755c37802a49a (patch) | |
| tree | a2d2375001ab676cf98172aabb139d05762ba45c | |
| parent | 0705f79c6f45108961b901e50f828a978fa0e4e8 (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.am | 4 | ||||
| -rw-r--r-- | doc/guix.texi | 22 | ||||
| -rw-r--r-- | guix/import/cabal.scm | 815 | ||||
| -rw-r--r-- | guix/import/hackage.scm | 703 | ||||
| -rw-r--r-- | guix/scripts/import/hackage.scm | 66 | ||||
| -rw-r--r-- | tests/hackage.scm | 88 |
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. | |||
| 3754 | Specific command-line options are: | 3754 | Specific command-line options are: |
| 3755 | 3755 | ||
| 3756 | @table @code | 3756 | @table @code |
| 3757 | @item --stdin | ||
| 3758 | @itemx -s | ||
| 3759 | Read a Cabal file from the standard input. | ||
| 3757 | @item --no-test-dependencies | 3760 | @item --no-test-dependencies |
| 3758 | @itemx -t | 3761 | @itemx -t |
| 3759 | Do not include dependencies only required to run the test suite. | 3762 | Do 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 | ||
| 3766 | Cabal conditionals are evaluated. The accepted keys are: @code{os}, | ||
| 3767 | @code{arch}, @code{impl} and a string representing the name of a flag. | ||
| 3768 | The value associated with a flag has to be either the symbol | ||
| 3769 | @code{true} or @code{false}. The value associated with other keys | ||
| 3770 | has to conform to the Cabal file format definition. The default value | ||
| 3771 | associated 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 | ||
| 3762 | The command below imports meta-data for the latest version of the | 3775 | The 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 |
| 3777 | specifying the value of the flag @samp{network-uri} as @code{false}: | ||
| 3764 | 3778 | ||
| 3765 | @example | 3779 | @example |
| 3766 | guix import hackage -t HTTP | 3780 | guix import hackage -t -e "'((\"network-uri\" . false))" HTTP |
| 3767 | @end example | 3781 | @end example |
| 3768 | 3782 | ||
| 3769 | A specific package version may optionally be specified by following the | 3783 | A 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 |
| 3773 | guix import hackage mtl-2.1.3.1 | 3787 | guix import hackage mtl-2.1.3.1 |
| 3774 | @end example | 3788 | @end example |
| 3775 | |||
| 3776 | Currently only indentation structured Cabal files are supported. | ||
| 3777 | @end table | 3789 | @end table |
| 3778 | 3790 | ||
| 3779 | The structure of the @command{guix import} code is modular. It would be | 3791 | The 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 | ||
| 98 | requested by calling it with one of the following symbols as the first | ||
| 99 | argument: 'empty?, 'push!, 'top, 'pop! and 'clear!. The action 'push! is the | ||
| 100 | only one requiring a second argument corresponding to the object to be added | ||
| 101 | to 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 | ||
| 225 | and returns the indentation of the line starting after the #\newline | ||
| 226 | character. 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 | ||
| 243 | following 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, | ||
| 257 | otherwise 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 | ||
| 275 | check 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-, | ||
| 305 | or 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 | ||
| 322 | string 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 | ||
| 374 | predicate IS?, or (ii) it satisfies the predicate IS-IF-FOLLOWED-BY? and the | ||
| 375 | character immediately following it satisfies IS-ALLOWED-FOLLOWER?. Returns a | ||
| 376 | string 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, | ||
| 431 | execute HOOK-FN if it isn't #f and return a lexical token of type TOKEN with | ||
| 432 | location 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 | ||
| 463 | PORT. If no token can be recognized return #f. LOC is the current port | ||
| 464 | location." | ||
| 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. | ||
| 479 | LOC 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 | ||
| 490 | the 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. | ||
| 539 | If #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 | ||
| 629 | list 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 | ||
| 635 | and return a 'cabal-package' object. The values of all tests can be | ||
| 636 | overwritten by specifying the desired value in ENV. ENV must be an alist. | ||
| 637 | The accepted keys are: \"os\", \"arch\", \"impl\" and a name of a flag. The | ||
| 638 | value associated with a flag has to be either \"true\" or \"false\". The | ||
| 639 | value associated with other keys has to conform to the Cabal file format | ||
| 640 | definition." | ||
| 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, | ||
| 659 | the 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. \ | ||
| 726 | See 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 | ||
| 754 | pertaining 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 | ||
| 790 | KEY-VALUES-LIST. The optional DELIMITER is used to specify a delimiter string | ||
| 791 | to 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 | ||
| 805 | KEY-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 | ||
| 100 | line (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 | ||
| 115 | remaining input lines to be read. SEED is the value read on the same line as | ||
| 116 | the key. Return two values: A list with values and the remaining lines to be | ||
| 117 | processed." | ||
| 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 | |||
| 142 | We try do deduce the Cabal format from the following document: | ||
| 143 | https://www.haskell.org/cabal/users-guide/developing-packages.html | ||
| 144 | |||
| 145 | Keys are case-insensitive. We therefore lowercase them. Values are | ||
| 146 | case-sensitive. Currently only indentation-structured files are parsed. | ||
| 147 | Braces 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 | ||
| 265 | produced by 'read-cabal'. Split each element of the keys list into individual | ||
| 266 | words. 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 | ||
| 276 | list, 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 | ||
| 278 | their 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 | ||
| 318 | is 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 | ||
| 327 | is represented by a binary operator. ARGS are the arguments of said operator. | ||
| 328 | Return a string representing an S-expression of the operator applied to its | ||
| 329 | arguments." | ||
| 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 | ||
| 338 | an 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 | ||
| 347 | syntax. 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 | ||
| 369 | syntax." | ||
| 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 | ||
| 391 | is 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. | ||
| 429 | Assume the module declaring the generated package includes a local variable | ||
| 430 | called \"haskell-implementation\" with a string value of the form NAME-VERSION | ||
| 431 | against 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'. | ||
| 468 | Return 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'. | ||
| 479 | Return all entries whose keys list starts with KEY-START and ends with | ||
| 480 | KEY-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 | ||
| 565 | file, filter packages included in NAMES-TO-FILTER and return a list with | ||
| 566 | inputs suitable for the Guix package. Currently the version information is | ||
| 567 | discarded." | ||
| 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'. | ||
| 584 | Return an S-expression containing the list of dependencies as expected by the | ||
| 585 | 'inputs' field of a package. The generated S-expressions may include | ||
| 586 | conditionals as defined in the cabal file. During this process we discard the | ||
| 587 | version 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 |
| 662 | the version part is omitted from the package name, then return the latest | 77 | the 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 | ||
| 117 | INCLUDE-TEST-DEPENDENCIES? is #f, do not include dependencies required by test | ||
| 118 | suites." | ||
| 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 | ||
| 140 | list with the names of dependencies. OWN-NAME is the name of the Cabal | ||
| 141 | package 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 | ||
| 701 | representation of a Cabal file as produced by 'read-cabal'." | 148 | representation 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 |
| 761 | the `package' S-expression corresponding to that package, or #f on failure." | 211 | called with keyword parameter PORT, from PORT. Return the `package' |
| 762 | (let ((module-meta (hackage-fetch module-name))) | 212 | S-expression corresponding to that package, or #f on failure. |
| 763 | (and=> module-meta (cut hackage-module->sexp <> | 213 | CABAL-ENVIRONMENT is an alist defining the environment in which the Cabal |
| 764 | #:include-test-dependencies? | 214 | conditionals are evaluated. The accepted keys are: \"os\", \"arch\", \"impl\" |
| 765 | include-test-dependencies?)))) | 215 | and the name of a flag. The value associated with a flag has to be either the |
| 216 | symbol 'true' or 'false'. The value associated with other keys has to conform | ||
| 217 | to the Cabal file format definition. The default value associated with the | ||
| 218 | keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\" | ||
| 219 | respectively." | ||
| 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 | |||
| 45 | generated package definition will correspond to the latest available | 47 | generated package definition will correspond to the latest available |
| 46 | version.\n")) | 48 | version.\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 | ||
| 41 | version: 1.0.0 | ||
| 42 | homepage: http://test.org | ||
| 43 | synopsis: synopsis | ||
| 44 | description: description | ||
| 45 | license: BSD3 | ||
| 46 | executable 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 |
| 54 | version: 1.0.0 | 41 | version: 1.0.0 |
| 55 | homepage: http://test.org | 42 | homepage: http://test.org |
| 56 | synopsis: synopsis | 43 | synopsis: synopsis |
| 57 | description: description | 44 | description: description |
| 58 | license: BSD3 | 45 | license: BSD3 |
| 59 | executable cabal | 46 | executable cabal { |
| 60 | build-depends: | 47 | build-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)) | 57 | library |
| 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 | ||
