Re: hackage importer

[Federico Beffa <beffa@ieee.org>]

[-- Attachment #1: Type: text/plain, Size: 2504 bytes --]

On Tue, Mar 31, 2015 at 3:33 PM, Ludovic Courtès <ludo@gnu.org> wrote:
> Nice.  TABs and odd indentation probably make good additional test cases
> to have in tests/cabal.scm.

I've added these test cases as suggested.

> I think it’s a matter of separating concerns.  In my mind there are
> three distinct layers:
>
>   1. Cabal parsing (what I call ‘read-cabal’, because it’s the
>      equivalent of ‘read’);
>
>   2. Cabal evaluation/instantiation for a certain set of flags, OS,
>      etc. (what I call ‘eval-cabal’ because it’s the equivalent of
>      ‘eval’);
>
>   3. Conversion of Cabal packages of Guix package sexps.
>
> My concern was about making sure these three phases were clearly visible
> in the code.  Tu put it differently, #1 and #2 would conceptually be
> part of a Cabal parsing/evaluation library, while #3 would be the only
> Guix-specific part.

OK, now I see what you had in mind. Thanks for the explanation!

My intention wasn't to make an "universal" Cabal parser for two reasons:
(i) I've not found any full, formal description of the file format. I
could in principle deduce it from the Haskell code, but I'm just
starting to learn Haskell.
(ii) I don't see any use of Cabal files in the Scheme world, but maybe
I'm just blind :-)

For these reasons my target was to understand the minimum necessary to
produce a Guix package.  In spite of this, I think, I ended up
handling most of it.

What's still missing is parsing of block structured (with braces) files.

> Anyway, I’ve probably used enough of your time by now.  :-)
> If this discussion gives you ideas on how to structure the code, that is
> fine, but otherwise we can probably go with the architecture you
> propose.
>
> How does that sound?

I think that restructuring the code as you suggest requires quite a
bit of effort. At this point in time I'm not ready to invest the
required time. If one day I will decide to work on improving the code
to make it handle block structured files, that may be the right moment
to reorganize it.

Please find attached updated patches with added documentation, two
more tests, and an option to disable the inclusion of dependencies
only requited by the test-suite of the package.
'read-cabal' now takes a port and 'strip-cabal' was renamed as
suggested and made local to the former. If parsing fails now an
exception of type '&message' is raised with a meaningful message.

Regards,
Fede

[-- Attachment #2: 0001-import-Add-hackage-importer.patch --]
[-- Type: text/x-diff, Size: 6784 bytes --]

From 633bfb5af57f707dea12ab747133182d085951ff Mon Sep 17 00:00:00 2001
From: Federico Beffa <beffa@fbengineering.ch>
Date: Sat, 7 Mar 2015 17:23:14 +0100
Subject: [PATCH 01/29] import: Add hackage importer.

* guix/scripts/import.scm (importers): Add hackage.
* guix/scripts/import/hackage.scm: New file.
* po/guix/POTFILES.in: Add guix/scripts/import.scm.
* doc/guix.texi: Add section on 'hackage' importer.
---
 doc/guix.texi                   |  29 +++++++++++
 guix/scripts/import.scm         |   2 +-
 guix/scripts/import/hackage.scm | 106 ++++++++++++++++++++++++++++++++++++++++
 po/guix/POTFILES.in             |   1 +
 4 files changed, 137 insertions(+), 1 deletion(-)
 create mode 100644 guix/scripts/import/hackage.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index 549da80..8c90b2d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3140,6 +3140,35 @@ bound to the @code{libreoffice} top-level attribute):
 @example
 guix import nix ~/path/to/nixpkgs libreoffice
 @end example
+
+@item hackage
+@cindex hackage
+Import meta-data from Haskell community's central package archive
+@uref{https://hackage.haskell.org/, Hackage}.  Information is taken from
+Cabal files and includes all the relevant information, including package
+dependencies.
+
+Specific command-line options are:
+
+@table @code
+@item --no-test-dependencies
+@itemx -t
+Do not include dependencies only required to run the test suite.
+@end table
+
+The command below imports meta-data for latest version of the
+@code{HTTP} Haskell package without including test dependencies:
+
+@example
+guix import hackage -t HTTP
+@end example
+
+A specific package version may optionally be specified by following the
+package name by a hyphen and a version number as in the following example:
+
+@example
+guix import hackage mtl-2.1.3.1
+@end example
 @end table
 
 The structure of the @command{guix import} code is modular.  It would be
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 7e75c10..06b4c17 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -73,7 +73,7 @@ rather than \\n."
 ;;; Entry point.
 ;;;
 
-(define importers '("gnu" "nix" "pypi" "cpan"))
+(define importers '("gnu" "nix" "pypi" "cpan" "hackage"))
 
 (define (resolve-importer name)
   (let ((module (resolve-interface
diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm
new file mode 100644
index 0000000..f7c18cd
--- /dev/null
+++ b/guix/scripts/import/hackage.scm
@@ -0,0 +1,106 @@
+;;; 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 scripts import hackage)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix import hackage)
+  #:use-module (guix scripts import)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:export (guix-import-hackage))
+
+\f
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+  '((include-test-dependencies? . #t)))
+
+(define (show-help)
+  (display (_ "Usage: guix import hackage PACKAGE-NAME
+Import and convert the Hackage package for PACKAGE-NAME.  If PACKAGE-NAME
+includes a suffix constituted by a dash followed by a numerical version (as
+used with Guix packages), then a definition for the specified version of the
+package will be generated.  If no version suffix is pecified, then the
+generated package definition will correspond to the latest available
+version.\n"))
+  (display (_ "
+  -h, --help                   display this help and exit"))
+  (display (_ "
+  -t, --no-test-dependencies   don't include test only dependencies"))
+  (display (_ "
+  -V, --version                display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specification of the command-line options.
+  (cons* (option '(#\h "help") #f #f
+                 (lambda args
+                   (show-help)
+                   (exit 0)))
+         (option '(#\V "version") #f #f
+                 (lambda args
+                   (show-version-and-exit "guix import hackage")))
+         (option '(#\t "no-test-dependencies") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'include-test-dependencies? #f
+                               (alist-delete 'include-test-dependencies?
+                                             result))))
+         %standard-import-options))
+
+\f
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-hackage . args)
+  (define (parse-options)
+    ;; Return the alist of option values.
+    (args-fold* args %options
+                (lambda (opt name arg result)
+                  (leave (_ "~A: unrecognized option~%") name))
+                (lambda (arg result)
+                  (alist-cons 'argument arg result))
+                %default-options))
+
+  (let* ((opts (parse-options))
+         (args (filter-map (match-lambda
+                            (('argument . value)
+                             value)
+                            (_ #f))
+                           (reverse opts))))
+    (match args
+      ((package-name)
+       (let ((sexp (hackage->guix-package
+                    package-name
+                    #:include-test-dependencies?
+                    (assoc-ref opts 'include-test-dependencies?))))
+         (unless sexp
+           (leave (_ "failed to download cabal file for package '~a'~%")
+                  package-name))
+         sexp))
+      (()
+       (leave (_ "too few arguments~%")))
+      ((many ...)
+       (leave (_ "too many arguments~%"))))))
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 619f6f9..4b79385 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -8,6 +8,7 @@ guix/scripts/download.scm
 guix/scripts/package.scm
 guix/scripts/gc.scm
 guix/scripts/hash.scm
+guix/scripts/import.scm
 guix/scripts/pull.scm
 guix/scripts/substitute-binary.scm
 guix/scripts/authenticate.scm
-- 
2.2.1


[-- Attachment #3: 0002-import-Add-hackage-importer.patch --]
[-- Type: text/x-diff, Size: 35348 bytes --]

From efb8a09ce3aee85ef73206be2957ef6c4e3360a2 Mon Sep 17 00:00:00 2001
From: Federico Beffa <beffa@fbengineering.ch>
Date: Sun, 8 Mar 2015 07:48:38 +0100
Subject: [PATCH 02/29] import: Add hackage importer.

* guix/import/hackage.scm: New file.
* tests/hackage.scm: New file.
---
 guix/import/hackage.scm | 767 ++++++++++++++++++++++++++++++++++++++++++++++++
 tests/hackage.scm       | 134 +++++++++
 2 files changed, 901 insertions(+)
 create mode 100644 guix/import/hackage.scm
 create mode 100644 tests/hackage.scm

diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
new file mode 100644
index 0000000..1b27803
--- /dev/null
+++ b/guix/import/hackage.scm
@@ -0,0 +1,767 @@
+;;; 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 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 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.
+  '("ghc"
+    "haskell98"
+    "hoopl"
+    "base"
+    "transformers"
+    "deepseq"
+    "array"
+    "binary"
+    "bytestring"
+    "containers"
+    "time"
+    "cabal"
+    "bin-package-db"
+    "ghc-prim"
+    "integer-gmp"
+    "integer-simple"
+    "win32"
+    "template-haskell"
+    "process"
+    "haskeline"
+    "terminfo"
+    "directory"
+    "filepath"
+    "old-locale"
+    "unix"
+    "old-time"
+    "pretty"
+    "xhtml"
+    "hpc"))
+
+(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)
+  (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
+version."
+  (let*-values (((name version) (package-name->name+version name-version))
+                ((url)
+                 (if version
+                     (string-append "http://hackage.haskell.org/package/"
+                                    name "-" version "/" name ".cabal")
+                     (string-append "http://hackage.haskell.org/package/"
+                                    name "/" name ".cabal"))))
+    (call-with-temporary-output-file
+     (lambda (temp port)
+       (and (url-fetch url temp)
+            (call-with-input-file temp read-cabal))))))
+
+(define string->license
+  ;; List of valid values from
+  ;; https://www.haskell.org
+  ;; /cabal/release/cabal-latest/doc/API/Cabal/Distribution-License.html.
+  (match-lambda
+   ("GPL-2" 'gpl2)
+   ("GPL-3" 'gpl3)
+   ("GPL" "'gpl??")
+   ("AGPL-3" 'agpl3)
+   ("AGPL" "'agpl??")
+   ("LGPL-2.1" 'lgpl2.1)
+   ("LGPL-3" 'lgpl3)
+   ("LGPL" "'lgpl??")
+   ("BSD2" 'bsd-2)
+   ("BSD3" 'bsd-3)
+   ("MIT" 'expat)
+   ("ISC" 'isc)
+   ("MPL" 'mpl2.0)
+   ("Apache-2.0" 'asl2.0)
+   ((x) (string->license x))
+   ((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
+representation of a Cabal file as produced by 'read-cabal'."
+
+  (define name
+    (first (key->values meta "name")))
+
+  (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)))
+  
+  (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 (maybe-inputs input-type inputs)
+    (match inputs
+      (()
+       '())
+      ((inputs ...)
+       (list (list input-type
+                   (list 'quasiquote inputs))))))
+  
+  (let ((tarball (with-store store
+                   (download-to-store store source-url))))
+    `(package
+       (name ,(hackage-name->package-name name))
+       (version ,version)
+       (source (origin
+                 (method url-fetch)
+                 (uri (string-append ,@(factorize-uri source-url version)))
+                 (sha256
+                  (base32
+                   ,(if tarball
+                        (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?))))
+
+;;; cabal.scm ends here
diff --git a/tests/hackage.scm b/tests/hackage.scm
new file mode 100644
index 0000000..23b854c
--- /dev/null
+++ b/tests/hackage.scm
@@ -0,0 +1,134 @@
+;;; 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 (test-hackage)
+  #:use-module (guix import hackage)
+  #:use-module (guix tests)
+  #:use-module (srfi srfi-64)
+  #:use-module (ice-9 match))
+
+(define test-cabal-1
+  "name: foo
+version: 1.0.0
+homepage: http://test.org
+synopsis: synopsis
+description: description
+license: BSD3
+executable cabal
+  build-depends:
+    HTTP       >= 4000.2.5 && < 4000.3,
+    mtl        >= 2.0      && < 3
+")
+
+;; Use TABs to indent lines and to separate keys from value.
+(define test-cabal-2
+  "name:	foo
+version:	1.0.0
+homepage:	http://test.org
+synopsis:	synopsis
+description:	description
+license:	BSD3
+executable cabal
+	build-depends:	HTTP       >= 4000.2.5 && < 4000.3,
+		mtl        >= 2.0      && < 3
+")
+
+;; Use indentation with comma as found, e.g., in 'haddock-api'.
+(define test-cabal-3
+  "name: foo
+version: 1.0.0
+homepage: http://test.org
+synopsis: synopsis
+description: description
+license: BSD3
+executable cabal
+    build-depends:
+        HTTP       >= 4000.2.5 && < 4000.3
+      , mtl        >= 2.0      && < 3
+")
+
+(define test-cond-1
+  "(os(darwin) || !(flag(debug))) && flag(cips)")
+
+(define read-cabal
+  (@@ (guix import hackage) read-cabal))
+
+(define eval-cabal-keywords
+  (@@ (guix import hackage) eval-cabal-keywords))
+
+(define conditional->sexp-like
+  (@@ (guix import hackage) conditional->sexp-like))
+
+(test-begin "hackage")
+
+(define (eval-test-with-cabal test-cabal)
+  (mock
+   ((guix import hackage) hackage-fetch
+    (lambda (name-version)
+      (call-with-input-string test-cabal
+        read-cabal)))
+   (match (hackage->guix-package "foo")
+     (('package
+        ('name "ghc-foo")
+        ('version "1.0.0")
+        ('source
+         ('origin
+           ('method 'url-fetch)
+           ('uri ('string-append
+                  "http://hackage.haskell.org/package/foo/foo-"
+                  'version
+                  ".tar.gz"))
+           ('sha256
+            ('base32
+             (? string? hash)))))
+        ('build-system 'haskell-build-system)
+        ('inputs
+         ('quasiquote
+          (("ghc-http" ('unquote 'ghc-http))
+           ("ghc-mtl" ('unquote 'ghc-mtl)))))
+        ('home-page "http://test.org")
+        ('synopsis (? string?))
+        ('description (? string?))
+        ('license 'bsd-3))
+      #t)
+     (x
+      (pk 'fail x #f)))))
+
+(test-assert "hackage->guix-package test 1"
+  (eval-test-with-cabal test-cabal-1))
+
+(test-assert "hackage->guix-package test 2"
+  (eval-test-with-cabal test-cabal-2))
+
+(test-assert "hackage->guix-package test 3"
+  (eval-test-with-cabal test-cabal-3))
+
+(test-assert "conditional->sexp-like"
+  (match
+    (eval-cabal-keywords
+     (conditional->sexp-like test-cond-1)
+     '(("debug" . "False")))
+    (('and ('or ('string-match "darwin" ('%current-system)) ('not '#f)) '#t)
+     #t)
+    (x
+     (pk 'fail x #f))))
+
+(test-end "hackage")
+
+\f
+(exit (= (test-runner-fail-count (test-runner-current)) 0))
-- 
2.2.1