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'.

2 files changed, 897 insertions, 621 deletions

diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
new file mode 100644
index 0000000000..dfeba88312
--- /dev/null
+++ b/guix/import/cabal.scm
@@ -0,0 +1,815 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix import cabal)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (system base lalr)
+  #:use-module (rnrs enums)
+  #:export (read-cabal
+            eval-cabal
+            
+            cabal-package?
+            cabal-package-name
+            cabal-package-version
+            cabal-package-license
+            cabal-package-home-page
+            cabal-package-source-repository
+            cabal-package-synopsis
+            cabal-package-description
+            cabal-package-executables
+            cabal-package-library
+            cabal-package-test-suites
+            cabal-package-flags
+            cabal-package-eval-environment
+
+            cabal-source-repository?
+            cabal-source-repository-use-case
+            cabal-source-repository-type
+            cabal-source-repository-location
+
+            cabal-flag?
+            cabal-flag-name
+            cabal-flag-description
+            cabal-flag-default
+            cabal-flag-manual
+
+            cabal-dependency?
+            cabal-dependency-name
+            cabal-dependency-version
+
+            cabal-executable?
+            cabal-executable-name
+            cabal-executable-dependencies
+
+            cabal-library?
+            cabal-library-dependencies
+
+            cabal-test-suite?
+            cabal-test-suite-name
+            cabal-test-suite-dependencies))
+
+;; Part 1:
+;;
+;; Functions used to read a Cabal file.
+
+;; Comment:
+;;
+;; The use of virtual closing braces VCCURLY and some lexer functions were
+;; inspired from http://hackage.haskell.org/package/haskell-src
+
+;; Object containing information about the structure of a block: (i) delimited
+;; by braces or by indentation, (ii) minimum indentation.
+(define-record-type  <parse-context>
+  (make-parse-context mode indentation)
+  parse-context?
+  (mode parse-context-mode)                ; 'layout or 'no-layout
+  (indentation parse-context-indentation)) ; #f for 'no-layout
+
+;; <parse-context> mode set universe
+(define-enumeration context (layout no-layout) make-context)
+
+(define (make-stack)
+  "Creates a simple stack closure.  Actions on the generated stack are
+requested by calling it with one of the following symbols as the first
+argument: 'empty?, 'push!, 'top, 'pop! and 'clear!.  The action 'push! is the
+only one requiring a second argument corresponding to the object to be added
+to the stack."
+  (let ((stack '()))
+    (lambda (msg . args)
+      (cond ((eqv? msg 'empty?) (null? stack))
+            ((eqv? msg 'push!) (set! stack (cons (first args) stack)))
+            ((eqv? msg 'top) (if (null? stack) '() (first stack)))
+            ((eqv? msg 'pop!) (match stack
+                                ((e r ...) (set! stack (cdr stack)) e)
+                                (_ #f)))
+            ((eqv? msg 'clear!) (set! stack '()))
+            (else #f)))))
+
+;; Stack to track the structure of nested blocks and simple interface
+(define context-stack (make-parameter (make-stack)))
+
+(define (context-stack-empty?) ((context-stack) 'empty?))
+
+(define (context-stack-push! e) ((context-stack) 'push! e))
+
+(define (context-stack-top) ((context-stack) 'top))
+
+(define (context-stack-pop!) ((context-stack) 'pop!))
+
+(define (context-stack-clear!) ((context-stack) 'clear!))
+
+;; Indentation of the line being parsed.
+(define current-indentation (make-parameter 0))
+
+;; Signal to reprocess the beginning of line, in case we need to close more
+;; than one indentation level.
+(define check-bol? (make-parameter #f))
+
+;; Name of the file being parsed. Used in error messages.
+(define cabal-file-name (make-parameter "unknowk"))
+
+;; Specify the grammar of a Cabal file and generate a suitable syntax analyser.
+(define (make-cabal-parser)
+  "Generate a parser for Cabal files."
+  (lalr-parser
+   ;; --- token definitions
+   (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION
+           (right: IF FLAG EXEC TEST-SUITE SOURCE-REPO BENCHMARK LIB OCURLY)
+           (left: OR)
+           (left: PROPERTY AND)
+           (right: ELSE NOT))
+   ;; --- rules
+   (body        (properties sections)   : (append $1 $2))
+   (sections    (sections flags)        : (append $1 $2)
+                (sections source-repo)  : (append $1 (list $2))
+                (sections executables)  : (append $1 $2)
+                (sections test-suites)  : (append $1 $2)
+                (sections benchmarks)   : (append $1 $2)
+                (sections lib-sec)      : (append $1 (list $2))
+                ()                      : '())
+   (flags       (flags flag-sec)        : (append $1 (list $2))
+                (flag-sec)              : (list $1))
+   (flag-sec    (FLAG OCURLY properties CCURLY) : `(section flag ,$1 ,$3)
+                (FLAG open properties close)    : `(section flag ,$1 ,$3)
+                (FLAG)                          : `(section flag ,$1 '()))
+   (source-repo (SOURCE-REPO OCURLY properties CCURLY)
+                : `(section source-repository ,$1 ,$3)
+                (SOURCE-REPO open properties close)
+                : `(section source-repository ,$1 ,$3))
+   (properties  (properties PROPERTY)   : (append $1 (list $2))
+                (PROPERTY)              : (list $1))
+   (executables (executables exec-sec)  : (append $1 (list $2))
+                (exec-sec)              : (list $1))
+   (exec-sec    (EXEC OCURLY exprs CCURLY) : `(section executable ,$1 ,$3)
+                (EXEC open exprs close)    : `(section executable ,$1 ,$3))
+   (test-suites (test-suites ts-sec)    : (append $1 (list $2))
+                (ts-sec)                : (list $1))
+   (ts-sec      (TEST-SUITE OCURLY exprs CCURLY) : `(section test-suite ,$1 ,$3)
+                (TEST-SUITE open exprs close)    : `(section test-suite ,$1 ,$3))
+   (benchmarks  (benchmarks bm-sec)     : (append $1 (list $2))
+                (bm-sec)                : (list $1))
+   (bm-sec      (BENCHMARK OCURLY exprs CCURLY) : `(section benchmark ,$1 ,$3)
+                (BENCHMARK open exprs close)    : `(section benchmark ,$1 ,$3))
+   (lib-sec     (LIB OCURLY exprs CCURLY) : `(section library ,$3)
+                (LIB open exprs close)    : `(section library ,$3))
+   (exprs       (exprs PROPERTY)         : (append $1 (list $2))
+                (PROPERTY)               : (list $1)
+                (exprs if-then-else)     : (append $1 (list $2))
+                (if-then-else)           : (list $1)
+                (exprs if-then)          : (append $1 (list $2))
+                (if-then)                : (list $1))
+   (if-then-else (IF tests OCURLY exprs CCURLY ELSE OCURLY exprs CCURLY)
+                 : `(if ,$2 ,$4 ,$8)
+                 (IF tests open exprs close ELSE OCURLY exprs CCURLY)
+                 : `(if ,$2 ,$4 ,$8)
+                 ;; The 'open' token after 'tests' is shifted after an 'exprs'
+                 ;; is found.  This is because, instead of 'exprs' a 'OCURLY'
+                 ;; token is a valid alternative.  For this reason, 'open'
+                 ;; pushes a <parse-context> with a line indentation equal to
+                 ;; the indentation of 'exprs'.
+                 ;;
+                 ;; Differently from this, without the rule above this
+                 ;; comment, when an 'ELSE' token is found, the 'open' token
+                 ;; following the 'ELSE' would be shifted immediately, before
+                 ;; the 'exprs' is found (because there are no other valid
+                 ;; tokens).  The 'open' would therefore create a
+                 ;; <parse-context> with the indentation of 'ELSE' and not
+                 ;; 'exprs', creating an inconsistency.  We therefore allow
+                 ;; mixed style conditionals.
+                 (IF tests open exprs close ELSE open exprs close)
+                 : `(if ,$2 ,$4 ,$8))
+   (if-then     (IF tests OCURLY exprs CCURLY) : `(if ,$2 ,$4 ())
+                (IF tests open exprs close)    : `(if ,$2 ,$4 ()))
+   (tests       (TEST OPAREN ID CPAREN)        : `(,$1 ,$3)
+                (TEST OPAREN ID RELATION VERSION CPAREN)
+                : `(,$1 ,(string-append $3 " " $4 " " $5))
+                (TEST OPAREN ID RELATION VERSION AND RELATION VERSION CPAREN)
+                : `(and (,$1 ,(string-append $3 " " $4 " " $5))
+                        (,$1 ,(string-append $3 " " $7 " " $8)))
+               (NOT tests)                     : `(not ,$2)
+               (tests AND tests)               : `(and ,$1 ,$3)
+               (tests OR tests)                : `(or ,$1 ,$3)
+               (OPAREN tests CPAREN)           : $2)
+   (open       () : (context-stack-push!
+                                   (make-parse-context (context layout)
+                                                       (current-indentation))))
+   (close      (VCCURLY))))
+
+(define (peek-next-line-indent port)
+  "This function can be called when the next character on PORT is #\newline
+and returns the indentation of the line starting after the #\newline
+character.  Discard (and consume) empty and comment lines."
+  (let ((initial-newline (string (read-char port))))
+    (let loop ((char (peek-char port))
+               (word ""))
+      (cond ((eqv? char #\newline) (read-char port)
+             (loop (peek-char port) ""))
+            ((or (eqv? char #\space) (eqv? char #\tab))
+             (let ((c (read-char port)))
+               (loop (peek-char port) (string-append word (string c)))))
+            ((comment-line port char) (loop (peek-char port) ""))
+            (else
+             (let ((len (string-length word)))
+               (unread-string (string-append initial-newline word) port)
+               len))))))
+
+(define* (read-value port value min-indent #:optional (separator " "))
+  "The next character on PORT must be #\newline.  Append to VALUE the
+following lines with indentation larger than MIN-INDENT."
+  (let loop ((val (string-trim-both value))
+             (x (peek-next-line-indent port)))
+    (if (> x min-indent)
+        (begin
+          (read-char port) ; consume #\newline
+          (loop (string-append
+                 val (if (string-null? val) "" separator)
+                 (string-trim-both (read-delimited "\n" port 'peek)))
+                (peek-next-line-indent port)))
+        val)))
+
+(define (lex-white-space port bol)
+  "Consume white spaces and comment lines on PORT.  If a new line is started return #t,
+otherwise return BOL (beginning-of-line)."
+  (let loop ((c (peek-char port))
+             (bol bol))
+    (cond
+     ((and (not (eof-object? c))
+           (or (char=? c #\space) (char=? c #\tab)))
+      (read-char port)
+      (loop (peek-char port) bol))
+     ((and (not (eof-object? c)) (char=? c #\newline))
+      (read-char port)
+      (loop (peek-char port) #t))
+     ((comment-line port c)
+      (lex-white-space port bol))
+     (else
+      bol))))
+
+(define (lex-bol port)
+  "Process the beginning of a line on PORT: update current-indentation and
+check the end of an indentation based context."
+  (let ((loc (make-source-location (cabal-file-name) (port-line port)
+                                   (port-column port) -1 -1)))
+    (current-indentation (source-location-column loc))
+    (case (get-offside port)
+      ((less-than)
+       (check-bol? #t) ; need to check if closing more than 1 indent level.
+       (unless (context-stack-empty?) (context-stack-pop!))
+       (make-lexical-token 'VCCURLY loc #f))
+      (else
+       (lex-token port)))))
+
+(define (bol? port) (or (check-bol?) (= (port-column port) 0)))
+
+(define (comment-line port c)
+  "If PORT starts with a comment line, consume it up to, but not including
+#\newline.  C is the next character on PORT."
+  (cond ((and (not (eof-object? c)) (char=? c #\-))
+         (read-char port)
+         (let ((c2 (peek-char port)))
+           (if (char=? c2 #\-)
+               (read-delimited "\n" port 'peek)
+               (begin (unread-char c port) #f))))
+        (else #f)))
+
+(define-enumeration ordering (less-than equal greater-than) make-ordering)
+
+(define (get-offside port)
+  "In an indentation based context return the symbol 'greater-than, 'equal or
+'less-than to signal if the current column number on PORT is greater-, equal-,
+or less-than the indentation of the current context."
+  (let ((x (port-column port)))
+    (match (context-stack-top)
+      (($ <parse-context> 'layout indentation)
+       (cond
+        ((> x indentation) (ordering greater-than))
+        ((= x indentation) (ordering equal))
+        (else (ordering less-than))))
+      (_ (ordering greater-than)))))
+ 
+;; (Semi-)Predicates for individual tokens.
+
+(define (is-relation? c)
+  (and (char? c) (any (cut char=? c <>) '(#\< #\> #\=))))
+
+(define (make-rx-matcher pat)
+  "Compile PAT into a regular expression and creates a function matching a
+string against the created regexp."
+  (let ((rx (make-regexp pat))) (cut regexp-exec rx <>)))
+
+(define is-property (make-rx-matcher "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$"))
+
+(define is-flag (make-rx-matcher "^[Ff]lag +([a-zA-Z0-9_-]+)"))
+
+(define is-src-repo
+  (make-rx-matcher "^[Ss]ource-[Rr]epository +([a-zA-Z0-9_-]+)"))
+
+(define is-exec (make-rx-matcher "^[Ee]xecutable +([a-zA-Z0-9_-]+)"))
+
+(define is-test-suite (make-rx-matcher "^[Tt]est-[Ss]uite +([a-zA-Z0-9_-]+)"))
+
+(define is-benchmark (make-rx-matcher "^[Bb]enchmark +([a-zA-Z0-9_-]+)"))
+
+(define is-lib (make-rx-matcher "^[Ll]ibrary *"))
+
+(define is-else (make-rx-matcher "^else"))
+
+(define (is-if s) (string=? s "if"))
+
+(define (is-and s) (string=? s "&&"))
+
+(define (is-or s) (string=? s "||"))
+
+(define (is-id s)
+  (let ((cabal-reserved-words
+         '("if" "else" "library" "flag" "executable" "test-suite"
+           "source-repository" "benchmark")))
+    (and (every (cut string-ci<> s <>) cabal-reserved-words)
+         (not (char=? (last (string->list s)) #\:)))))
+
+(define (is-test s port)
+  (let ((tests-rx (make-regexp "os|arch|flag|impl"))
+        (c (peek-char port)))
+    (and (regexp-exec tests-rx s) (char=? #\( c))))
+
+;; Lexers for individual tokens.
+
+(define (lex-relation loc port)
+  (make-lexical-token 'RELATION loc (read-while is-relation? port)))
+
+(define (lex-version loc port)
+  (make-lexical-token 'VERSION loc
+                      (read-while char-numeric? port
+                                  (cut char=? #\. <>) char-numeric?)))
+
+(define* (read-while is? port #:optional
+                     (is-if-followed-by? (lambda (c) #f))
+                     (is-allowed-follower? (lambda (c) #f)))
+  "Read from PORT as long as: (i) either the read character satisfies the
+predicate IS?, or (ii) it satisfies the predicate IS-IF-FOLLOWED-BY? and the
+character immediately following it satisfies IS-ALLOWED-FOLLOWER?.  Returns a
+string with the read characters."
+  (let loop ((c (peek-char port))
+             (res '()))
+    (cond ((and (not (eof-object? c)) (is? c))
+           (let ((c (read-char port)))
+             (loop (peek-char port) (append res (list c)))))
+          ((and (not (eof-object? c)) (is-if-followed-by? c))
+           (let ((c (read-char port))
+                 (c2 (peek-char port)))
+             (if (and (not (eof-object? c2)) (is-allowed-follower? c2))
+                 (loop c2 (append res (list c)))
+                 (begin (unread-char c) (list->string res)))))
+          (else (list->string res)))))
+
+(define (lex-property k-v-rx-res loc port)
+  (let ((key (string-downcase (match:substring k-v-rx-res 1)))
+        (value (match:substring k-v-rx-res 2)))
+    (make-lexical-token
+     'PROPERTY loc
+     (list key `(,(read-value port value (current-indentation)))))))
+
+(define (lex-rx-res rx-res token loc)
+  (let ((name (string-downcase (match:substring rx-res 1))))
+    (make-lexical-token token loc name)))
+
+(define (lex-flag flag-rx-res loc) (lex-rx-res flag-rx-res 'FLAG loc))
+
+(define (lex-src-repo src-repo-rx-res loc)
+  (lex-rx-res src-repo-rx-res 'SOURCE-REPO loc))
+
+(define (lex-exec exec-rx-res loc) (lex-rx-res exec-rx-res 'EXEC loc))
+
+(define (lex-test-suite ts-rx-res loc) (lex-rx-res ts-rx-res 'TEST-SUITE loc))
+
+(define (lex-benchmark bm-rx-res loc) (lex-rx-res bm-rx-res 'BENCHMARK loc))
+
+(define (lex-lib loc) (make-lexical-token 'LIB loc #f))
+
+(define (lex-else loc) (make-lexical-token 'ELSE loc #f))
+
+(define (lex-if loc) (make-lexical-token 'IF loc #f))
+
+(define (lex-and loc) (make-lexical-token 'AND loc #f))
+
+(define (lex-or loc) (make-lexical-token 'OR loc #f))
+
+(define (lex-id w loc) (make-lexical-token 'ID loc w))
+
+(define (lex-test w loc) (make-lexical-token 'TEST loc (string->symbol w)))
+
+;; Lexer for tokens recognizable by single char.
+
+(define* (is-ref-char->token ref-char next-char token loc port
+                         #:optional (hook-fn #f))
+  "If the next character NEXT-CHAR on PORT is REF-CHAR, then read it,
+execute HOOK-FN if it isn't #f and return a lexical token of type TOKEN with
+location information LOC."
+  (cond ((char=? next-char ref-char)
+         (read-char port)
+         (when hook-fn (hook-fn))
+         (make-lexical-token token loc (string next-char)))
+        (else #f)))
+
+(define (is-ocurly->token c loc port)
+  (is-ref-char->token #\{ c 'OCURLY loc port
+                  (lambda ()
+                    (context-stack-push! (make-parse-context
+                                          (context no-layout) #f)))))
+
+(define (is-ccurly->token c loc port)
+  (is-ref-char->token #\} c 'CCURLY loc port (lambda () (context-stack-pop!))))
+
+(define (is-oparen->token c loc port)
+  (is-ref-char->token #\( c 'OPAREN loc port))
+
+(define (is-cparen->token c loc port)
+  (is-ref-char->token #\) c 'CPAREN loc port))
+
+(define (is-not->token c loc port)
+  (is-ref-char->token #\! c 'NOT loc port))
+
+(define (is-version? c) (char-numeric? c))
+
+;; Main lexer functions
+
+(define (lex-single-char port loc)
+  "Process tokens which can be recognised by peeking the next character on
+PORT.  If no token can be recognized return #f.  LOC is the current port
+location."
+  (let* ((c (peek-char port)))
+    (cond ((eof-object? c) (read-char port) '*eoi*)
+          ((is-ocurly->token c loc port))
+          ((is-ccurly->token c loc port))
+          ((is-oparen->token c loc port))
+          ((is-cparen->token c loc port))
+          ((is-not->token c loc port))
+          ((is-version? c) (lex-version loc port))
+          ((is-relation? c) (lex-relation loc port))
+          (else
+           #f))))
+
+(define (lex-word port loc)
+  "Process tokens which can be recognized by reading the next word form PORT.
+LOC is the current port location."
+  (let* ((w (read-delimited " ()\t\n" port 'peek)))
+    (cond ((is-if w) (lex-if loc))
+          ((is-test w port) (lex-test w loc))
+          ((is-and w) (lex-and loc))
+          ((is-or w) (lex-or loc))
+          ((is-id w) (lex-id w loc))
+          (else (unread-string w port) #f))))
+
+(define (lex-line port loc)
+  "Process tokens which can be recognised by reading a line from PORT.  LOC is
+the current port location."
+  (let* ((s (read-delimited "\n{}" port 'peek)))
+    (cond
+     ((is-property s) => (cut lex-property <> loc port))
+     ((is-flag s) => (cut lex-flag <> loc))
+     ((is-src-repo s) => (cut lex-src-repo <> loc))
+     ((is-exec s) => (cut lex-exec <> loc))
+     ((is-test-suite s) => (cut lex-test-suite <> loc))
+     ((is-benchmark s) => (cut lex-benchmark <> loc))
+     ((is-lib s) (lex-lib loc))
+     ((is-else s) (lex-else loc))
+     (else
+      #f))))
+
+(define (lex-token port)
+  (let* ((loc (make-source-location (cabal-file-name) (port-line port)
+                                    (port-column port) -1 -1)))
+    (or (lex-single-char port loc) (lex-word port loc) (lex-line port loc))))
+
+;; Lexer- and error-function generators
+
+(define (errorp)
+  "Generates the lexer error function."
+  (let ((p (current-error-port)))
+    (lambda (message . args)
+      (format p "~a" message)
+      (if (and (pair? args) (lexical-token? (car args)))
+          (let* ((token (car args))
+                 (source (lexical-token-source token))
+                 (line (source-location-line source))
+                 (column (source-location-column source)))
+            (format p "~a " (or (lexical-token-value token)
+                                 (lexical-token-category token)))
+            (when (and (number? line) (number? column))
+              (format p "(at line ~a, column ~a)" (1+ line) column)))
+          (for-each display args))
+      (format p "~%"))))
+
+(define (make-lexer port)
+  "Generate the Cabal lexical analyser reading from PORT."
+  (let ((p port))
+    (lambda ()
+      (let ((bol (lex-white-space p (bol? p))))
+        (check-bol? #f)
+        (if bol (lex-bol p) (lex-token p))))))
+
+(define* (read-cabal #:optional (port (current-input-port))
+                     (file-name #f))
+  "Read a Cabal file from PORT.  FILE-NAME is a string used in error messages.
+If #f use the function 'port-filename' to obtain it."
+  (let ((cabal-parser (make-cabal-parser)))
+    (parameterize ((cabal-file-name
+                    (or file-name (port-filename port) "standard input"))
+                   (current-indentation 0)
+                   (check-bol? #f)
+                   (context-stack (make-stack)))
+      (cabal-parser (make-lexer port) (errorp)))))
+
+;; Part 2:
+;;
+;; Evaluate the S-expression returned by 'read-cabal'.
+
+;; This defines the object and interface that we provide to access the Cabal
+;; file information.  Note that this does not include all the pieces of
+;; information of the Cabal file, but only the ones we currently are
+;; interested in.
+(define-record-type <cabal-package>
+  (make-cabal-package name version license home-page source-repository
+                      synopsis description
+                      executables lib test-suites
+                      flags eval-environment)
+  cabal-package?
+  (name   cabal-package-name)
+  (version cabal-package-version)
+  (license cabal-package-license)
+  (home-page cabal-package-home-page)
+  (source-repository cabal-package-source-repository)
+  (synopsis cabal-package-synopsis)
+  (description cabal-package-description)
+  (executables cabal-package-executables)
+  (lib cabal-package-library) ; 'library' is a Scheme keyword
+  (test-suites cabal-package-test-suites)
+  (flags cabal-package-flags)
+  (eval-environment cabal-package-eval-environment)) ; alist
+
+(set-record-type-printer! <cabal-package>
+                          (lambda (package port)
+                            (format port "#<cabal-package ~a-~a>"
+                                      (cabal-package-name package)
+                                      (cabal-package-version package))))
+
+(define-record-type <cabal-source-repository>
+  (make-cabal-source-repository use-case type location)
+  cabal-source-repository?
+  (use-case cabal-source-repository-use-case)
+  (type cabal-source-repository-type)
+  (location cabal-source-repository-location))
+
+;; We need to be able to distinguish the value of a flag from the Scheme #t
+;; and #f values.
+(define-record-type <cabal-flag>
+  (make-cabal-flag name description default manual)
+  cabal-flag?
+  (name cabal-flag-name)
+  (description cabal-flag-description)
+  (default cabal-flag-default) ; 'true or 'false
+  (manual cabal-flag-manual))  ; 'true or 'false
+
+(set-record-type-printer! <cabal-flag>
+                          (lambda (package port)
+                            (format port "#<cabal-flag ~a default:~a>"
+                                      (cabal-flag-name package)
+                                      (cabal-flag-default package))))
+
+(define-record-type <cabal-dependency>
+  (make-cabal-dependency name version)
+  cabal-dependency?
+  (name cabal-dependency-name)
+  (version cabal-dependency-version))
+
+(define-record-type <cabal-executable>
+  (make-cabal-executable name dependencies)
+  cabal-executable?
+  (name cabal-executable-name)
+  (dependencies cabal-executable-dependencies)) ; list of <cabal-dependency>
+
+(define-record-type <cabal-library>
+  (make-cabal-library dependencies)
+  cabal-library?
+  (dependencies cabal-library-dependencies)) ; list of <cabal-dependency>
+
+(define-record-type <cabal-test-suite>
+  (make-cabal-test-suite name dependencies)
+  cabal-test-suite?
+  (name cabal-test-suite-name)
+  (dependencies cabal-test-suite-dependencies)) ; list of <cabal-dependency>
+
+(define (cabal-flags->alist flag-list)
+    "Retrun an alist associating the flag name to its default value from a
+list of <cabal-flag> objects."
+  (map (lambda (flag) (cons (cabal-flag-name flag) (cabal-flag-default flag)))
+       flag-list))
+
+(define (eval-cabal cabal-sexp env)
+  "Given the CABAL-SEXP produced by 'read-cabal', evaluate all conditionals
+and return a 'cabal-package' object.  The values of all tests can be
+overwritten by specifying the desired value in ENV.  ENV must be an alist.
+The accepted keys are: \"os\", \"arch\", \"impl\" and a name of a flag.  The
+value associated with a flag has to be either \"true\" or \"false\".  The
+value associated with other keys has to conform to the Cabal file format
+definition."
+  (define (os name)
+    (let ((env-os (or (assoc-ref env "os") "linux")))
+      (string-match env-os name)))
+  
+  (define (arch name)
+    (let ((env-arch (or (assoc-ref env "arch") "x86_64")))
+      (string-match env-arch name)))
+
+  (define (comp-name+version haskell)
+    "Extract the compiler name and version from the string HASKELL."
+    (let* ((matcher-fn (make-rx-matcher "([a-zA-Z0-9_]+)-([0-9.]+)"))
+           (name (or (and=> (matcher-fn haskell) (cut match:substring <> 1))
+                     haskell))
+           (version (and=> (matcher-fn haskell) (cut match:substring <> 2))))
+      (values name version)))
+
+  (define (comp-spec-name+op+version spec)
+    "Extract the compiler specification from SPEC.  Return the compiler name,
+the ordering operation and the version."
+    (let* ((with-ver-matcher-fn (make-rx-matcher
+                                 "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *"))
+           (without-ver-matcher-fn (make-rx-matcher "([a-zA-Z0-9_-]+)"))
+           (name (or (and=> (with-ver-matcher-fn spec)
+                            (cut match:substring <> 1))
+                     (match:substring (without-ver-matcher-fn spec) 1)))
+           (operator (and=> (with-ver-matcher-fn spec)
+                            (cut match:substring <> 2)))
+           (version (and=> (with-ver-matcher-fn spec)
+                           (cut match:substring <> 3))))
+      (values name operator version)))
+  
+  (define (impl haskell)
+    (let*-values (((comp-name comp-ver)
+                   (comp-name+version (or (assoc-ref env "impl") "ghc")))
+                  ((spec-name spec-op spec-ver)
+                   (comp-spec-name+op+version haskell)))
+      (if (and spec-ver comp-ver)
+          (eval-string
+           (string-append "(string" spec-op " \"" comp-name "\""
+                          " \"" spec-name "-" spec-ver "\")"))
+          (string-match spec-name comp-name))))
+  
+  (define (cabal-flags)
+    (make-cabal-section cabal-sexp 'flag))
+  
+  (define (flag name)
+    (let ((value (or (assoc-ref env name)
+                     (assoc-ref (cabal-flags->alist (cabal-flags)) name))))
+      (if (eq? value 'false) #f #t)))
+  
+  (define (eval sexp)
+    (match sexp
+      (() '())
+      ;; nested 'if'
+      ((('if predicate true-group false-group) rest ...)
+       (append (if (eval predicate)
+                   (eval true-group)
+                   (eval false-group))
+               (eval rest)))
+      (('if predicate true-group false-group)
+       (if (eval predicate)
+           (eval true-group)
+           (eval false-group)))
+      (('flag name) (flag name))
+      (('os name) (os name))
+      (('arch name) (arch name))
+      (('impl name) (impl name))
+      (('not name) (not (eval name)))
+      ;; 'and' and 'or' aren't functions, thus we can't use apply
+      (('and args ...) (fold (lambda (e s) (and e s)) #t (eval args)))
+      (('or args ...) (fold (lambda (e s) (or e s)) #f (eval args)))
+      ;; no need to evaluate flag parameters
+      (('section 'flag name parameters)
+       (list 'section 'flag name parameters))
+      ;; library does not have a name parameter
+      (('section 'library parameters)
+       (list 'section 'library (eval parameters)))
+      (('section type name parameters)
+       (list 'section type name (eval parameters)))
+      (((? string? name) values)
+       (list name values))
+      ((element rest ...)
+       (cons (eval element) (eval rest)))
+      (_ (raise (condition
+                 (&message (message "Failed to evaluate Cabal file. \
+See the manual for limitations.")))))))
+
+  (define (cabal-evaluated-sexp->package evaluated-sexp)
+    (let* ((name (lookup-join evaluated-sexp "name"))
+           (version (lookup-join evaluated-sexp "version"))
+           (license (lookup-join evaluated-sexp "license"))
+           (home-page (lookup-join evaluated-sexp "homepage"))
+           (home-page-or-hackage
+            (if (string-null? home-page)
+                (string-append "http://hackage.haskell.org/package/" name)
+                home-page))
+           (source-repository (make-cabal-section evaluated-sexp
+                                                  'source-repository))
+           (synopsis (lookup-join evaluated-sexp "synopsis"))
+           (description (lookup-join evaluated-sexp "description"))
+           (executables (make-cabal-section evaluated-sexp 'executable))
+           (lib (make-cabal-section evaluated-sexp 'library))
+           (test-suites (make-cabal-section evaluated-sexp 'test-suite))
+           (flags (make-cabal-section evaluated-sexp 'flag))
+           (eval-environment '()))
+      (make-cabal-package name version license home-page-or-hackage
+                          source-repository synopsis description executables lib
+                          test-suites flags eval-environment)))
+
+  ((compose cabal-evaluated-sexp->package eval) cabal-sexp))
+
+(define (make-cabal-section sexp section-type)
+  "Given an SEXP as produced by 'read-cabal', produce a list of objects
+pertaining to SECTION-TYPE sections.  SECTION-TYPE must be one of:
+'executable, 'flag, 'test-suite, 'source-repository or 'library."
+  (filter-map (cut match <>
+                   (('section (? (cut equal? <> section-type)) name parameters)
+                    (case section-type
+                      ((test-suite) (make-cabal-test-suite
+                                      name (dependencies parameters)))
+                      ((executable) (make-cabal-executable
+                                      name (dependencies parameters)))
+                      ((source-repository) (make-cabal-source-repository
+                                            name
+                                            (lookup-join parameters "type")
+                                            (lookup-join parameters "location")))
+                      ((flag)
+                       (let* ((default (lookup-join parameters "default"))
+                              (default-true-or-false
+                                (if (and default (string-ci=? "false" default))
+                                    'false
+                                    'true))
+                              (description (lookup-join parameters "description"))
+                              (manual (lookup-join parameters "manual"))
+                              (manual-true-or-false
+                               (if (and manual (string-ci=? "true" manual))
+                                   'true
+                                   'false)))
+                         (make-cabal-flag name description
+                                          default-true-or-false
+                                          manual-true-or-false)))
+                      (else #f)))
+                   (('section (? (cut equal? <> section-type) lib) parameters)
+                    (make-cabal-library (dependencies parameters)))
+                   (_ #f))
+              sexp))
+
+(define* (lookup-join key-values-list key #:optional (delimiter " "))
+  "Lookup and joint all values pertaining to keys of value KEY in
+KEY-VALUES-LIST.  The optional DELIMITER is used to specify a delimiter string
+to be added between the values found in different key/value pairs."
+  (string-join 
+   (filter-map (cut match <> 
+                    (((? (lambda(x) (equal? x key))) value)
+                     (string-join value delimiter))
+                    (_ #f))
+               key-values-list)
+   delimiter))
+
+(define dependency-name-version-rx
+  (make-regexp "([a-zA-Z0-9_-]+) *(.*)"))
+
+(define (dependencies key-values-list)
+  "Return a list of 'cabal-dependency' objects for the dependencies found in
+KEY-VALUES-LIST."
+  (let ((deps (string-tokenize (lookup-join key-values-list "build-depends" ",")
+                               (char-set-complement (char-set #\,)))))
+    (map (lambda (d)
+           (let ((rx-result (regexp-exec dependency-name-version-rx d)))
+             (make-cabal-dependency
+              (match:substring rx-result 1)
+              (match:substring rx-result 2))))
+         deps)))
+
+;;; cabal.scm ends here
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 1b27803dba..b5574a8d9f 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -18,28 +18,19 @@
 
 (define-module (guix import hackage)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 regex)
-  #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 receive)
-  #:use-module (ice-9 pretty-print)
   #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-34)
-  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-1)
   #:use-module ((guix download) #:select (download-to-store))
   #:use-module ((guix utils) #:select (package-name->name+version))
   #:use-module (guix import utils)
+  #:use-module (guix import cabal)
   #:use-module (guix store)
   #:use-module (guix hash)
   #:use-module (guix base32)
   #:use-module ((guix utils) #:select (call-with-temporary-output-file))
   #:export (hackage->guix-package))
 
-;; Part 1:
-;;
-;; Functions used to read a Cabal file.
-
 (define ghc-standard-libraries
   ;; List of libraries distributed with ghc (7.8.4). We include GHC itself as
   ;; some packages list it.
@@ -75,588 +66,12 @@
 
 (define package-name-prefix "ghc-")
 
-(define key-value-rx
-  ;; Regular expression matching "key: value"
-  (make-regexp "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$"))
-
-(define sections-rx
-  ;; Regular expression matching a section "head sub-head ..."
-  (make-regexp "([a-zA-Z0-9\\(\\)-]+)"))
-
-(define comment-rx
-  ;; Regexp matching Cabal comment lines.
-  (make-regexp "^ *--"))
-
-(define (has-key? line)
-  "Check if LINE includes a key."
-  (regexp-exec key-value-rx line))
-
-(define (comment-line? line)
-  "Check if LINE is a comment line."
-  (regexp-exec comment-rx line))
-
-(define (line-indentation+rest line)
-  "Returns two results: The number of indentation spaces and the rest of the
-line (without indentation)."
-  (let loop ((line-lst (string->list line))
-             (count 0))
-    ;; Sometimes values are spread over multiple lines and new lines start
-    ;; with a comma ',' with the wrong indentation.  See e.g. haddock-api.
-    (if (or (null? line-lst)
-            (not (or
-                  (eqv? (first line-lst) #\space)
-                  (eqv? (first line-lst) #\,) ; see, e.g., haddock-api.cabal
-                  (eqv? (first line-lst) #\tab))))
-        (values count (list->string line-lst))
-        (loop (cdr line-lst) (+ count 1)))))
-
-(define (multi-line-value lines seed)
-  "Function to read a value split across multiple lines. LINES are the
-remaining input lines to be read. SEED is the value read on the same line as
-the key.  Return two values: A list with values and the remaining lines to be
-processed."
-  (define (multi-line-value-with-min-indent lines seed min-indent)
-    (if (null? lines)
-        (values '() '())
-        (let-values (((current-indent value) (line-indentation+rest (first lines)))
-                     ((next-line-indent next-line-value)
-                      (if (null? (cdr lines))
-                          (values #f "")
-                          (line-indentation+rest (second lines)))))
-          (if (or (not next-line-indent) (< next-line-indent min-indent)
-                  (regexp-exec condition-rx next-line-value))
-              (values (reverse (cons value seed)) (cdr lines))
-              (multi-line-value-with-min-indent (cdr lines) (cons value seed)
-                                                min-indent)))))
-
-  (let-values (((current-indent value) (line-indentation+rest (first lines))))
-    (multi-line-value-with-min-indent lines seed current-indent)))
-
-(define (read-cabal port)
-  "Parses a Cabal file from PORT.  Return a list of list pairs:
-
-(((head1 sub-head1 ... key1) (value))
- ((head2 sub-head2 ... key2) (value2))
- ...).
-
-We try do deduce the Cabal format from the following document:
-https://www.haskell.org/cabal/users-guide/developing-packages.html 
-
-Keys are case-insensitive.  We therefore lowercase them.  Values are
-case-sensitive.  Currently only indentation-structured files are parsed.
-Braces structured files are not handled." ;" <- make emacs happy.
-  (define (read-and-trim-line port)
-    (let ((line (read-line port)))
-      (if (string? line)
-          (string-trim-both line #\return)
-          line)))
-
-  (define (strip-insignificant-lines port)
-    (let loop ((line (read-and-trim-line port))
-               (result '()))
-      (cond
-       ((eof-object? line)
-        (reverse result))
-       ((or (string-null? line) (comment-line? line))
-        (loop (read-and-trim-line port) result))
-       (else
-        (loop (read-and-trim-line port) (cons line result))))))
-
-  (let loop
-      ((lines (strip-insignificant-lines port))
-       (indents  '()) ; only includes indents at start of section heads.
-       (sections '())
-       (result '()))
-    (let-values
-        (((current-indent line)
-          (if (null? lines)
-              (values 0 "")
-              (line-indentation+rest (first lines))))
-         ((next-line-indent next-line)
-          (if (or (null? lines) (null? (cdr lines)))
-              (values 0 "")
-              (line-indentation+rest (second lines)))))
-      (if (null? lines)
-          (reverse result)
-          (let ((rx-result (has-key? line)))
-            (cond
-             (rx-result
-              (let ((key (string-downcase (match:substring rx-result 1)))
-                    (value (match:substring rx-result 2)))
-                (cond
-                 ;; Simple single line "key: value".
-                 ((= next-line-indent current-indent)
-                  (loop (cdr lines) indents sections
-                        (cons
-                         (list (reverse (cons key sections)) (list value))
-                         result)))
-                 ;; Multi line "key: value\n value cont...".
-                 ((> next-line-indent current-indent)
-                  (let*-values (((value-lst lines)
-                                 (multi-line-value (cdr lines)
-                                                   (if (string-null? value)
-                                                       '()
-                                                       `(,value)))))
-                    ;; multi-line-value returns to the first line after the
-                    ;; multi-value.
-                    (loop lines indents sections
-                          (cons
-                           (list (reverse (cons key sections)) value-lst)
-                           result))))
-                 ;; Section ended.
-                 (else
-                  ;; Indentation is reduced. Check by how many levels.
-                  (let* ((idx (and=> (list-index
-                                      (lambda (x) (= next-line-indent x))
-                                      indents)
-                                     (cut + <>
-                                            (if (has-key? next-line) 1 0))))
-                         (sec
-                          (if idx
-                              (drop sections idx)
-                              (raise
-                               (condition
-                                (&message
-                                 (message "unable to parse Cabal file"))))))
-                         (ind (drop indents idx)))
-                    (loop (cdr lines) ind sec
-                          (cons 
-                           (list (reverse (cons key sections)) (list value))
-                           result)))))))
-             ;; Start of a new section.
-             ((or (null? indents)
-                  (> current-indent (first indents)))
-              (loop (cdr lines) (cons current-indent indents)
-                    (cons (string-downcase line) sections) result))
-             (else
-              (loop (cdr lines) indents
-                    (cons (string-downcase line) (cdr sections))
-                    result))))))))
-
-(define condition-rx
-  ;; Regexp for conditionals.
-  (make-regexp "^if +(.*)$"))
-
-(define (split-section section)
-  "Split SECTION in individual words with exception for the predicate of an
-'if' conditional."
-  (let ((rx-result (regexp-exec condition-rx section)))
-    (if rx-result
-        `("if" ,(match:substring rx-result 1))
-        (map match:substring (list-matches sections-rx section)))))
-
-(define (join-sections sec1 sec2)
-  (fold-right cons sec2 sec1))
-
-(define (pre-process-keys key)
-  (match key
-    (() '())
-    ((sec1 rest ...)
-     (join-sections (split-section sec1) (pre-process-keys rest)))))
-
-(define (pre-process-entry-keys entry)
-  (match entry
-    ((key value)
-     (list (pre-process-keys key) value))
-    (() '())))
-
-(define (pre-process-entries-keys entries)
-  "ENTRIES is a list of list pairs, a keys list and a valules list, as
-produced by 'read-cabal'.  Split each element of the keys list into individual
-words.  This pre-processing is used to read flags."
-  (match entries
-    ((entry rest ...)
-     (cons (pre-process-entry-keys entry)
-           (pre-process-entries-keys rest)))
-    (()
-     '())))
-
-(define (get-flags pre-processed-entries)
-  "PRE-PROCESSED-ENTRIES is a list of list pairs, a keys list and a values
-list, as produced by 'read-cabal' and pre-processed by
-'pre-process-entries-keys'.  Return a list of pairs with the name of flags and
-their default value (one of \"False\" or \"True\") as specified in the Cabal file:
-
-((\"flag1-name\" . \"False-or-True\") ...)." ;" <- make emacs happy
-  (match pre-processed-entries
-    (() '())
-    (((("flag" flag-name "default") (flag-val)) rest ...)
-     (cons (cons flag-name  flag-val)
-           (get-flags rest)))
-    ((entry rest ... )
-     (get-flags rest))
-    (_ #f)))
-
-;; Part 2:
-;;
-;; Functions to read information from the Cabal object created by 'read-cabal'
-;; and convert Cabal format dependencies conditionals into equivalent
-;; S-expressions.
-
-(define tests-rx
-  ;; Cabal test keywords
-  (make-regexp "(os|arch|flag|impl) *\\(([ a-zA-Z0-9_.<>=-]+)\\)"))
-
-(define parens-rx
-  ;; Parentheses within conditions
-  (make-regexp "\\((.+)\\)"))
-
-(define or-rx
-  ;; OR operator in conditions
-  (make-regexp " +\\|\\| +"))
-
-(define and-rx
-  ;; AND operator in conditions
-  (make-regexp " +&& +"))
-
-(define not-rx
-  ;; NOT operator in conditions
-  (make-regexp "^!.+"))
-
-(define (bi-op-args str match-lst)
-  "Return a list with the arguments of (logic) bianry operators.  MATCH-LST
-is the result of 'list-match' against a binary operator regexp on STR."
-  (let ((operators (length match-lst)))
-    (map (lambda (from to)
-           (substring str from to))
-         (cons 0 (map match:end match-lst))
-         (append (map match:start match-lst) (list (string-length str))))))
-
-(define (bi-op->sexp-like bi-op args)
-  "BI-OP is a string with the name of a Scheme operator which in a Cabal file
-is represented by a binary operator.  ARGS are the arguments of said operator.
-Return a string representing an S-expression of the operator applied to its
-arguments."
-  (if (= (length args) 1)
-      (first args)
-      (string-append "(" bi-op
-                     (fold (lambda (arg seed) (string-append seed " " arg))
-                           "" args) ")")))
-
-(define (not->sexp-like arg)
-  "If the string ARG is prefixed by a Cabal negation operator, convert it to
-an equivalent Scheme S-expression string."
-  (if (regexp-exec not-rx arg)
-      (string-append "(not "
-                     (substring arg 1 (string-length arg))
-                     ")")
-      arg))
-
-(define (parens-less-cond->sexp-like conditional)
-  "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme
-syntax.  This procedure accepts only simple conditionals without parentheses."
-  ;; The outher operation is the one with the lowest priority: OR
-  (bi-op->sexp-like
-   "or"
-   ;; each OR argument may be an AND operation
-   (map (lambda (or-arg)
-          (let ((m-lst (list-matches and-rx or-arg)))
-            ;; is there an AND operation?
-            (if (> (length m-lst) 0)
-                (bi-op->sexp-like
-                 "and"
-                 ;; expand NOT operators when there are ANDs
-                 (map not->sexp-like (bi-op-args or-arg m-lst)))
-                ;; ... and when there aren't.
-                (not->sexp-like or-arg))))
-        ;; list of OR arguments
-        (bi-op-args conditional (list-matches or-rx conditional)))))
-
-(define test-keyword-ornament "__")
-
-(define (conditional->sexp-like conditional)
-  "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme
-syntax."
-  ;; First we substitute TEST-KEYWORD-ORNAMENT for parentheses around tests
-  ;; keywords so that parentheses are only used to set precedences. This
-  ;; substantially simplify parsing.
-  (let ((conditional
-         (regexp-substitute/global #f tests-rx conditional
-                                   'pre 1 test-keyword-ornament 2
-                                   test-keyword-ornament 'post)))
-    (let loop ((sub-cond conditional))
-      (let ((rx-result (regexp-exec parens-rx sub-cond)))
-        (cond
-         (rx-result
-          (parens-less-cond->sexp-like
-           (string-append
-            (match:prefix rx-result)
-            (loop (match:substring rx-result 1))
-            (match:suffix rx-result))))
-         (else
-          (parens-less-cond->sexp-like sub-cond)))))))
-
-(define (eval-flags sexp-like-cond flags)
-  "SEXP-LIKE-COND is a string representing an S-expression conditional.  FLAGS
-is a list of flag name and value pairs as produced by 'get-flags'.  Substitute
-\"#t\" or \"#f\" according to the value of flags. (Default to \"True\")."
-  (fold-right
-   (lambda (flag sexp)
-     (match flag
-       ((name . value)
-        (let ((rx (make-regexp
-                   (string-append "flag" test-keyword-ornament name
-                                  test-keyword-ornament))))
-          (regexp-substitute/global
-           #f rx sexp
-           'pre (if (string-ci= value "False") "#f" "#t") 'post)))
-       (_ sexp)))
-   sexp-like-cond
-   (cons '("[a-zA-Z0-9_-]+" . "True") flags)))
-
-(define (eval-tests->sexp sexp-like-cond)
-  "In the string SEXP-LIKE-COND substitute test keywords \"os(...)\" and
-\"arch(...)\" with equivalent Scheme checks.  Retrun an S-expression."
-  (with-input-from-string 
-      (fold-right
-       (lambda (test sexp)
-         (match test
-           ((type pre-match post-match)
-            (let ((rx (make-regexp
-                       (string-append type test-keyword-ornament "(\\w+)"
-                                      test-keyword-ornament))))
-              (regexp-substitute/global
-               #f rx sexp
-               'pre pre-match 2 post-match 'post)))
-           (_ sexp)))
-       sexp-like-cond
-       ;; (%current-system) returns, e.g., "x86_64-linux" or "i686-linux".
-       '(("(os|arch)" "(string-match \"" "\" (%current-system))")))
-    read))
-
-(define (eval-impl sexp-like-cond)
-  "Check for the Cabal test \"impl(...)\" in the string SEXP-LIKE-COND.
-Assume the module declaring the generated package includes a local variable
-called \"haskell-implementation\" with a string value of the form NAME-VERSION
-against which we compare."
-  (with-output-to-string
-    (lambda ()
-      (write
-       (with-input-from-string 
-           (fold-right
-            (lambda (test sexp)
-              (match test
-                ((pre-match post-match)
-                 (let ((rx-with-version
-                        (make-regexp
-                         (string-append
-                          "impl" test-keyword-ornament
-                          "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *"
-                          test-keyword-ornament)))
-                       (rx-without-version
-                        (make-regexp
-                         (string-append "impl" test-keyword-ornament "(\\w+)"
-                                        test-keyword-ornament))))
-                   (if (regexp-exec rx-with-version sexp)
-                       (regexp-substitute/global
-                        #f rx-with-version sexp
-                        'pre pre-match 2 " " post-match " \"" 1 "-" 3 "\")" 'post)
-                       (regexp-substitute/global
-                        #f rx-without-version sexp
-                        'pre pre-match "-match \"" 1 "\" " post-match ")" 'post))))
-                (_ sexp)))
-            sexp-like-cond
-            '(("(string" "haskell-implementation")))
-         read)))))
-
-(define (eval-cabal-keywords sexp-like-cond flags)
-  ((compose eval-tests->sexp eval-impl (cut eval-flags <> flags))
-   sexp-like-cond))
-
-(define (key->values meta key)
-  "META is the representation of a Cabal file as produced by 'read-cabal'.
-Return the list of values associated with a specific KEY (a string)."
-  (match meta
-    (() '())
-    (((((? (lambda(x) (equal? x key)))) v) r ...)
-     v)
-    (((k v) r ...)
-     (key->values (cdr meta) key))
-    (_ "key Not fount")))
-
-(define (key-start-end->entries meta key-start-rx key-end-rx)
-  "META is the representation of a Cabal file as produced by 'read-cabal'.
-Return all entries whose keys list starts with KEY-START and ends with
-KEY-END."
-  (let ((pred
-         (lambda (x)
-           (and (regexp-exec key-start-rx (first x))
-                (regexp-exec key-end-rx (last x))))))
-           ;; (equal? (list key-start key-end) (list (first x) (last x))))))
-    (match meta
-      (() '())
-      ((((? pred k) v) r ...)
-       (cons `(,k ,v)
-             (key-start-end->entries (cdr meta) key-start-rx key-end-rx)))
-      (((k v) r ...)
-       (key-start-end->entries (cdr meta) key-start-rx key-end-rx))
-      (_ "key Not fount"))))
-
-(define else-rx
-  (make-regexp "^else$"))
-
-(define (count-if-else rx-result-ls)
-  (apply + (map (lambda (m) (if m 1 0)) rx-result-ls)))
-
-(define (analyze-entry-cond entry)
-  (let* ((keys (first entry))
-         (vals (second entry))
-         (rx-cond-result
-          (map (cut regexp-exec condition-rx <>) keys))
-         (rx-else-result
-          (map (cut regexp-exec else-rx <>) keys))
-         (cond-no (count-if-else rx-cond-result))
-         (else-no (count-if-else rx-else-result))
-         (cond-idx (list-index (lambda (rx) (if rx #t #f)) rx-cond-result))
-         (else-idx (list-index (lambda (rx) (if rx #t #f)) rx-else-result))
-         (key-cond
-              (cond
-               ((or (and cond-idx else-idx (< cond-idx else-idx))
-                    (and cond-idx (not else-idx)))
-                (match:substring
-                 (receive (head tail)
-                     (split-at rx-cond-result cond-idx) (first tail))))
-               ((or (and cond-idx else-idx (> cond-idx else-idx))
-                    (and (not cond-idx) else-idx))
-                (match:substring
-                 (receive (head tail)
-                     (split-at rx-else-result else-idx) (first tail))))
-               (else
-                ""))))
-    (values keys vals rx-cond-result
-            rx-else-result cond-no else-no key-cond)))
-
-(define (remove-cond entry cond)
-  (match entry
-    ((k v)
-     (list (cdr (member cond k)) v))))
-
-(define (group-and-reduce-level entries group group-cond)
-  (let loop
-      ((true-group group)
-       (false-group '())
-       (entries entries))
-    (if (null? entries)
-        (values (reverse true-group) (reverse false-group) entries)
-        (let*-values (((entry) (first entries))
-                      ((keys vals rx-cond-result rx-else-result
-                             cond-no else-no key-cond)
-                       (analyze-entry-cond entry)))
-          (cond
-           ((and (>= (+ cond-no else-no) 1) (string= group-cond key-cond))
-            (loop (cons (remove-cond entry group-cond) true-group) false-group
-                  (cdr entries)))
-           ((and (>= (+ cond-no else-no) 1) (string= key-cond "else"))
-            (loop true-group (cons (remove-cond entry "else") false-group)
-                  (cdr entries)))
-           (else
-            (values (reverse true-group) (reverse false-group) entries)))))))
-
-(define dependencies-rx
-  (make-regexp "([a-zA-Z0-9_-]+) *[^,]*,?"))
-
 (define (hackage-name->package-name name)
+  "Given the NAME of a Cabal package, return the corresponding Guix name."
   (if (string-prefix? package-name-prefix name)
       (string-downcase name)
       (string-append package-name-prefix (string-downcase name))))
 
-(define (split-and-filter-dependencies ls names-to-filter)
-  "Split the comma separated list of dependencies LS coming from the Cabal
-file, filter packages included in NAMES-TO-FILTER and return a list with
-inputs suitable for the Guix package.  Currently the version information is
-discarded."
-  (define (split-at-comma-and-filter d)
-    (fold
-     (lambda (m seed)
-       (let* ((name (string-downcase (match:substring m 1)))
-              (pkg-name (hackage-name->package-name name)))
-         (if (member name names-to-filter)
-             seed
-             (cons (list pkg-name (list 'unquote (string->symbol pkg-name)))
-                   seed))))
-     '()
-     (list-matches dependencies-rx d)))
-    
-  (fold (lambda (d p) (append (split-at-comma-and-filter d) p)) '()  ls))
-
-(define* (dependencies-cond->sexp meta #:key (include-test-dependencies? #t))
-  "META is the representation of a Cabal file as produced by 'read-cabal'.
-Return an S-expression containing the list of dependencies as expected by the
-'inputs' field of a package.  The generated S-expressions may include
-conditionals as defined in the cabal file.  During this process we discard the
-version information of the packages."
-  (define (take-dependencies meta)
-    (let ((key-start-exe (make-regexp "executable"))
-          (key-start-lib (make-regexp "library"))
-          (key-start-tests (make-regexp "test-suite"))
-          (key-end (make-regexp "build-depends")))
-      (append
-       (key-start-end->entries meta key-start-exe key-end)
-       (key-start-end->entries meta key-start-lib key-end)
-       (if include-test-dependencies?
-           (key-start-end->entries meta key-start-tests key-end)
-           '()))))
-
-  (let ((flags (get-flags (pre-process-entries-keys meta)))
-        (augmented-ghc-std-libs (append (key->values meta "name")
-                                        ghc-standard-libraries)))
-    (delete-duplicates
-     (let loop ((entries (take-dependencies meta))
-                (result '()))
-       (if (null? entries)
-           (reverse result)
-           (let*-values (((entry) (first entries))
-                         ((keys vals rx-cond-result rx-else-result
-                                cond-no else-no key-cond)
-                          (analyze-entry-cond entry)))
-             (cond
-              ((= (+ cond-no else-no) 0)
-               (loop (cdr entries)
-                     (append
-                      (split-and-filter-dependencies vals
-                                                     augmented-ghc-std-libs)
-                      result)))
-              (else
-               (let-values (((true-group false-group entries)
-                             (group-and-reduce-level entries '()
-                                                     key-cond))
-                            ((cond-final) (eval-cabal-keywords
-                                           (conditional->sexp-like
-                                            (last (split-section key-cond)))
-                                           flags)))
-                 (loop entries
-                       (cond
-                        ((or (eq? cond-final #t) (equal? cond-final '(not #f)))
-                         (append (loop true-group '()) result))
-                        ((or (eq? cond-final #f) (equal? cond-final '(not #t)))
-                         (append (loop false-group '()) result))
-                        (else
-                         (let ((true-group-result (loop true-group '()))
-                               (false-group-result (loop false-group '())))
-                           (cond
-                            ((and (null? true-group-result)
-                                  (null? false-group-result))
-                             result)
-                            ((null? false-group-result)
-                             (cons `(unquote-splicing
-                                     (when ,cond-final ,true-group-result))
-                                   result))
-                            ((null? true-group-result)
-                             (cons `(unquote-splicing
-                                     (unless ,cond-final ,false-group-result))
-                                   result))
-                            (else
-                             (cons `(unquote-splicing
-                                     (if ,cond-final
-                                         ,true-group-result
-                                         ,false-group-result))
-                                   result))))))))))))))))
-
-;; Part 3:
-;;
-;; Retrive the desired package and its Cabal file from
-;; http://hackage.haskell.org and construct the Guix package S-expression.
-
 (define (hackage-fetch name-version)
   "Return the Cabal file for the package NAME-VERSION, or #f on failure.  If
 the version part is omitted from the package name, then return the latest
@@ -696,33 +111,63 @@ version."
    ((lst ...) `(list ,@(map string->license lst)))
    (_ #f)))
 
-(define* (hackage-module->sexp meta #:key (include-test-dependencies? #t))
-  "Return the `package' S-expression for a Cabal package.  META is the
+
+(define (cabal-dependencies->names cabal include-test-dependencies?)
+  "Return the list of dependencies names from the CABAL package object.  If
+INCLUDE-TEST-DEPENDENCIES? is #f, do not include dependencies required by test
+suites."
+  (let* ((lib (cabal-package-library cabal))
+         (lib-deps (if (pair? lib)
+                       (map cabal-dependency-name
+                            (append-map cabal-library-dependencies lib))
+                       '()))
+         (exe (cabal-package-executables cabal))
+         (exe-deps (if (pair? exe)
+                       (map cabal-dependency-name
+                            (append-map cabal-executable-dependencies exe))
+                       '()))
+         (ts (cabal-package-test-suites cabal))
+         (ts-deps (if (pair? ts)
+                       (map cabal-dependency-name
+                            (append-map cabal-test-suite-dependencies ts))
+                       '())))
+    (if include-test-dependencies?
+        (delete-duplicates (append lib-deps exe-deps ts-deps))
+        (delete-duplicates (append lib-deps exe-deps)))))
+
+(define (filter-dependencies dependencies own-name)
+  "Filter the dependencies included with the GHC compiler from DEPENDENCIES, a
+list with the names of dependencies.  OWN-NAME is the name of the Cabal
+package being processed and is used to filter references to itself."
+  (filter (lambda (d) (not (member (string-downcase d)
+                                   (cons own-name ghc-standard-libraries))))
+          dependencies))
+
+(define* (hackage-module->sexp cabal #:key (include-test-dependencies? #t))
+  "Return the `package' S-expression for a Cabal package.  CABAL is the
 representation of a Cabal file as produced by 'read-cabal'."
 
   (define name
-    (first (key->values meta "name")))
+    (cabal-package-name cabal))
 
   (define version
-    (first (key->values meta "version")))
-  
-  (define description
-    (let*-values (((description) (key->values meta "description"))
-                  ((lines last)
-                   (split-at description (- (length description) 1))))
-      (fold-right (lambda (line seed) (string-append line "\n" seed))
-                  (first last) lines)))
+    (cabal-package-version cabal))
   
   (define source-url
     (string-append "http://hackage.haskell.org/package/" name
                    "/" name "-" version ".tar.gz"))
 
-  ;; Several packages do not have an official home-page other than on Hackage.
-  (define home-page
-    (let ((home-page-entry (key->values meta "homepage")))
-      (if (null? home-page-entry)
-          (string-append "http://hackage.haskell.org/package/" name)
-          (first home-page-entry))))
+  (define dependencies
+    (let ((names
+           (map hackage-name->package-name
+                ((compose (cut filter-dependencies <>
+                               (cabal-package-name cabal))
+                          (cut cabal-dependencies->names <>
+                               include-test-dependencies?))
+                 cabal))))
+      (map (lambda (name)
+             (list name (list 'unquote (string->symbol name))))
+           names)))
   
   (define (maybe-inputs input-type inputs)
     (match inputs
@@ -732,6 +177,11 @@ representation of a Cabal file as produced by 'read-cabal'."
        (list (list input-type
                    (list 'quasiquote inputs))))))
   
+  (define (maybe-arguments)
+    (if (not include-test-dependencies?)
+        '((arguments `(#:tests? #f)))
+        '()))
+
   (let ((tarball (with-store store
                    (download-to-store store source-url))))
     `(package
@@ -746,22 +196,33 @@ representation of a Cabal file as produced by 'read-cabal'."
                         (bytevector->nix-base32-string (file-sha256 tarball))
                         "failed to download tar archive")))))
        (build-system haskell-build-system)
-       ,@(maybe-inputs 'inputs
-                       (dependencies-cond->sexp meta
-                                                #:include-test-dependencies?
-                                                include-test-dependencies?))
-       (home-page ,home-page)
-       (synopsis ,@(key->values meta "synopsis"))
-       (description ,description)
-       (license ,(string->license (key->values meta "license"))))))
-
-(define* (hackage->guix-package module-name
-                                #:key (include-test-dependencies? #t))
-  "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, and return
-the `package' S-expression corresponding to that package, or #f on failure."
-  (let ((module-meta (hackage-fetch module-name)))
-    (and=> module-meta (cut hackage-module->sexp <>
-                            #:include-test-dependencies?
-                            include-test-dependencies?))))
+       ,@(maybe-inputs 'inputs dependencies)
+       ,@(maybe-arguments)
+       (home-page ,(cabal-package-home-page cabal))
+       (synopsis ,(cabal-package-synopsis cabal))
+       (description ,(cabal-package-description cabal))
+       (license ,(string->license (cabal-package-license cabal))))))
+
+(define* (hackage->guix-package package-name #:key
+                                (include-test-dependencies? #t)
+                                (port #f)
+                                (cabal-environment '()))
+  "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the
+called with keyword parameter PORT, from PORT.  Return the `package'
+S-expression corresponding to that package, or #f on failure.
+CABAL-ENVIRONMENT is an alist defining the environment in which the Cabal
+conditionals are evaluated.  The accepted keys are: \"os\", \"arch\", \"impl\"
+and the name of a flag.  The value associated with a flag has to be either the
+symbol 'true' or 'false'.  The value associated with other keys has to conform
+to the Cabal file format definition.  The default value associated with the
+keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\"
+respectively."
+  (let ((cabal-meta (if port
+                        (read-cabal port)
+                        (hackage-fetch package-name))))
+    (and=> cabal-meta (compose (cut hackage-module->sexp <>
+                                    #:include-test-dependencies? 
+                                    include-test-dependencies?)
+                               (cut eval-cabal <> cabal-environment)))))
 
 ;;; cabal.scm ends here