[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/27: import: Add hackage importer.
|
From: |
Federico Beffa |
|
Subject: |
02/27: import: Add hackage importer. |
|
Date: |
Wed, 08 Apr 2015 15:31:43 +0000 |
beffa pushed a commit to branch master
in repository guix.
commit b29455cfe7440e08f485eabc7a9335a856cacab8
Author: Federico Beffa <address@hidden>
Date: Sun Mar 8 07:48:38 2015 +0100
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(+), 0 deletions(-)
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 <address@hidden>
+;;;
+;;; 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 <address@hidden>
+;;;
+;;; 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")
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))
- branch master updated (bba229a -> a231ef7), Federico Beffa, 2015/04/08
- 03/27: build-system/haskell: Update configure flags, 'haddock' and %standard-phases., Federico Beffa, 2015/04/08
- 04/27: profiles: Generate GHC's package database cache., Federico Beffa, 2015/04/08
- 05/27: gnu: Add ghc-mtl., Federico Beffa, 2015/04/08
- 07/27: gnu: Add ghc-zlib., Federico Beffa, 2015/04/08
- 01/27: import: Add hackage importer., Federico Beffa, 2015/04/08
- 14/27: gnu: Add ghc-primitive., Federico Beffa, 2015/04/08
- 02/27: import: Add hackage importer.,
Federico Beffa <=
- 08/27: gnu: Add ghc-stm., Federico Beffa, 2015/04/08
- 13/27: gnu: Add ghc-random., Federico Beffa, 2015/04/08
- 11/27: gnu: Add ghc-hashable., Federico Beffa, 2015/04/08
- 22/27: gnu: Add ghc-split., Federico Beffa, 2015/04/08
- 20/27: gnu: Add ghc-fgl., Federico Beffa, 2015/04/08
- 16/27: gnu: Add ghc-quickcheck., Federico Beffa, 2015/04/08
- 09/27: gnu: Add ghc-parallel., Federico Beffa, 2015/04/08
- 12/27: gnu: Add ghc-hunit, Federico Beffa, 2015/04/08
- 06/27: gnu: Add ghc-paths., Federico Beffa, 2015/04/08
- 18/27: gnu: Add ghc-syb., Federico Beffa, 2015/04/08