* hackage importer
@ 2015-03-13 17:59 Federico Beffa
2015-03-15 14:38 ` Ludovic Courtès
0 siblings, 1 reply; 19+ messages in thread
From: Federico Beffa @ 2015-03-13 17:59 UTC (permalink / raw)
To: Guix-devel
[-- Attachment #1: Type: text/plain, Size: 1966 bytes --]
Hi,
please find attached an initial version of an importer for packages
from Hackage:
http://hackage.haskell.org/
Here a couple of features and limitations:
* The information about packages is retrieved from .cabal files.
Similarly to Haskell code these files support "layout" style grouping
and grouping with braces {}. Currently the importer only supports the
former which appears to be the most popular form.
* The code handles dependencies with conditionals and tries to comply
with the description at
https://www.haskell.org/cabal/users-guide/developing-packages.html#configurations
However, information about library versions is discarded.
* It implies the existence of a haskell-build-system which currently
doesn't exist. That's for another free week-end, or somebody
interested :-)
* Cabal files include dependencies to libraries included with the
complier (at least with GHC). For the moment I just filter those out
assuming the packages are going to be compiled with GHC.
* The generated package name is prefixed with "haskell-" in a similar
way to Perl and Python packages. However, the cabal file includes
checks for the compiler implementation and the importer handles that
and keep the test in the generated package (see eval-impl in the code
and the description in the above link). If in the future there is
interest in supporting other Haskell compilers, then maybe we should
better prefix the packages according to the used compiler ("ghc-"
...).
* The argument to the importer may include a version suffix (GUIX
style). If no version is included, then it retrieves the latest
version.
I've tested it with a hadful of packages among which "mtl",
"cabal-install" and "HTTP" and appears to be working.
Obviously the tests in part 5 were used along the way and will be
removed. Before doing that and squashing my local commits I thought I
would see the comments here :-) The attached patch is squashed with
"git diff master".
Regards,
Fede
[-- Attachment #2: 0001-import-hackage.patch --]
[-- Type: text/x-diff, Size: 42968 bytes --]
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
new file mode 100644
index 0000000..35af03d
--- /dev/null
+++ b/guix/import/hackage.scm
@@ -0,0 +1,1021 @@
+;;; 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-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 and do some pre-processing: discarding
+;; comments and empty lines.
+
+;; List of libraries distributed with ghc (7.8.4).
+(define ghc-standard-libraries
+ '("haskell98" ; 2.0.0.3
+ "hoopl" ; 3.10.0.1
+ "base"
+ "transformers" ; 0.3.0.0
+ "deepseq" ; 1.3.0.2
+ "array" ; 0.5.0.0
+ "binary" ; 0.7.1.0
+ "bytestring" ; 0.10.4.0
+ "containers" ; 0.5.5.1
+ "time" ; 1.4.2
+ "Cabal" ; 1.18.1.5 (but not "cabal-install")
+ "bin-package-db" ; 0.0.0.0
+ "ghc-prim"
+ "integer-gmp"
+ "Win32" ; 2.3.0.2
+ "template-haskell"
+ "process" ; 1.2.0.0
+ "haskeline" ; 0.7.1.2
+ "terminfo" ; 0.4.0.0
+ "directory" ; 1.2.1.0
+ "filepath" ; 1.3.0.2
+ "old-locale" ; 1.0.0.6
+ "unix" ; 2.7.0.1
+ "old-time" ; 1.1.0.2
+ "pretty" ; 1.1.1.1
+ "xhtml" ; 3000.2.1
+ "hpc")) ; 0.6.0.1
+
+;; Libraries present in the "Haskell Platform" 2014.2.0 and not included in
+;; the GHC standard libraries:
+;;
+;; "zlib" ; 0.5.4.1
+;; "async" ; 2.0.1.5
+;; "stm" ; 2.4.2
+;; "mtl" ; 2.1.3.1
+;; "primitive" ; 0.5.2.1
+;; "parallel" ; 3.2.0.4
+;; "attoparsec" ; 0.10.4.0
+;; "case-insensitive" ; 1.1.0.3
+;; "syb" ; 0.4.1
+;; "containers" ; 0.5.5.1
+;; "fgl" ; 5.5.0.1
+;; "unordered-containers" ; 0.2.3.3
+;; "hashable" ; 1.2.1.0
+;; "split" ; 0.2.2
+;; "text" ; 1.1.0.0
+;; "vector" ; 0.10.9.1
+;; "GLURaw" ; 1.4.0.1
+;; "OpenGL" ; 2.9.2.0
+;; "OpenGLRaw" ; 1.5.0.0
+;; "GLUT" ; 2.5.1.1
+;; "haskell-src" ; 1.0.1.6
+;; "network" ; 2.4.2.2
+;; "HTTP" ; 4000.2.10
+;; "random" ; 1.0.1.1
+;; "HUnit" ; 1.2.5.2
+;; "QuickCheck" ; 2.6
+;; "html" ; 1.0.1.2
+;; "parsec" ; 3.1.5
+;; "regex-compat" ; 0.95.1
+;; "regex-base" ; 0.93.2
+;; "regex-posix" ; 0.95.2
+
+(define guix-name-prefix "haskell-")
+
+;; Regular expression matching "key: value"
+(define key-value-rx
+ "([a-zA-Z0-9-]+): *(\\w?.*)$")
+
+;; Regular expression matching a section "head sub-head ..."
+(define sections-rx
+ "([a-zA-Z0-9\\(\\)-]+)")
+
+;; Cabal comment.
+(define comment-rx
+ "^ *--")
+
+;; Check if the current line includes a key
+(define (has-key? line)
+ (string-match key-value-rx line))
+
+(define (comment-line? line)
+ (string-match comment-rx line))
+
+;; returns the number of indentation spaces and the rest of the line.
+(define (line-indentation+rest line)
+ (let loop ((line-lst (string->list line))
+ (count 0))
+ (if (or (null? line-lst) (not (eqv? (first line-lst) #\space)))
+ (values count (list->string line-lst))
+ (loop (cdr line-lst) (+ count 1)))))
+
+;; Part 1 main function: read a cabal fila and filter empty lines and comments.
+;; Returns a list composed by the pre-processed lines of the file.
+(define (read-cabal port)
+ (let loop ((line (read-line port))
+ (result '()))
+ (cond
+ ((eof-object? line)
+ (reverse result))
+ ((or (string-null? line) (comment-line? line))
+ (loop (read-line port) result))
+ (else
+ (loop (read-line port) (cons line result))))))
+
+;; Part 2:
+;;
+;; Take the result of part 1 and convert the content of the file in a list of
+;; list pairs, where the first list of the pair includes keys while the second
+;; is a list of values.
+
+;; 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. Returns two values: (VALUES values-lst remaining-lines)
+(define (multi-line-value lines seed)
+ (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 current-indent)
+ (regexp-exec condition-rx next-line-value))
+ (values (reverse (cons value seed)) (cdr lines))
+ (multi-line-value (cdr lines) (cons value seed))))))
+
+;; Parses a cabal file in the form of a list of lines as produced by
+;; READ-CABAL and returns its content in the following form:
+;;
+;; (((head1 sub-head1 ... key1) (value))
+;; ((head2 sub-head2 ... key2) (value2))
+;; ...).
+;;
+;; where all elements are strings.
+;;
+;; We try do deduce the format from the following document:
+;; https://www.haskell.org/cabal/users-guide/developing-packages.html
+;;
+;; Key values are case-insensitive. We therefore lowercase them. Values are
+;; case-sensitive.
+;;
+;; Currently only only layout structured files are parsed. Braces {}
+;; structured files are not handled.
+(define (cabal->key-values lines)
+ (let loop
+ ((lines lines)
+ (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*-values (((idx) (+ (list-index
+ (lambda (x) (= next-line-indent x))
+ indents)
+ (if (has-key? next-line) 1 0)))
+ ((_ sec) (split-at sections idx))
+ ((_ ind) (split-at 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))))))))
+
+;; Find if a string represent a conditional
+(define condition-rx
+ (make-regexp "^if +(.*)$"))
+
+;; Split sections in individual words with exception for the predicate of an
+;; 'if' conditional.
+(define (split-section section)
+ (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))
+ (() '())))
+
+;; Split all strings included in the list of keys into individual words, with
+;; exception for 'if' predicates. Returns an entry with the key list composed
+;; by single words. This is used to read flags.
+(define (pre-process-entries-keys entries)
+ (match entries
+ ((entry rest ...)
+ (cons (pre-process-entry-keys entry)
+ (pre-process-entries-keys rest)))
+ (()
+ '())))
+
+;; Read flags and returns an alist where each pair is composed by the name of
+;; a flag and its value: "True" or "False".
+(define (get-flags pre-processed-entries)
+ (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 3:
+;;
+;; So far we did read the cabal file and extracted flags information. Now we
+;; need to evaluate the conditions and process the entries accordingly.
+
+;; Cabal test keywords
+(define tests-rx
+ (make-regexp "(os|arch|flag|impl)\\(([a-zA-Z0-9_-]+)\\)"))
+
+;; Parentheses within conditions
+(define parens-rx
+ (make-regexp "\\((.+)\\)"))
+
+;; OR operator in conditions
+(define or-rx
+ (make-regexp " +\\|\\| +"))
+
+;; AND operator in conditions
+(define and-rx
+ (make-regexp " +&& +"))
+
+;; NOT operator in conditions
+(define not-rx
+ (make-regexp "^!.+"))
+
+;; Returns a list with the arguments of (logic) bianry operators. MATCH-LST
+;; is the result of "list-match" against a binary operator regexp.
+(define (bi-op-args str match-lst)
+ (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))))))
+
+;; If there is a single argument there is no binary operation to perform. We
+;; just return the argument. Takes a list as produced by
+;; "bi-op-argsf". Returns a string.
+(define (bi-op->sexp-like bi-op args)
+ (if (= (length args) 1)
+ (first args)
+ (string-append "(" bi-op
+ (fold (lambda (arg seed) (string-append seed " " arg))
+ "" args) ")")))
+
+;; Takes a string and checks for negation symbol.
+(define (not->sexp-like arg)
+ (if (regexp-exec not-rx arg)
+ (string-append "(not "
+ (substring arg 1 (string-length arg))
+ ")")
+ arg))
+
+;; Convert a CABAL conditional string into a string with equivalent SCHEME
+;; syntax. This procedure accepts only simple conditionals without
+;; parentheses.
+(define (parens-less-cond->sexp-like conditional)
+ ;; 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 "§§")
+
+;; Convert a CABAL conditional string into a string with equivalent SCHEME
+;; syntax.
+(define (conditional->sexp-like conditional)
+ ;; 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)))))))
+
+;; Substitute SCHEME #t or #f according to the value of flags. (Default to
+;; "True")
+(define (eval-flags sexp-like-cond flags)
+ (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)))
+
+;; We need to substitute test keywords "os(...)" and "arch(...)" with
+;; S-expression functions that perform the check when we want to build the
+;; package.
+;;
+;; (%current-system) returns, e.g., "x86_64-linux" or "i686-linux".
+(define (eval-tests sexp-like-cond)
+ (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
+ '(("(os|arch)" "(string-match \"" "\" (%current-system))")))
+ read))
+
+;; We check for the cabal test "impl(...)". Assume the module declaring the
+;; generated package includes a local variable called "haskell-implementation"
+;; with a value of the form NAME-VERSION against which we compare.
+(define (eval-impl sexp-like-cond)
+ (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 " \"" 1 "-" 3 "\" " post-match '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)))))
+
+;; META is the result of "cabal->key-values". Returns the list associated with
+;; a specific KEY. Since the value can be a list (as for "description"), we
+;; always return a list.
+(define (key->values meta key)
+ (match meta
+ (() '())
+ (((((? (lambda(x) (equal? x key)))) v) r ...)
+ v)
+ (((k v) r ...)
+ (key->values (cdr meta) key))
+ (_ "key Not fount")))
+
+;; Returns all entries with a key starting with key-start and ending with
+;; key-end as in (key-start ... key-end).
+(define (key-start-end->entries meta key-start key-end)
+ (let ((pred
+ (lambda (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 key-end)))
+ (((k v) r ...)
+ (key-start-end->entries (cdr meta) key-start key-end))
+ (_ "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 (guix-name name)
+ (if (string-prefix? guix-name-prefix name)
+ (string-downcase name)
+ (string-append guix-name-prefix (string-downcase name))))
+
+;; Split the comma separated list of dependencies coming from the cabal file
+;; and return a list with inputs suitable for the GUIX package. Currently the
+;; version information is discarded.
+(define (split-dependencies ls)
+ (define (split-at-comma d)
+ (map
+ (lambda (m)
+ (let ((name (guix-name (match:substring m 1))))
+ (list name (list 'unquote (string->symbol name)))))
+ (list-matches dependencies-rx d)))
+
+ (fold (lambda (d p) (append (split-at-comma d) p)) '() ls))
+
+;; Genrate an S-expression containing the list of dependencies. 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 (dependencies-cond->sexp meta)
+
+ (define (take-dependencies meta)
+ (let ((key-start-exe "executable cabal")
+ (key-start-lib "library")
+ (key-end "build-depends"))
+ (append
+ (key-start-end->entries meta key-start-exe key-end)
+ (key-start-end->entries meta key-start-lib key-end))))
+
+ (let ((flags (get-flags (pre-process-entries-keys meta))))
+ (delete-duplicates
+ (let loop ((entries (take-dependencies meta))
+ (result '()))
+ (if (null? entries)
+ 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-dependencies vals) result)))
+ (else
+ (let-values (((true-group false-group entries)
+ (group-and-reduce-level entries '()
+ key-cond))
+ ((cond-final) (eval-tests
+ (eval-impl
+ (eval-flags
+ (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
+ (cons `(unquote-splicing
+ (if ,cond-final
+ ,(loop true-group '())
+ ,(loop false-group '())))
+ result)))))))))))))
+
+;; Filter the libraries already included in the Haskell compiler standard
+;; libraries. Currently we imply the use of GHC.
+(define (filter-standard-libraries ls)
+ (let ((real-name-rx (make-regexp
+ (string-append guix-name-prefix "(\\w+)"))))
+ (fold (lambda (elem seed)
+ (if (eq? (first elem) 'unquote-splicing)
+ (let*-values (((group-cond true-group false-group)
+ (match (second elem)
+ ((if c t f )
+ (values c t f))
+ (_ (values c '() '()))))
+ ((filtered-true-group)
+ (filter-standard-libraries true-group))
+ ((filtered-false-group)
+ (filter-standard-libraries false-group)))
+ (cond
+ ((and (null? filtered-false-group)
+ (null? filtered-true-group))
+ seed)
+ ((null? filtered-false-group)
+ (cons (list 'unquote-splicing
+ (list 'if group-cond
+ filtered-true-group))
+ seed))
+ (else
+ (cons (list 'unquote-splicing
+ (list 'if group-cond
+ filtered-true-group
+ filtered-false-group))
+ seed))))
+ (let ((rx-result (regexp-exec real-name-rx (first elem))))
+ (match (match:substring rx-result 1)
+ ((? (cut member <>
+ ;; GUIX names are all lower-case.
+ (map (cut string-downcase <>)
+ ghc-standard-libraries)))
+ seed)
+ (_
+ (cons elem seed))))))
+ '() ls)))
+
+;; Part 4:
+;;
+;; 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")))
+ ((cabal)
+ (call-with-temporary-output-file
+ (lambda (temp port)
+ (and (url-fetch url temp)
+ (call-with-input-file temp read-cabal))))))
+ (and=> cabal cabal->key-values)))
+
+;; List of valid values from
+;; https://www.haskell.org
+;; /cabal/release/cabal-latest/doc/API/Cabal/Distribution-License.html.
+(define string->license
+ (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)
+ "Return the `package' s-expression for a cabal package from the metadata in
+META."
+
+ (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"))
+
+ (define (maybe-inputs guix-name inputs)
+ (match (filter-standard-libraries inputs)
+ (()
+ '())
+ ((inputs ...)
+ (list (list guix-name
+ (list 'quasiquote inputs))))))
+
+ (let ((tarball (with-store store
+ (download-to-store store source-url))))
+ `(package
+ (name ,(guix-name name))
+ (version ,version)
+ (source (origin
+ (method url-fetch)
+ (uri (string-append ,@(factorize-uri source-url version)))
+ (sha256
+ (base32
+ ,(bytevector->nix-base32-string (file-sha256 tarball))))))
+ (build-system haskell-build-system)
+ ,@(maybe-inputs 'inputs (dependencies-cond->sexp meta))
+ (home-page ,@(key->values meta "homepage"))
+ (synopsis ,@(key->values meta "synopsis"))
+ (description ,description)
+ (license ,(string->license (key->values meta "license"))))))
+
+(define (hackage->guix-package module-name)
+ "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 hackage-module->sexp)))
+
+;; Part 5:
+;;
+;; Some variables used to test the varisous functions.
+
+(define test-1
+ '("head 1"
+ " kh1: vh1"
+ " kh2: vh2"
+ "name: mtl"))
+
+(define test-2
+ '("head 1"
+ " subh 1"
+ " kh1: vh1"
+ " kh2: vh2"
+ "name: mtl"))
+
+(define test-3
+ '("head 1"
+ " subh 1"
+ " kh1: vh1"
+ " subh 2"
+ " kh2: vh2"
+ " kh3: vh3"
+ "name: mtl"))
+
+(define test-4
+ '("Library"
+ " Build-Depends: basee"
+ " Exposed-Modules: Testing.Test1"
+ " Extensions: CPP"
+ " if flag(debug)"
+ " GHC-Options: -DDEBUG"
+ " if !os(windows)"
+ " CC-Options: \"-DDEBUG\""
+ " else"
+ " CC-Options: \"-DNDEBUG else\""
+ " if flag(webfrontend)"
+ " Build-Depends: cgi > 0.42"
+ " Other-Modules: Testing.WebStuff"))
+
+(define test-5
+ '("Flag Debug"
+ " Description: Enable debug support"
+ " Default: False"
+ "Library"
+ " Build-Depends: base"
+ " if flag(debug)"
+ " GHC-Options: -DDEBUG"
+ " if !os(windows)"
+ " CC-Options: \"-DDEBUG\""
+ " else"
+ " CC-Options: \"-DNDEBUG\""))
+
+(define test-6
+ '("Flag Debug"
+ " Description: Enable debug support"
+ " Default: False"
+ "Flag Cips"
+ " Description: This is a journey into the sound..."
+ " Default: True"
+ "if flag(debug)"
+ " GHC-Options: -DDEBUG"
+ " if !os(windows)"
+ " CC-Options: \"-DDEBUG\""
+ " else"
+ " CC-Options: \"-DNDEBUG\""))
+
+(define test-7
+ '("executable cabal"
+ " main-is: Main.hs"
+ " build-depends:"
+ " array >= 0.1 && < 0.6,"
+ " base >= 4.3 && < 5"
+ " if flag(old-directory)"
+ " build-depends: directory >= 1 && < 1.2, old-time >= 1 && < 1.2,"
+ " process >= 1.0.1.1 && < 1.1.0.2"
+ " else"
+ " build-depends: directory >= 1.2 && < 1.3,"
+ " process >= 1.1.0.2 && < 1.3"
+ " if flag(network-uri)"
+ " build-depends: network-uri >= 2.6, network >= 2.6"
+ " else"
+ " build-depends: network >= 2.4 && < 2.6"
+ " if os(windows)"
+ " build-depends: Win32 >= 2 && < 3"
+ " cpp-options: -DWIN32"
+ " else"
+ " build-depends: unix >= 2.0 && < 2.8"))
+
+(define test-dep-1
+ '((("executable cabal" "build-depends")
+ ("array >= 0.1"))
+ (("executable cabal" "build-depends")
+ ("fbe >= 0.2"))))
+
+(define test-dep-2
+ '((("executable cabal" "if flag(cips)" "build-depends")
+ ("fbe >= 0.2"))))
+
+(define test-dep-3
+ '((("executable cabal" "if flag(cips)" "build-depends")
+ ("fbe >= 0.2"))
+ (("executable cabal" "else" "build-depends")
+ ("fbeee >= 0.3"))
+ ))
+
+(define test-dep-4
+ '((("executable cabal" "if flag(a)" "if flag(b)" "build-depends")
+ ("network-uri >= 2.6, network >= 2.6"))
+ (("executable cabal" "if flag(a)" "else" "build-depends")
+ ("fbeeeee >= 0.3"))
+ (("executable cabal" "build-depends")
+ ("network >= 0.1"))
+ ))
+
+(define test-dep-5
+ '((("executable cabal" "if flag(a)" "if flag(b)" "build-depends")
+ ("fbe >= 0.2"))
+ (("executable cabal" "if flag(a)" "else" "build-depends")
+ ("fbe >= 0.3"))
+ (("executable cabal" "else" "build-depends")
+ ("fbe >= 0.4"))
+ ))
+
+(define test-dep-6
+ '((("executable cabal" "if flag(a)" "if flag(b)" "build-depends")
+ ("fbe >= 0.2"))
+ (("executable cabal" "if flag(a)" "else" "build-depends")
+ ("fbe >= 0.3"))
+ (("executable cabal" "else" "build-depends")
+ ("fbe >= 0.4"))
+ (("executable cabal" "build-depends")
+ ("array >= 0.1"))
+ ))
+
+(define test-dep-10
+ '((("executable cabal" "build-depends")
+ ("array >= 0.1 && < 0.6," "base >= 4.3 && < 5"))
+ (("executable cabal" "if flag(old-directory)" "build-depends")
+ ("directory >= 1 && < 1.2," "process >= 1.0.1.1 && < 1.1.0.2"))
+ (("executable cabal" "else" "build-depends")
+ ("directory >= 1.2 && < 1.3," "process >= 1.1.0.2 && < 1.3"))
+ (("executable cabal" "if flag(network-uri)" "build-depends")
+ ("network-uri >= 2.6, network >= 2.6"))
+ (("executable cabal" "else" "build-depends")
+ ("network >= 2.4 && < 2.6"))
+ (("executable cabal" "if os(windows)" "build-depends")
+ ("Win32 >= 2 && < 3"))
+ (("executable cabal" "else" "build-depends")
+ ("unix >= 2.0 && < 2.8"))))
+
+(define test-dep-10a
+ '((("executable cabal" "build-depends")
+ ("array >= 0.1 && < 0.6," "base >= 4.3 && < 5"))
+ (("executable cabal" "if flag(old-directory)" "build-depends")
+ ("directory >= 1 && < 1.2, old-time >= 1 && < 1.2"))
+ (("executable cabal" "else" "build-depends")
+ ("directory >= 1.2 && < 1.3," "process >= 1.1.0.2 && < 1.3"))
+ (("executable cabal" "if flag(network-uri)" "build-depends")
+ ("network-uri >= 2.6, network >= 2.6"))
+ (("executable cabal" "else" "build-depends")
+ ("network >= 2.4 && < 2.6"))
+ (("executable cabal" "if os(windows)" "build-depends")
+ ("Win32 >= 2 && < 3"))
+ (("executable cabal" "else" "build-depends")
+ ("unix >= 2.0 && < 2.8"))))
+
+(define test-dep-11
+ '((("executable cabal" "if flag(old-directory)" "if flag(network-uri)" "build-depends")
+ ("network-uri >= 2.6, network >= 2.6"))
+ (("executable cabal" "if flag(old-directory)" "if flag(network-uri)" "if flag(cips)" "build-depends")
+ ("network-uri >= 2.6, network >= 2.6"))
+ (("executable cabal" "if flag(old-directory)" "else" "build-depends")
+ ("network >= 2.4 && < 2.6"))
+ (("executable cabal" "else" "build-depends")
+ ("directory >= 1.2 && < 1.3," "process >= 1.1.0.2 && < 1.3"))
+ (("executable cabal" "else" "if flag(cips)" "build-depends")
+ ("cip >= 1.2"))))
+
+(define test-dep-12
+ '((("executable cabal" "build-depends")
+ ("array >= 0.1 && < 0.6," "base >= 4.3 && < 5"))
+ (("executable cabal" "if flag(old-directory)" "build-depends")
+ ("directory >= 1 && < 1.2," "process >= 1.0.1.1 && < 1.1.0.2"))
+ (("executable cabal" "if flag(old-directory)" "if flag(network-uri)" "build-depends")
+ ("network-uri >= 2.6, network >= 2.6"))
+ (("executable cabal" "if flag(old-directory)" "else" "build-depends")
+ ("network >= 2.4 && < 2.6"))
+ (("executable cabal" "else" "build-depends")
+ ("directory >= 1.2 && < 1.3," "process >= 1.1.0.2 && < 1.3"))))
+
+(define test-dep-13
+ '((("executable cabal" "if os(linux)" "if flag(debug)" "build-depends")
+ ("network-uri >= 2.6, network >= 2.6"))
+ (("executable cabal" "if os(linux)" "if flag(debug)" "if flag(cips)" "build-depends")
+ ("network-uri >= 2.6, network >= 2.6"))
+ (("executable cabal" "if os(linux)" "else" "build-depends")
+ ("network >= 2.4 && < 2.6"))
+ (("executable cabal" "else" "build-depends")
+ ("directory >= 1.2 && < 1.3," "process >= 1.1.0.2 && < 1.3"))
+ (("executable cabal" "else" "if flag(cips)" "build-depends")
+ ("cip >= 1.2"))))
+
+(define test-cond-1
+ "(os(darwin) && !(arch(i386))) || os(freebsd)")
+
+(define test-cond-2
+ "(os(darwin) || !(arch(i386))) && os(freebsd)")
+
+(define test-cond-3
+ "os(darwin) && arch(i386) || os(freebsd)")
+
+(define test-cond-4
+ "os(darwin) && !arch(i386) || !os(freebsd)")
+
+(define test-cond-5
+ "os(darwin) && !arch(i386) && !os(freebsd)")
+
+(define test-cond-6
+ "(os(darwin) || !(flag(debug))) && flag(cips)")
+
+(define test-cond-7
+ "(os(darwin) || !(flag(debug))) && flag(cips) && flag(fbe)")
+
+(define test-cond-8
+ "os(linux) && impl(ghc)")
+
+(define test-cond-9
+ "os(linux) && impl(ghc <= 6.1.0)")
+
+;; Run some tests
+
+;; (display (cabal->key-values
+;; (call-with-input-file "mtl.cabal" read-cabal)))
+;; (display (cabal->key-values
+;; (call-with-input-file "/home/beffa/tmp/cabal-install.cabal" read-cabal)))
+;; (display (get-flags (pre-process-entries-keys (cabal->key-values test-5))))
+;; (newline)
+;; (display (conditional->sexp-like test-cond-2))
+;; (newline)
+;; (display
+;; (eval-flags (conditional->sexp-like test-cond-6)
+;; (get-flags (pre-process-entries-keys (cabal->key-values test-6)))))
+;; (newline)
+;; (key->values (cabal->key-values test-1) "name")
+;; (newline)
+;; (key-start-end->entries (cabal->key-values test-4) "Library" "CC-Options")
+;; (newline)
+;; (eval-tests (conditional->sexp-like test-cond-6))
+;;
+;;; cabal.scm ends here
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..22a9888
--- /dev/null
+++ b/guix/scripts/import/hackage.scm
@@ -0,0 +1,96 @@
+;;; 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
+ '())
+
+(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 (_ "
+ -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")))
+ %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)))
+ (unless sexp
+ (leave (_ "failed to download cabal file for package '~a'~%")
+ package-name))
+ sexp))
+ (()
+ (leave (_ "too few arguments~%")))
+ ((many ...)
+ (leave (_ "too many arguments~%"))))))
^ permalink raw reply related [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-03-13 17:59 Federico Beffa
@ 2015-03-15 14:38 ` Ludovic Courtès
2015-03-15 22:29 ` Federico Beffa
0 siblings, 1 reply; 19+ messages in thread
From: Ludovic Courtès @ 2015-03-15 14:38 UTC (permalink / raw)
To: Federico Beffa; +Cc: Guix-devel
Federico Beffa <beffa@ieee.org> skribis:
> please find attached an initial version of an importer for packages
> from Hackage:
> http://hackage.haskell.org/
Woow, impressive piece of work!
[...]
> * The code handles dependencies with conditionals and tries to comply
> with the description at
> https://www.haskell.org/cabal/users-guide/developing-packages.html#configurations
Neat.
> * Cabal files include dependencies to libraries included with the
> complier (at least with GHC). For the moment I just filter those out
> assuming the packages are going to be compiled with GHC.
Sounds good.
> * The generated package name is prefixed with "haskell-" in a similar
> way to Perl and Python packages. However, the cabal file includes
> checks for the compiler implementation and the importer handles that
> and keep the test in the generated package (see eval-impl in the code
> and the description in the above link). If in the future there is
> interest in supporting other Haskell compilers, then maybe we should
> better prefix the packages according to the used compiler ("ghc-"
> ...).
I would use ‘ghc-’ right from the start, since that’s really what it
is. WDYT?
> Obviously the tests in part 5 were used along the way and will be
> removed.
More precisely, they’ll have to be turned into tests/hackage.scm
(similar to tests/snix.scm and tests/pypi.scm.) :-)
This looks like really nice stuff. There are patterns that are not
sufficiently apparent IMO, like ‘read-cabal’ that would do the actual
parsing and return a first-class cabal object, and then ‘eval-cabal’ (or
similar) that would evaluate the conditionals in a cabal object. For
the intermediate steps, I would expect conversion procedures from one
representation to another, typically ‘foo->bar’.
Some comments below.
> +;; List of libraries distributed with ghc (7.8.4).
> +(define ghc-standard-libraries
> + '("haskell98" ; 2.0.0.3
> + "hoopl" ; 3.10.0.1
Maybe the version numbers in comments can be omitted since they’ll
become outdated eventually?
> +(define guix-name-prefix "haskell-")
s/guix-name-prefix/package-name-prefix/ and rather “ghc-” IMO.
> +;; Regular expression matching "key: value"
> +(define key-value-rx
> + "([a-zA-Z0-9-]+): *(\\w?.*)$")
> +
> +;; Regular expression matching a section "head sub-head ..."
> +(define sections-rx
> + "([a-zA-Z0-9\\(\\)-]+)")
> +
> +;; Cabal comment.
> +(define comment-rx
> + "^ *--")
Use (make-regexp ...) directly, and then ‘regexp-exec’ instead of
‘string-match’.
> +;; Check if the current line includes a key
> +(define (has-key? line)
> + (string-match key-value-rx line))
> +
> +(define (comment-line? line)
> + (string-match comment-rx line))
> +
> +;; returns the number of indentation spaces and the rest of the line.
> +(define (line-indentation+rest line)
Please turn all the comments above procedures this into docstrings.
> +;; Part 1 main function: read a cabal fila and filter empty lines and comments.
> +;; Returns a list composed by the pre-processed lines of the file.
> +(define (read-cabal port)
s/fila/file/
s/Returns/Return/
I would expect ‘read-cabal’ to return a <cabal> record, say, that can be
directly manipulated (just like ‘read’ returns a Scheme object.) But
here it seems to return an intermediate parsing result, right?
> +;; Parses a cabal file in the form of a list of lines as produced by
> +;; READ-CABAL and returns its content in the following form:
> +;;
> +;; (((head1 sub-head1 ... key1) (value))
> +;; ((head2 sub-head2 ... key2) (value2))
> +;; ...).
> +;;
> +;; where all elements are strings.
> +;;
> +;; We try do deduce the format from the following document:
> +;; https://www.haskell.org/cabal/users-guide/developing-packages.html
> +;;
> +;; Key values are case-insensitive. We therefore lowercase them. Values are
> +;; case-sensitive.
> +;;
> +;; Currently only only layout structured files are parsed. Braces {}
“only indentation-structured files”
> +;; structured files are not handled.
> +(define (cabal->key-values lines)
I think this is the one I would call ‘read-cabal’.
> +;; Find if a string represent a conditional
> +(define condition-rx
> + (make-regexp "^if +(.*)$"))
The comment should rather be “Regexp for conditionals.” and be placed
below ‘define’.
> +;; Part 3:
> +;;
> +;; So far we did read the cabal file and extracted flags information. Now we
> +;; need to evaluate the conditions and process the entries accordingly.
I would expect the conversion of conditional expressions to sexps to be
done in the parsing phase above, such that ‘read-cabal’ returns an
object with some sort of an AST for those conditionals.
Then this part would focus on the evaluation of those conditionals,
like:
;; Evaluate the conditionals in CABAL according to FLAGS. Return an
;; evaluated Cabal object.
(eval-cabal cabal flags)
WDYT?
> +(define (guix-name name)
Rather ‘hackage-name->package-name’?
> +;; Split the comma separated list of dependencies coming from the cabal file
> +;; and return a list with inputs suitable for the GUIX package. Currently the
> +;; version information is discarded.
s/GUIX/Guix/
> +(define (split-dependencies ls)
> + (define (split-at-comma d)
> + (map
> + (lambda (m)
> + (let ((name (guix-name (match:substring m 1))))
> + (list name (list 'unquote (string->symbol name)))))
> + (list-matches dependencies-rx d)))
I think it could use simply:
(map string-trim-both
(string-tokenize d (char-set-complement (char-set #\,))))
> +;; Genrate an S-expression containing the list of dependencies. The generated
“Generate”
> +;; S-expressions may include conditionals as defined in the cabal file.
> +;; During this process we discard the version information of the packages.
> +(define (dependencies-cond->sexp meta)
[...]
> + (match (match:substring rx-result 1)
> + ((? (cut member <>
> + ;; GUIX names are all lower-case.
> + (map (cut string-downcase <>)
> + ghc-standard-libraries)))
s/GUIX/Guix/
I find it hard to read. Typically, I would introduce:
(define (standard-library? name)
(member name ghc-standard-libraries))
and use it here (with the assumption that ‘ghc-standard-libraries’ is
already lowercase.)
> +;; Part 5:
> +;;
> +;; Some variables used to test the varisous functions.
“various”
> +(define test-dep-3
> + '((("executable cabal" "if flag(cips)" "build-depends")
> + ("fbe >= 0.2"))
> + (("executable cabal" "else" "build-depends")
> + ("fbeee >= 0.3"))
> + ))
No hanging parens please.
> +;; Run some tests
> +
> +;; (display (cabal->key-values
> +;; (call-with-input-file "mtl.cabal" read-cabal)))
> +;; (display (cabal->key-values
> +;; (call-with-input-file "/home/beffa/tmp/cabal-install.cabal" read-cabal)))
> +;; (display (get-flags (pre-process-entries-keys (cabal->key-values test-5))))
> +;; (newline)
> +;; (display (conditional->sexp-like test-cond-2))
> +;; (newline)
> +;; (display
> +;; (eval-flags (conditional->sexp-like test-cond-6)
> +;; (get-flags (pre-process-entries-keys (cabal->key-values test-6)))))
> +;; (newline)
> +;; (key->values (cabal->key-values test-1) "name")
> +;; (newline)
> +;; (key-start-end->entries (cabal->key-values test-4) "Library" "CC-Options")
> +;; (newline)
> +;; (eval-tests (conditional->sexp-like test-cond-6))
This should definitely go to tests/hackage.scm.
> + (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
s/GUIX/Guix/
Also, guix/scripts/import.scm must be added to po/guix/POTFILES.in, for
i18n.
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-03-15 14:38 ` Ludovic Courtès
@ 2015-03-15 22:29 ` Federico Beffa
2015-03-22 20:12 ` Federico Beffa
0 siblings, 1 reply; 19+ messages in thread
From: Federico Beffa @ 2015-03-15 22:29 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Guix-devel
Thanks for the review!
I'm currently on a business trip. Will look carefully at your comments
when I will be back.
Regards,
Fede
On Sun, Mar 15, 2015 at 2:38 PM, Ludovic Courtès <ludo@gnu.org> wrote:
> Federico Beffa <beffa@ieee.org> skribis:
>
>> please find attached an initial version of an importer for packages
>> from Hackage:
>> http://hackage.haskell.org/
>
> Woow, impressive piece of work!
>
> [...]
>
>> * The code handles dependencies with conditionals and tries to comply
>> with the description at
>> https://www.haskell.org/cabal/users-guide/developing-packages.html#configurations
>
> Neat.
>
>> * Cabal files include dependencies to libraries included with the
>> complier (at least with GHC). For the moment I just filter those out
>> assuming the packages are going to be compiled with GHC.
>
> Sounds good.
>
>> * The generated package name is prefixed with "haskell-" in a similar
>> way to Perl and Python packages. However, the cabal file includes
>> checks for the compiler implementation and the importer handles that
>> and keep the test in the generated package (see eval-impl in the code
>> and the description in the above link). If in the future there is
>> interest in supporting other Haskell compilers, then maybe we should
>> better prefix the packages according to the used compiler ("ghc-"
>> ...).
>
> I would use ‘ghc-’ right from the start, since that’s really what it
> is. WDYT?
>
>> Obviously the tests in part 5 were used along the way and will be
>> removed.
>
> More precisely, they’ll have to be turned into tests/hackage.scm
> (similar to tests/snix.scm and tests/pypi.scm.) :-)
>
> This looks like really nice stuff. There are patterns that are not
> sufficiently apparent IMO, like ‘read-cabal’ that would do the actual
> parsing and return a first-class cabal object, and then ‘eval-cabal’ (or
> similar) that would evaluate the conditionals in a cabal object. For
> the intermediate steps, I would expect conversion procedures from one
> representation to another, typically ‘foo->bar’.
>
> Some comments below.
>
>> +;; List of libraries distributed with ghc (7.8.4).
>> +(define ghc-standard-libraries
>> + '("haskell98" ; 2.0.0.3
>> + "hoopl" ; 3.10.0.1
>
> Maybe the version numbers in comments can be omitted since they’ll
> become outdated eventually?
>
>> +(define guix-name-prefix "haskell-")
>
> s/guix-name-prefix/package-name-prefix/ and rather “ghc-” IMO.
>
>> +;; Regular expression matching "key: value"
>> +(define key-value-rx
>> + "([a-zA-Z0-9-]+): *(\\w?.*)$")
>> +
>> +;; Regular expression matching a section "head sub-head ..."
>> +(define sections-rx
>> + "([a-zA-Z0-9\\(\\)-]+)")
>> +
>> +;; Cabal comment.
>> +(define comment-rx
>> + "^ *--")
>
> Use (make-regexp ...) directly, and then ‘regexp-exec’ instead of
> ‘string-match’.
>
>> +;; Check if the current line includes a key
>> +(define (has-key? line)
>> + (string-match key-value-rx line))
>> +
>> +(define (comment-line? line)
>> + (string-match comment-rx line))
>> +
>> +;; returns the number of indentation spaces and the rest of the line.
>> +(define (line-indentation+rest line)
>
> Please turn all the comments above procedures this into docstrings.
>
>> +;; Part 1 main function: read a cabal fila and filter empty lines and comments.
>> +;; Returns a list composed by the pre-processed lines of the file.
>> +(define (read-cabal port)
>
> s/fila/file/
> s/Returns/Return/
>
> I would expect ‘read-cabal’ to return a <cabal> record, say, that can be
> directly manipulated (just like ‘read’ returns a Scheme object.) But
> here it seems to return an intermediate parsing result, right?
>
>> +;; Parses a cabal file in the form of a list of lines as produced by
>> +;; READ-CABAL and returns its content in the following form:
>> +;;
>> +;; (((head1 sub-head1 ... key1) (value))
>> +;; ((head2 sub-head2 ... key2) (value2))
>> +;; ...).
>> +;;
>> +;; where all elements are strings.
>> +;;
>> +;; We try do deduce the format from the following document:
>> +;; https://www.haskell.org/cabal/users-guide/developing-packages.html
>> +;;
>> +;; Key values are case-insensitive. We therefore lowercase them. Values are
>> +;; case-sensitive.
>> +;;
>> +;; Currently only only layout structured files are parsed. Braces {}
>
> “only indentation-structured files”
>
>> +;; structured files are not handled.
>> +(define (cabal->key-values lines)
>
> I think this is the one I would call ‘read-cabal’.
>
>> +;; Find if a string represent a conditional
>> +(define condition-rx
>> + (make-regexp "^if +(.*)$"))
>
> The comment should rather be “Regexp for conditionals.” and be placed
> below ‘define’.
>
>> +;; Part 3:
>> +;;
>> +;; So far we did read the cabal file and extracted flags information. Now we
>> +;; need to evaluate the conditions and process the entries accordingly.
>
> I would expect the conversion of conditional expressions to sexps to be
> done in the parsing phase above, such that ‘read-cabal’ returns an
> object with some sort of an AST for those conditionals.
>
> Then this part would focus on the evaluation of those conditionals,
> like:
>
> ;; Evaluate the conditionals in CABAL according to FLAGS. Return an
> ;; evaluated Cabal object.
> (eval-cabal cabal flags)
>
> WDYT?
>
>> +(define (guix-name name)
>
> Rather ‘hackage-name->package-name’?
>
>> +;; Split the comma separated list of dependencies coming from the cabal file
>> +;; and return a list with inputs suitable for the GUIX package. Currently the
>> +;; version information is discarded.
>
> s/GUIX/Guix/
>
>> +(define (split-dependencies ls)
>> + (define (split-at-comma d)
>> + (map
>> + (lambda (m)
>> + (let ((name (guix-name (match:substring m 1))))
>> + (list name (list 'unquote (string->symbol name)))))
>> + (list-matches dependencies-rx d)))
>
> I think it could use simply:
>
> (map string-trim-both
> (string-tokenize d (char-set-complement (char-set #\,))))
>
>> +;; Genrate an S-expression containing the list of dependencies. The generated
>
> “Generate”
>
>> +;; S-expressions may include conditionals as defined in the cabal file.
>> +;; During this process we discard the version information of the packages.
>> +(define (dependencies-cond->sexp meta)
>
> [...]
>
>> + (match (match:substring rx-result 1)
>> + ((? (cut member <>
>> + ;; GUIX names are all lower-case.
>> + (map (cut string-downcase <>)
>> + ghc-standard-libraries)))
>
> s/GUIX/Guix/
>
> I find it hard to read. Typically, I would introduce:
>
> (define (standard-library? name)
> (member name ghc-standard-libraries))
>
> and use it here (with the assumption that ‘ghc-standard-libraries’ is
> already lowercase.)
>
>> +;; Part 5:
>> +;;
>> +;; Some variables used to test the varisous functions.
>
> “various”
>
>> +(define test-dep-3
>> + '((("executable cabal" "if flag(cips)" "build-depends")
>> + ("fbe >= 0.2"))
>> + (("executable cabal" "else" "build-depends")
>> + ("fbeee >= 0.3"))
>> + ))
>
> No hanging parens please.
>
>> +;; Run some tests
>> +
>> +;; (display (cabal->key-values
>> +;; (call-with-input-file "mtl.cabal" read-cabal)))
>> +;; (display (cabal->key-values
>> +;; (call-with-input-file "/home/beffa/tmp/cabal-install.cabal" read-cabal)))
>> +;; (display (get-flags (pre-process-entries-keys (cabal->key-values test-5))))
>> +;; (newline)
>> +;; (display (conditional->sexp-like test-cond-2))
>> +;; (newline)
>> +;; (display
>> +;; (eval-flags (conditional->sexp-like test-cond-6)
>> +;; (get-flags (pre-process-entries-keys (cabal->key-values test-6)))))
>> +;; (newline)
>> +;; (key->values (cabal->key-values test-1) "name")
>> +;; (newline)
>> +;; (key-start-end->entries (cabal->key-values test-4) "Library" "CC-Options")
>> +;; (newline)
>> +;; (eval-tests (conditional->sexp-like test-cond-6))
>
> This should definitely go to tests/hackage.scm.
>
>> + (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
>
> s/GUIX/Guix/
>
> Also, guix/scripts/import.scm must be added to po/guix/POTFILES.in, for
> i18n.
>
> Thanks!
>
> Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-03-15 22:29 ` Federico Beffa
@ 2015-03-22 20:12 ` Federico Beffa
2015-03-26 13:09 ` Ludovic Courtès
0 siblings, 1 reply; 19+ messages in thread
From: Federico Beffa @ 2015-03-22 20:12 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Guix-devel
[-- Attachment #1: Type: text/plain, Size: 10260 bytes --]
ludo@gnu.org (Ludovic Courtès) writes:
> I would use ‘ghc-’ right from the start, since that’s really what it
> is. WDYT?
Agreed!
>> Obviously the tests in part 5 were used along the way and will be
>> removed.
>
> More precisely, they’ll have to be turned into tests/hackage.scm
> (similar to tests/snix.scm and tests/pypi.scm.) :-)
I've created a test for hackage. In doing so I've had an issue with the
locale and would like an advice: When I run "guix import hackage
package-name" from the shell, or when I invoke a REPL with Geiser
everything works fine. When I initially did run the test-suite with
make check TESTS=tests/hackage.scm
the conditionals conversion looked wrong. I've found that this is
related to the choice of locale. To make the test work as desired I
added '(setlocale LC_ALL "en_US.UTF-8")' to the file declaring the
tests.
I suppose that running the 'guix import ...' command does get the locale
from the shell. Should I somehow force the locale within the '(guix
import hackage)' module?
>> +;; List of libraries distributed with ghc (7.8.4).
>> +(define ghc-standard-libraries
>> + '("haskell98" ; 2.0.0.3
>> + "hoopl" ; 3.10.0.1
>
> Maybe the version numbers in comments can be omitted since they’ll
> become outdated eventually?
OK.
>> +(define guix-name-prefix "haskell-")
>
> s/guix-name-prefix/package-name-prefix/ and rather “ghc-” IMO.
Agreed.
>
>> +;; Regular expression matching "key: value"
>> +(define key-value-rx
>> + "([a-zA-Z0-9-]+): *(\\w?.*)$")
>> +
>> +;; Regular expression matching a section "head sub-head ..."
>> +(define sections-rx
>> + "([a-zA-Z0-9\\(\\)-]+)")
>> +
>> +;; Cabal comment.
>> +(define comment-rx
>> + "^ *--")
>
> Use (make-regexp ...) directly, and then ‘regexp-exec’ instead of
> ‘string-match’.
I already had in mind to change these before sending the e-mail, but I
forgot. It's now done.
>
>> +;; Check if the current line includes a key
>> +(define (has-key? line)
>> + (string-match key-value-rx line))
>> +
>> +(define (comment-line? line)
>> + (string-match comment-rx line))
>> +
>> +;; returns the number of indentation spaces and the rest of the line.
>> +(define (line-indentation+rest line)
>
> Please turn all the comments above procedures this into docstrings.
Done.
>
>> +;; Part 1 main function: read a cabal fila and filter empty lines and comments.
>> +;; Returns a list composed by the pre-processed lines of the file.
>> +(define (read-cabal port)
>
> s/fila/file/
> s/Returns/Return/
>
> I would expect ‘read-cabal’ to return a <cabal> record, say, that can be
> directly manipulated (just like ‘read’ returns a Scheme object.) But
> here it seems to return an intermediate parsing result, right?
OK. I've renamed some functions and the new name should hopefully be a
better choice. What was 'read-cabal' has become 'strip-cabal' (which only
strips comments and empty lines).
>> +;; Parses a cabal file in the form of a list of lines as produced by
>> +;; READ-CABAL and returns its content in the following form:
>> +;;
>> +;; (((head1 sub-head1 ... key1) (value))
>> +;; ((head2 sub-head2 ... key2) (value2))
>> +;; ...).
>> +;;
>> +;; where all elements are strings.
>> +;;
>> +;; We try do deduce the format from the following document:
>> +;; https://www.haskell.org/cabal/users-guide/developing-packages.html
>> +;;
>> +;; Key values are case-insensitive. We therefore lowercase them. Values are
>> +;; case-sensitive.
>> +;;
>> +;; Currently only only layout structured files are parsed. Braces {}
>
> “only indentation-structured files”
OK
>
>> +;; structured files are not handled.
>> +(define (cabal->key-values lines)
>
> I think this is the one I would call ‘read-cabal’.
>
... and I've followed you suggestion and renamed this function to 'read-cabal'.
>> +;; Find if a string represent a conditional
>> +(define condition-rx
>> + (make-regexp "^if +(.*)$"))
>
> The comment should rather be “Regexp for conditionals.” and be placed
> below ‘define’.
OK
> I would expect the conversion of conditional expressions to sexps to be
> done in the parsing phase above, such that ‘read-cabal’ returns an
> object with some sort of an AST for those conditionals.
>
> Then this part would focus on the evaluation of those conditionals,
> like:
>
> ;; Evaluate the conditionals in CABAL according to FLAGS. Return an
> ;; evaluated Cabal object.
> (eval-cabal cabal flags)
>
> WDYT?
I think it's better to keep the parsing phase to a bare minimum and work
with layers to keep each function as manageable and simple as possible.
The way it works is as follows:
1. 'strip-cabal' reads the file, strips comment and empty lines and
return a list. Each element of the list is a line from the Cabal file.
2. 'read-cabal' takes the above list and does the parsing required to
read the indentation based structure of the file. It returns a list
composed of list pairs. The pair is composed by a list of keys and a
list of values. For example, the following snippet
name: foo
version: 1.0
...
is returned as
((("name") ("foo"))
(("version") ("1.0"))
...)
This is enough for all the information that we need to build a Guix
package, but dependencies.
Dependencies are listed in 'Library' and 'Executable cabal' sections of
the Cabal file as in the following example snippet:
executable cabal
build-depends:
HTTP >= 4000.2.5 && < 4000.3
...
and may include conditionals as in (continuing from above with the
proper indentation)
if os(windows)
build-depends: Win32 >= 2 && < 3
else
build-depends: unix >= 2.0 && < 2.8
...
Now, to make sense of the indentation based structure I need to keep a
state indicating how many indentation levels we currently have and the
name of the various sub-sections. For this reason I keep a one to one
correspondence between indentation levels and section titles. That means
that the above snipped is encoded as follows in my Cabal object:
((("executable cabal" "build-depends:") ("HTTP..."))
(("executable cabal" "if os(windows)" "build-depends:") ("Win32 ..."))
(("executable cabal" "else" "build-depends:") ("unix ..."))
...)
If I split 'if' from the predicate 'os(windows)' then the level of
indentation and the corresponding section header loose synchronization
(different length).
For this reason I only convert the predicates from Cabal syntax to
Scheme syntax when I take the list of dependencies and convert the list
in the form expected in a guix package.
I hope to have clarified the strategy.
>> +(define (guix-name name)
>
> Rather ‘hackage-name->package-name’?
OK
>> +;; Split the comma separated list of dependencies coming from the cabal file
>> +;; and return a list with inputs suitable for the GUIX package. Currently the
>> +;; version information is discarded.
>
> s/GUIX/Guix/
OK
>> +(define (split-dependencies ls)
>> + (define (split-at-comma d)
>> + (map
>> + (lambda (m)
>> + (let ((name (guix-name (match:substring m 1))))
>> + (list name (list 'unquote (string->symbol name)))))
>> + (list-matches dependencies-rx d)))
>
> I think it could use simply:
>
> (map string-trim-both
> (string-tokenize d (char-set-complement (char-set #\,))))
Actually, this wouldn't do. On top of splitting at commas, the function also
translates the name of the package from hackage-name to guix-name.
>> +;; Genrate an S-expression containing the list of dependencies. The generated
>
> “Generate”
Ouch... soo many typos :-(
>> +;; S-expressions may include conditionals as defined in the cabal file.
>> +;; During this process we discard the version information of the packages.
>> +(define (dependencies-cond->sexp meta)
>
> [...]
>
>> + (match (match:substring rx-result 1)
>> + ((? (cut member <>
>> + ;; GUIX names are all lower-case.
>> + (map (cut string-downcase <>)
>> + ghc-standard-libraries)))
>
> s/GUIX/Guix/
>
> I find it hard to read. Typically, I would introduce:
>
> (define (standard-library? name)
> (member name ghc-standard-libraries))
>
> and use it here (with the assumption that ‘ghc-standard-libraries’ is
> already lowercase.)
OK, I've followed your advice. I initially kept ghc-standard-libraries
capitalized as the original name, but it doesn't really make any sense.
>> +;; Run some tests
>> +
>> +;; (display (cabal->key-values
>> +;; (call-with-input-file "mtl.cabal" read-cabal)))
>> +;; (display (cabal->key-values
>> +;; (call-with-input-file "/home/beffa/tmp/cabal-install.cabal" read-cabal)))
>> +;; (display (get-flags (pre-process-entries-keys (cabal->key-values test-5))))
>> +;; (newline)
>> +;; (display (conditional->sexp-like test-cond-2))
>> +;; (newline)
>> +;; (display
>> +;; (eval-flags (conditional->sexp-like test-cond-6)
>> +;; (get-flags (pre-process-entries-keys (cabal->key-values test-6)))))
>> +;; (newline)
>> +;; (key->values (cabal->key-values test-1) "name")
>> +;; (newline)
>> +;; (key-start-end->entries (cabal->key-values test-4) "Library" "CC-Options")
>> +;; (newline)
>> +;; (eval-tests (conditional->sexp-like test-cond-6))
>
> This should definitely go to tests/hackage.scm.
As mentioned above, I've created a test-suite for the hackage and added
a couple of thests.
>
>> + (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
>
> s/GUIX/Guix/
OK
> Also, guix/scripts/import.scm must be added to po/guix/POTFILES.in, for
> i18n.
OK, I've added it.
Thanks for the review!
Fede
[-- Attachment #2: 0001-import-Add-hackage-importer.patch --]
[-- Type: text/x-diff, Size: 746 bytes --]
From 231ea64519505f84e252a4b3ab14d3857a9374c2 Mon Sep 17 00:00:00 2001
From: Federico Beffa <beffa@fbengineering.ch>
Date: Sat, 7 Mar 2015 17:23:14 +0100
Subject: [PATCH 1/5] import: Add hackage importer.
* guix/scripts/import.scm (importers): Add hackage.
---
guix/scripts/import.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
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
--
2.2.1
[-- Attachment #3: 0002-import-Add-hackage-importer.patch --]
[-- Type: text/x-diff, Size: 3968 bytes --]
From ad79b3b0bc8b08ec98f49b665b32ce9259516713 Mon Sep 17 00:00:00 2001
From: Federico Beffa <beffa@fbengineering.ch>
Date: Sat, 7 Mar 2015 17:30:17 +0100
Subject: [PATCH 2/5] import: Add hackage importer.
* guix/scripts/import/hackage.scm: New file.
---
guix/scripts/import/hackage.scm | 96 +++++++++++++++++++++++++++++++++++++++++
1 file changed, 96 insertions(+)
create mode 100644 guix/scripts/import/hackage.scm
diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm
new file mode 100644
index 0000000..9b2b9e5
--- /dev/null
+++ b/guix/scripts/import/hackage.scm
@@ -0,0 +1,96 @@
+;;; 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
+ '())
+
+(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 (_ "
+ -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")))
+ %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)))
+ (unless sexp
+ (leave (_ "failed to download cabal file for package '~a'~%")
+ package-name))
+ sexp))
+ (()
+ (leave (_ "too few arguments~%")))
+ ((many ...)
+ (leave (_ "too many arguments~%"))))))
--
2.2.1
[-- Attachment #4: 0003-import-Add-hackage-importer.patch --]
[-- Type: text/x-diff, Size: 31433 bytes --]
From 447c6b8f1ee6cc1d4edba44cabef1b28b75c7608 Mon Sep 17 00:00:00 2001
From: Federico Beffa <beffa@fbengineering.ch>
Date: Sun, 8 Mar 2015 07:48:38 +0100
Subject: [PATCH 3/5] import: Add hackage importer.
* guix/import/hackage.scm: New file.
---
guix/import/hackage.scm | 787 ++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 787 insertions(+)
create mode 100644 guix/import/hackage.scm
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
new file mode 100644
index 0000000..5f2f46e
--- /dev/null
+++ b/guix/import/hackage.scm
@@ -0,0 +1,787 @@
+;;; 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-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))
+
+;; (use-modules (ice-9 match))
+;; (use-modules (ice-9 regex))
+;; (use-modules (ice-9 rdelim))
+;; (use-modules (ice-9 receive))
+;; (use-modules (ice-9 pretty-print))
+;; (use-modules (srfi srfi-26))
+;; (use-modules (srfi srfi-11))
+;; (use-modules (srfi srfi-1))
+
+;; Part 1:
+;;
+;; Functions used to read a Cabal file and do some pre-processing: discarding
+;; comments and empty lines.
+
+(define ghc-standard-libraries
+ ;; List of libraries distributed with ghc (7.8.4).
+ '("haskell98"
+ "hoopl"
+ "base"
+ "transformers"
+ "deepseq"
+ "array"
+ "binary"
+ "bytestring"
+ "containers"
+ "time"
+ "cabal"
+ "bin-package-db"
+ "ghc-prim"
+ "integer-gmp"
+ "win32"
+ "template-haskell"
+ "process"
+ "haskeline"
+ "terminfo"
+ "directory"
+ "filepath"
+ "old-locale"
+ "unix"
+ "old-time"
+ "pretty"
+ "xhtml"
+ "hpc"))
+
+;; Libraries present in the "Haskell Platform" 2014.2.0 and not included in
+;; the GHC standard libraries:
+;;
+;; "zlib" ; 0.5.4.1
+;; "async" ; 2.0.1.5
+;; "stm" ; 2.4.2
+;; "mtl" ; 2.1.3.1
+;; "primitive" ; 0.5.2.1
+;; "parallel" ; 3.2.0.4
+;; "attoparsec" ; 0.10.4.0
+;; "case-insensitive" ; 1.1.0.3
+;; "syb" ; 0.4.1
+;; "containers" ; 0.5.5.1
+;; "fgl" ; 5.5.0.1
+;; "unordered-containers" ; 0.2.3.3
+;; "hashable" ; 1.2.1.0
+;; "split" ; 0.2.2
+;; "text" ; 1.1.0.0
+;; "vector" ; 0.10.9.1
+;; "GLURaw" ; 1.4.0.1
+;; "OpenGL" ; 2.9.2.0
+;; "OpenGLRaw" ; 1.5.0.0
+;; "GLUT" ; 2.5.1.1
+;; "haskell-src" ; 1.0.1.6
+;; "network" ; 2.4.2.2
+;; "HTTP" ; 4000.2.10
+;; "random" ; 1.0.1.1
+;; "HUnit" ; 1.2.5.2
+;; "QuickCheck" ; 2.6
+;; "html" ; 1.0.1.2
+;; "parsec" ; 3.1.5
+;; "regex-compat" ; 0.95.1
+;; "regex-base" ; 0.93.2
+;; "regex-posix" ; 0.95.2
+
+(define package-name-prefix "ghc-")
+
+(define key-value-rx
+ ;; Regular expression matching "key: value"
+ (make-regexp "([a-zA-Z0-9-]+): *(\\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))
+ (if (or (null? line-lst) (not (eqv? (first line-lst) #\space)))
+ (values count (list->string line-lst))
+ (loop (cdr line-lst) (+ count 1)))))
+
+(define (strip-cabal port)
+ "Read a Cabal file from PORT and filter empty and comment lines.
+Return a list composed by the remaining lines of the file."
+ (let loop ((line (read-line port))
+ (result '()))
+ (cond
+ ((eof-object? line)
+ (reverse result))
+ ((or (string-null? line) (comment-line? line))
+ (loop (read-line port) result))
+ (else
+ (loop (read-line port) (cons line result))))))
+
+;; Part 2:
+;;
+;; Take the result of part 1 and convert the content of the file in a list of
+;; list pairs, where the first list of the pair includes keys while the second
+;; is a list of values.
+
+(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."
+ (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 current-indent)
+ (regexp-exec condition-rx next-line-value))
+ (values (reverse (cons value seed)) (cdr lines))
+ (multi-line-value (cdr lines) (cons value seed))))))
+
+(define (read-cabal lines)
+ "Parses a Cabal file. LINES is a list with each element being a line of a
+Cabal file, as produced by STRIP-CABAL. 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.
+ (let loop
+ ((lines lines)
+ (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 (+ (list-index
+ (lambda (x) (= next-line-indent x))
+ indents)
+ (if (has-key? next-line) 1 0)))
+ (sec (drop sections idx))
+ (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 3:
+;;
+;; Functions to read information from the Cabal object created by 'read-cabal'
+;; and process dependencies conditionals.
+
+(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-like-cond)
+ "In the string SEXP-LIKE-COND substitute test keywords \"os(...)\" and
+\"arch(...)\" with strings representing Scheme functions performing equivalent
+checks."
+ (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 " \"" 1 "-" 3 "\" " post-match '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 (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 key-end)
+ "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)
+ (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 key-end)))
+ (((k v) r ...)
+ (key-start-end->entries (cdr meta) key-start key-end))
+ (_ "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-dependencies ls)
+ "Split the comma separated list of dependencies LS coming from the Cabal
+file and return a list with inputs suitable for the Guix package. Currently
+the version information is discarded."
+ (define (split-at-comma d)
+ (map
+ (lambda (m)
+ (let ((name (hackage-name->package-name (match:substring m 1))))
+ (list name (list 'unquote (string->symbol name)))))
+ (list-matches dependencies-rx d)))
+
+ (fold (lambda (d p) (append (split-at-comma d) p)) '() ls))
+
+(define (dependencies-cond->sexp meta)
+ "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 "executable cabal")
+ (key-start-lib "library")
+ (key-end "build-depends"))
+ (append
+ (key-start-end->entries meta key-start-exe key-end)
+ (key-start-end->entries meta key-start-lib key-end))))
+
+ (let ((flags (get-flags (pre-process-entries-keys meta))))
+ (delete-duplicates
+ (let loop ((entries (take-dependencies meta))
+ (result '()))
+ (if (null? entries)
+ 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-dependencies vals) result)))
+ (else
+ (let-values (((true-group false-group entries)
+ (group-and-reduce-level entries '()
+ key-cond))
+ ((cond-final) (eval-tests
+ (eval-impl
+ (eval-flags
+ (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
+ (cons `(unquote-splicing
+ (if ,cond-final
+ ,(loop true-group '())
+ ,(loop false-group '())))
+ result)))))))))))))
+
+(define (standard-library? name)
+ (member name ghc-standard-libraries))
+
+(define (filter-standard-libraries ls)
+ "Filter from list of inputs LS the libraries already included with the
+Haskell compiler. Currently we imply the use of GHC."
+ (let ((real-name-rx (make-regexp
+ (string-append package-name-prefix "(\\w+)"))))
+ (fold (lambda (elem seed)
+ (if (eq? (first elem) 'unquote-splicing)
+ (let*-values (((group-cond true-group false-group)
+ (match (second elem)
+ ((if c t f )
+ (values c t f))
+ (_ (values c '() '()))))
+ ((filtered-true-group)
+ (filter-standard-libraries true-group))
+ ((filtered-false-group)
+ (filter-standard-libraries false-group)))
+ (cond
+ ((and (null? filtered-false-group)
+ (null? filtered-true-group))
+ seed)
+ ((null? filtered-false-group)
+ (cons (list 'unquote-splicing
+ (list 'if group-cond
+ filtered-true-group))
+ seed))
+ (else
+ (cons (list 'unquote-splicing
+ (list 'if group-cond
+ filtered-true-group
+ filtered-false-group))
+ seed))))
+ (let ((rx-result (regexp-exec real-name-rx (first elem))))
+ (match (match:substring rx-result 1)
+ ((? standard-library?)
+ seed)
+ (_
+ (cons elem seed))))))
+ '() ls)))
+
+;; Part 4:
+;;
+;; 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")))
+ ((cabal)
+ (call-with-temporary-output-file
+ (lambda (temp port)
+ (and (url-fetch url temp)
+ (call-with-input-file temp strip-cabal))))))
+ (and=> cabal 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)
+ "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"))
+
+ (define (maybe-inputs hackage-name->package-name inputs)
+ (match (filter-standard-libraries inputs)
+ (()
+ '())
+ ((inputs ...)
+ (list (list hackage-name->package-name
+ (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))
+ (home-page ,@(key->values meta "homepage"))
+ (synopsis ,@(key->values meta "synopsis"))
+ (description ,description)
+ (license ,(string->license (key->values meta "license"))))))
+
+(define (hackage->guix-package module-name)
+ "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 hackage-module->sexp)))
+
+;;; cabal.scm ends here
--
2.2.1
[-- Attachment #5: 0004-import-Add-to-list-of-files-with-translatable-string.patch --]
[-- Type: text/x-diff, Size: 724 bytes --]
From 157fadf158866beda08b0cad654583836a85a3e7 Mon Sep 17 00:00:00 2001
From: Federico Beffa <beffa@fbengineering.ch>
Date: Sun, 22 Mar 2015 13:30:24 +0100
Subject: [PATCH 4/5] import: Add to list of files with translatable strings.
* po/guix/POTFILES.in: Add guix/scripts/import.scm.
---
po/guix/POTFILES.in | 1 +
1 file changed, 1 insertion(+)
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 #6: 0005-tests-Add-tests-for-the-hackage-importer.patch --]
[-- Type: text/x-diff, Size: 3820 bytes --]
From 631cc5e8ca07143d2d30984e5f4a12159ae45d58 Mon Sep 17 00:00:00 2001
From: Federico Beffa <beffa@fbengineering.ch>
Date: Sun, 22 Mar 2015 19:51:30 +0100
Subject: [PATCH 5/5] tests: Add tests for the hackage importer.
* tests/hackage.scm: New file.
---
tests/hackage.scm | 114 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 114 insertions(+)
create mode 100644 tests/hackage.scm
diff --git a/tests/hackage.scm b/tests/hackage.scm
new file mode 100644
index 0000000..13cbbe5
--- /dev/null
+++ b/tests/hackage.scm
@@ -0,0 +1,114 @@
+;;; 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))
+
+(setlocale LC_ALL "en_US.UTF-8")
+
+(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
+")
+
+(define test-cond-1
+ "(os(darwin) || !(flag(debug))) && flag(cips)")
+
+(define read-cabal
+ (@@ (guix import hackage) read-cabal))
+
+(define strip-cabal
+ (@@ (guix import hackage) strip-cabal))
+
+(define eval-tests
+ (@@ (guix import hackage) eval-tests))
+
+(define eval-impl
+ (@@ (guix import hackage) eval-impl))
+
+(define eval-flags
+ (@@ (guix import hackage) eval-flags))
+
+(define conditional->sexp-like
+ (@@ (guix import hackage) conditional->sexp-like))
+
+(test-begin "hackage")
+
+(test-assert "hackage->guix-package"
+ ;; Replace network resources with sample data.
+ (mock
+ ((guix import hackage) hackage-fetch
+ (lambda (name-version)
+ (read-cabal
+ (call-with-input-string test-cabal-1
+ strip-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 "conditional->sexp-like"
+ (match
+ (eval-tests
+ (eval-impl
+ (eval-flags
+ (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
^ permalink raw reply related [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-03-22 20:12 ` Federico Beffa
@ 2015-03-26 13:09 ` Ludovic Courtès
2015-03-28 8:53 ` Federico Beffa
0 siblings, 1 reply; 19+ messages in thread
From: Ludovic Courtès @ 2015-03-26 13:09 UTC (permalink / raw)
To: Federico Beffa; +Cc: Guix-devel
Federico Beffa <beffa@ieee.org> skribis:
> I've created a test for hackage. In doing so I've had an issue with the
> locale and would like an advice: When I run "guix import hackage
> package-name" from the shell, or when I invoke a REPL with Geiser
> everything works fine. When I initially did run the test-suite with
>
> make check TESTS=tests/hackage.scm
>
> the conditionals conversion looked wrong. I've found that this is
> related to the choice of locale. To make the test work as desired I
> added '(setlocale LC_ALL "en_US.UTF-8")' to the file declaring the
> tests.
What’s the exact error you were getting? Character classes in regexps
are locale sensitive, I think, which could be one reason things behave
differently. There’s also the problem that, when running in the C
locale, ‘regexp-exec’ (and other C-implemented procedures) cannot be
passed any string that is not strictly ASCII.
Could you post the actual backtrace you get (?) when running the program
with LC_ALL=C?
[...]
>> I would expect the conversion of conditional expressions to sexps to be
>> done in the parsing phase above, such that ‘read-cabal’ returns an
>> object with some sort of an AST for those conditionals.
>>
>> Then this part would focus on the evaluation of those conditionals,
>> like:
>>
>> ;; Evaluate the conditionals in CABAL according to FLAGS. Return an
>> ;; evaluated Cabal object.
>> (eval-cabal cabal flags)
>>
>> WDYT?
>
> I think it's better to keep the parsing phase to a bare minimum and work
> with layers to keep each function as manageable and simple as possible.
>
> The way it works is as follows:
>
> 1. 'strip-cabal' reads the file, strips comment and empty lines and
> return a list. Each element of the list is a line from the Cabal file.
>
> 2. 'read-cabal' takes the above list and does the parsing required to
> read the indentation based structure of the file. It returns a list
> composed of list pairs. The pair is composed by a list of keys and a
> list of values. For example, the following snippet
>
> name: foo
> version: 1.0
> ...
>
> is returned as
>
> ((("name") ("foo"))
> (("version") ("1.0"))
> ...)
OK. I would rather have ‘read-cabal’ take an input port (like Scheme’s
‘read’) and return the list above; this would be the least surprising,
more idiomatic approach. ‘strip-cabal’ (or
‘strip-insignificant-lines’?) would be an internal procedure used only
by ‘read-cabal’.
WDYT?
> This is enough for all the information that we need to build a Guix
> package, but dependencies.
>
> Dependencies are listed in 'Library' and 'Executable cabal' sections of
> the Cabal file as in the following example snippet:
>
> executable cabal
> build-depends:
> HTTP >= 4000.2.5 && < 4000.3
> ...
>
> and may include conditionals as in (continuing from above with the
> proper indentation)
>
> if os(windows)
> build-depends: Win32 >= 2 && < 3
> else
> build-depends: unix >= 2.0 && < 2.8
> ...
>
> Now, to make sense of the indentation based structure I need to keep a
> state indicating how many indentation levels we currently have and the
> name of the various sub-sections. For this reason I keep a one to one
> correspondence between indentation levels and section titles. That means
> that the above snipped is encoded as follows in my Cabal object:
>
> ((("executable cabal" "build-depends:") ("HTTP..."))
> (("executable cabal" "if os(windows)" "build-depends:") ("Win32 ..."))
> (("executable cabal" "else" "build-depends:") ("unix ..."))
> ...)
>
> If I split 'if' from the predicate 'os(windows)' then the level of
> indentation and the corresponding section header loose synchronization
> (different length).
Would it be possible for ‘read-cabal’ to instead return a
tree-structured sexp like:
(if (os windows)
(build-depends (Win32 >= 2 && < 3))
(build-depends (unix >= 2.0 && < 2.8)))
That would use a variant of ‘conditional->sexp-like’, essentially.
(Of course the achieve that the parser must keep track of indentation
levels and everything, as you already implemented; I’m just commenting
on the interface here.)
Then, if I could imagine:
(eval-cabal '(("name" "foo")
("version" "1.0"
("executable cabal" (if (os windows) ...)))
=> #<cabal-package name: "foo" dependencies: '(unix)>
This way the structure of the Cabal file would be preserved, only
converted to sexp form, which is easier to work with.
Does that make sense?
> For this reason I only convert the predicates from Cabal syntax to
> Scheme syntax when I take the list of dependencies and convert the list
> in the form expected in a guix package.
>
> I hope to have clarified the strategy.
>
>>> +(define (guix-name name)
>>
>> Rather ‘hackage-name->package-name’?
>
> OK
>
>>> +;; Split the comma separated list of dependencies coming from the cabal file
>>> +;; and return a list with inputs suitable for the GUIX package. Currently the
>>> +;; version information is discarded.
>>
>> s/GUIX/Guix/
>
> OK
>
>>> +(define (split-dependencies ls)
>>> + (define (split-at-comma d)
>>> + (map
>>> + (lambda (m)
>>> + (let ((name (guix-name (match:substring m 1))))
>>> + (list name (list 'unquote (string->symbol name)))))
>>> + (list-matches dependencies-rx d)))
>>
>> I think it could use simply:
>>
>> (map string-trim-both
>> (string-tokenize d (char-set-complement (char-set #\,))))
>
> Actually, this wouldn't do. On top of splitting at commas, the function also
> translates the name of the package from hackage-name to guix-name.
Right, but then it’s best to have two separate procedures and two
compose them:
(map (compose hackage-name->package-name string-trim-both)
(string-tokenize d (char-set-complement (char-set #\,))))
> From 231ea64519505f84e252a4b3ab14d3857a9374c2 Mon Sep 17 00:00:00 2001
> From: Federico Beffa <beffa@fbengineering.ch>
> Date: Sat, 7 Mar 2015 17:23:14 +0100
> Subject: [PATCH 1/5] import: Add hackage importer.
>
> * guix/scripts/import.scm (importers): Add hackage.
[...]
> From ad79b3b0bc8b08ec98f49b665b32ce9259516713 Mon Sep 17 00:00:00 2001
> From: Federico Beffa <beffa@fbengineering.ch>
> Date: Sat, 7 Mar 2015 17:30:17 +0100
> Subject: [PATCH 2/5] import: Add hackage importer.
>
> * guix/scripts/import/hackage.scm: New file.
These two should be one patch, along with the modification of
POTFILES.in, because these 3 things correspond to a single logical
change–the addition of a sub-command and associated infrastructure. A
fourth part is also needed: the addition of a couple of paragraphs in
guix.texi.
> From 447c6b8f1ee6cc1d4edba44cabef1b28b75c7608 Mon Sep 17 00:00:00 2001
> From: Federico Beffa <beffa@fbengineering.ch>
> Date: Sun, 8 Mar 2015 07:48:38 +0100
> Subject: [PATCH 3/5] import: Add hackage importer.
>
> * guix/import/hackage.scm: New file.
Please add tests/hackage.test as part of the same patch.
> +;; (use-modules (ice-9 match))
> +;; (use-modules (ice-9 regex))
> +;; (use-modules (ice-9 rdelim))
> +;; (use-modules (ice-9 receive))
> +;; (use-modules (ice-9 pretty-print))
> +;; (use-modules (srfi srfi-26))
> +;; (use-modules (srfi srfi-11))
> +;; (use-modules (srfi srfi-1))
Debugging leftover?
Nothing to add to what I wrote above.
[...]
> +(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
> +")
> +
> +(define test-cond-1
> + "(os(darwin) || !(flag(debug))) && flag(cips)")
> +
> +(define read-cabal
> + (@@ (guix import hackage) read-cabal))
> +
> +(define strip-cabal
> + (@@ (guix import hackage) strip-cabal))
> +
> +(define eval-tests
> + (@@ (guix import hackage) eval-tests))
> +
> +(define eval-impl
> + (@@ (guix import hackage) eval-impl))
> +
> +(define eval-flags
> + (@@ (guix import hackage) eval-flags))
> +
> +(define conditional->sexp-like
> + (@@ (guix import hackage) conditional->sexp-like))
I think it would be fine to export ‘read-cabal’ and ‘eval-cabal’ once
these two have the desired interface.
> +(test-begin "hackage")
> +
> +(test-assert "hackage->guix-package"
> + ;; Replace network resources with sample data.
> + (mock
> + ((guix import hackage) hackage-fetch
> + (lambda (name-version)
> + (read-cabal
> + (call-with-input-string test-cabal-1
> + strip-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)
Nice.
With the adjusted semantics, there could be lower-level tests:
(test-equal "read-cabal"
'(("name" "foo") ...)
(call-with-input-string test-cabal-1 read-cabal))
and:
(test-assert "eval-cabal, conditions"
(let ((p (eval-cabal '(("name" "foo")
("executable cabal" (if (os windows) ...))))))
(and (cabal-package? p)
(string=? "foo" (cabal-package-name p))
(equal? '(unix) (cabal-package-dependencies p)))))
Looks like we’re almost there. I hope the above makes sense!
Thank you,
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-03-26 13:09 ` Ludovic Courtès
@ 2015-03-28 8:53 ` Federico Beffa
2015-03-29 13:58 ` Ludovic Courtès
0 siblings, 1 reply; 19+ messages in thread
From: Federico Beffa @ 2015-03-28 8:53 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Guix-devel
On Thu, Mar 26, 2015 at 2:09 PM, Ludovic Courtès <ludo@gnu.org> wrote:
> Could you post the actual backtrace you get (?) when running the program
> with LC_ALL=C?
I doesn't backtrace, the function just gives the wrong result. I think
the problem was caused by the character § that I did introduce to mark
some cabal test keywords. I've now changed character and the problem
seems to be solved.
>
> [...]
>
>>> I would expect the conversion of conditional expressions to sexps to be
>>> done in the parsing phase above, such that ‘read-cabal’ returns an
>>> object with some sort of an AST for those conditionals.
>>>
>>> Then this part would focus on the evaluation of those conditionals,
>>> like:
>>>
>>> ;; Evaluate the conditionals in CABAL according to FLAGS. Return an
>>> ;; evaluated Cabal object.
>>> (eval-cabal cabal flags)
>>>
>>> WDYT?
I'm not sure this can be done, because flags must be declared in the
cabal file itself and the manual is not clear if the flags are
required to be declared before they are used or not (although it would
make sense).
https://www.haskell.org/cabal/users-guide/developing-packages.html#configurations
[...]
> Looks like we’re almost there. I hope the above makes sense!
To see how this importer (and the haskell-build-system that I've
posted) performs I've now used it with several libraries (for the
moment I've packaged 26 libraries). While it runs nicely with most of
them, a couple posed problems resulting in package definitions with
some fields empty and 1 caused a backtrace. (Once I fixed the package
manually, the build-system worked fine for all of them.)
Before working further on improving the interface, I want first to
understand what are the root causes of the errors (especially the one
causing the backtrace) and fix them.
Thanks for all your comments! I think they make sense to me and will
try to accommodate them.
Regards,
Fede
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-03-28 8:53 ` Federico Beffa
@ 2015-03-29 13:58 ` Ludovic Courtès
2015-03-29 16:55 ` Federico Beffa
0 siblings, 1 reply; 19+ messages in thread
From: Ludovic Courtès @ 2015-03-29 13:58 UTC (permalink / raw)
To: Federico Beffa; +Cc: Guix-devel
Federico Beffa <beffa@ieee.org> skribis:
> On Thu, Mar 26, 2015 at 2:09 PM, Ludovic Courtès <ludo@gnu.org> wrote:
>> Could you post the actual backtrace you get (?) when running the program
>> with LC_ALL=C?
>
> I doesn't backtrace, the function just gives the wrong result.
Hmm, OK. Still sounds like an encoding error.
>>>> I would expect the conversion of conditional expressions to sexps to be
>>>> done in the parsing phase above, such that ‘read-cabal’ returns an
>>>> object with some sort of an AST for those conditionals.
>>>>
>>>> Then this part would focus on the evaluation of those conditionals,
>>>> like:
>>>>
>>>> ;; Evaluate the conditionals in CABAL according to FLAGS. Return an
>>>> ;; evaluated Cabal object.
>>>> (eval-cabal cabal flags)
>>>>
>>>> WDYT?
>
> I'm not sure this can be done, because flags must be declared in the
> cabal file itself and the manual is not clear if the flags are
> required to be declared before they are used or not (although it would
> make sense).
By ‘flags’ I actually meant things like ‘unix’, which appear in
conditionals:
(eval-cabal cabal '(unix))
> To see how this importer (and the haskell-build-system that I've
> posted) performs I've now used it with several libraries (for the
> moment I've packaged 26 libraries). While it runs nicely with most of
> them, a couple posed problems resulting in package definitions with
> some fields empty and 1 caused a backtrace. (Once I fixed the package
> manually, the build-system worked fine for all of them.)
>
> Before working further on improving the interface, I want first to
> understand what are the root causes of the errors (especially the one
> causing the backtrace) and fix them.
Sounds good, thanks!
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-03-29 13:58 ` Ludovic Courtès
@ 2015-03-29 16:55 ` Federico Beffa
2015-03-31 13:33 ` Ludovic Courtès
0 siblings, 1 reply; 19+ messages in thread
From: Federico Beffa @ 2015-03-29 16:55 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Guix-devel
On Sun, Mar 29, 2015 at 3:58 PM, Ludovic Courtès <ludo@gnu.org> wrote:
>> On Thu, Mar 26, 2015 at 2:09 PM, Ludovic Courtès <ludo@gnu.org> wrote:
>>> Could you post the actual backtrace you get (?) when running the program
>>> with LC_ALL=C?
>>
>> I doesn't backtrace, the function just gives the wrong result.
>
> Hmm, OK. Still sounds like an encoding error.
After changing the character that I mentioned in the previous email it
works correctly with LC_ALL=C.
>> Before working further on improving the interface, I want first to
>> understand what are the root causes of the errors (especially the one
>> causing the backtrace) and fix them.
The problems turned out to be related to:
* the use of TABs in some .cabal files. I've now updated a couple of regexp.
* The following odd indentation which confused the parsing (this is
the one which caused the backtrace):
build-depends:
base >= 4.3 && < 4.9
, bytestring
, filepath
...
I've now improved the algorithm which can now handle this odd indentation.
I've now tested the importer with ca. 40 packages and (I believe) they
are all handled without errors.
> OK. I would rather have ‘read-cabal’ take an input port (like Scheme’s
> ‘read’) and return the list above; this would be the least surprising,
> more idiomatic approach. ‘strip-cabal’ (or
> ‘strip-insignificant-lines’?) would be an internal procedure used only
> by ‘read-cabal’.
That's no problem. The way it is right now makes it easier to test in
the REPL, but is in no way essential.
> Would it be possible for ‘read-cabal’ to instead return a
> tree-structured sexp like:
>
> (if (os windows)
> (build-depends (Win32 >= 2 && < 3))
> (build-depends (unix >= 2.0 && < 2.8)))
>
> That would use a variant of ‘conditional->sexp-like’, essentially.
>
> (Of course the achieve that the parser must keep track of indentation
> levels and everything, as you already implemented; I’m just commenting
> on the interface here.)
>
> Then, if I could imagine:
>
> (eval-cabal '(("name" "foo")
> ("version" "1.0"
> ("executable cabal" (if (os windows) ...)))
> => #<cabal-package name: "foo" dependencies: '(unix)>
>
> This way the structure of the Cabal file would be preserved, only
> converted to sexp form, which is easier to work with.
>
> Does that make sense?
To be honest, I'm not sure I understand what you would like to achieve.
'read-cabal' returns an object and, according to your proposal, you
would like a function '(eval-cabal object)' returning a package. In
the code that is exactly what '(hackage-module->sexp object)' does. Is
it a matter of naming? (I've taken names from the python and perl
build systems, but of course I can change them if desired.)
To the representation of object:
Right now 'read-cabal' is fairly simple and easy to read and debug.
Some complexity for the evaluation of conditionals is postponed and
handled by the function '(dependencies-cond->sexp object)' which is
used internally by '(hackage-module->sexp object)' to create the
package.
As far as I understand, you would like 'read-cabal' to directly
evaluate conditionals. To achieve that, essentially all of the
functionality of '(dependencies-cond->sexp object)' would have to be
included in it, making 'read-cabal' a substantially more complex
function and simplifying the work of "later" functions. So, as I see
it, we would just move the complexity from one function to another
one.
In addition, with the current approach within
'(dependencies-cond->sexp object)': (i) I can easily discard
everything not related to depencendies before handling the
conditionals of interest. (ii) I have all the cabal file flags, even
if they come after the conditional in the file.
If I'm completely missing the point, could you please be more verbose
with your explanation.
Thanks for your patience!
Regards,
Fede
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-03-29 16:55 ` Federico Beffa
@ 2015-03-31 13:33 ` Ludovic Courtès
2015-04-03 13:01 ` Federico Beffa
2015-04-26 11:38 ` Federico Beffa
0 siblings, 2 replies; 19+ messages in thread
From: Ludovic Courtès @ 2015-03-31 13:33 UTC (permalink / raw)
To: Federico Beffa; +Cc: Guix-devel
Federico Beffa <beffa@ieee.org> skribis:
> On Sun, Mar 29, 2015 at 3:58 PM, Ludovic Courtès <ludo@gnu.org> wrote:
>>> On Thu, Mar 26, 2015 at 2:09 PM, Ludovic Courtès <ludo@gnu.org> wrote:
>>>> Could you post the actual backtrace you get (?) when running the program
>>>> with LC_ALL=C?
>>>
>>> I doesn't backtrace, the function just gives the wrong result.
>>
>> Hmm, OK. Still sounds like an encoding error.
>
> After changing the character that I mentioned in the previous email it
> works correctly with LC_ALL=C.
Well, OK. We may still be doing something wrong wrt. encoding/decoding,
but I’m not sure what.
>>> Before working further on improving the interface, I want first to
>>> understand what are the root causes of the errors (especially the one
>>> causing the backtrace) and fix them.
>
> The problems turned out to be related to:
> * the use of TABs in some .cabal files. I've now updated a couple of regexp.
> * The following odd indentation which confused the parsing (this is
> the one which caused the backtrace):
>
> build-depends:
> base >= 4.3 && < 4.9
> , bytestring
> , filepath
> ...
>
> I've now improved the algorithm which can now handle this odd indentation.
Nice. TABs and odd indentation probably make good additional test cases
to have in tests/cabal.scm.
> I've now tested the importer with ca. 40 packages and (I believe) they
> are all handled without errors.
Woohoo!
>> Would it be possible for ‘read-cabal’ to instead return a
>> tree-structured sexp like:
>>
>> (if (os windows)
>> (build-depends (Win32 >= 2 && < 3))
>> (build-depends (unix >= 2.0 && < 2.8)))
>>
>> That would use a variant of ‘conditional->sexp-like’, essentially.
>>
>> (Of course the achieve that the parser must keep track of indentation
>> levels and everything, as you already implemented; I’m just commenting
>> on the interface here.)
>>
>> Then, if I could imagine:
>>
>> (eval-cabal '(("name" "foo")
>> ("version" "1.0"
>> ("executable cabal" (if (os windows) ...)))
>> => #<cabal-package name: "foo" dependencies: '(unix)>
>>
>> This way the structure of the Cabal file would be preserved, only
>> converted to sexp form, which is easier to work with.
>>
>> Does that make sense?
>
> To be honest, I'm not sure I understand what you would like to achieve.
It’s really just about the architecture and layers of code.
> 'read-cabal' returns an object and, according to your proposal, you
> would like a function '(eval-cabal object)' returning a package. In
> the code that is exactly what '(hackage-module->sexp object)' does. Is
> it a matter of naming? (I've taken names from the python and perl
> build systems, but of course I can change them if desired.)
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.
> Right now 'read-cabal' is fairly simple and easy to read and debug.
> Some complexity for the evaluation of conditionals is postponed and
> handled by the function '(dependencies-cond->sexp object)' which is
> used internally by '(hackage-module->sexp object)' to create the
> package.
>
> As far as I understand, you would like 'read-cabal' to directly
> evaluate conditionals.
No, precisely not. I’m saying ‘read-cabal’ should include an AST of
conditionals; that AST would be evaluated by ‘eval-cabal’.
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?
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-03-31 13:33 ` Ludovic Courtès
@ 2015-04-03 13:01 ` Federico Beffa
2015-04-05 18:24 ` Ludovic Courtès
2015-04-26 11:38 ` Federico Beffa
1 sibling, 1 reply; 19+ messages in thread
From: Federico Beffa @ 2015-04-03 13:01 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Guix-devel
[-- 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
^ permalink raw reply related [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-04-03 13:01 ` Federico Beffa
@ 2015-04-05 18:24 ` Ludovic Courtès
0 siblings, 0 replies; 19+ messages in thread
From: Ludovic Courtès @ 2015-04-05 18:24 UTC (permalink / raw)
To: Federico Beffa; +Cc: Guix-devel
Federico Beffa <beffa@ieee.org> skribis:
> 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 :-)
You’re right, of course ;-), but thinking in terms of separate libraries
can help structure the code IMO.
>> 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.
Sounds good!
> 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.
OK.
> 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.
[...]
> +The command below imports meta-data for latest version of the
^^^
+ “the”
> 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.
Perfect!
OK to push these two.
Thanks for your patience and for the great work!
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-03-31 13:33 ` Ludovic Courtès
2015-04-03 13:01 ` Federico Beffa
@ 2015-04-26 11:38 ` Federico Beffa
2015-05-02 12:48 ` Ludovic Courtès
1 sibling, 1 reply; 19+ messages in thread
From: Federico Beffa @ 2015-04-26 11:38 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Guix-devel
[-- Attachment #1: Type: text/plain, Size: 852 bytes --]
On Tue, Mar 31, 2015 at 3:33 PM, Ludovic Courtès <ludo@gnu.org> wrote:
> 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.
Please find attached a patch reorganizing the code as you suggest.
Regards,
Fede
[-- Attachment #2: 0001-import-hackage-Refactor-parsing-code-and-add-new-opt.patch --]
[-- Type: text/x-diff, Size: 79965 bytes --]
From bc8cdab1e322a25002a3d9cf33eddd856c8a81d8 Mon Sep 17 00:00:00 2001
From: Federico Beffa <beffa@fbengineering.ch>
Date: Sun, 26 Apr 2015 11:22:29 +0200
Subject: [PATCH] import: hackage: Refactor parsing code and add new option.
* guix/import/cabal.scm: New file.
* guix/import/hackage.scm: Update to use the new Cabal parsing module.
* tests/hackage.scm: Update tests for private functions.
* guix/scripts/import/hackage.scm: Add new '--cabal-environment' option.
* doc/guix.texi: ... and document it.
* Makefile.am (MODULES): Add 'guix/import/cabal.scm',
'guix/import/hackage.scm' and 'guix/scripts/import/hackage.scm'.
(SCM_TESTS): Add 'tests/hackage.scm'.
---
Makefile.am | 4 +
doc/guix.texi | 17 +-
guix/import/cabal.scm | 902 ++++++++++++++++++++++++++++++++++++++++
guix/import/hackage.scm | 691 ++++--------------------------
guix/scripts/import/hackage.scm | 14 +-
tests/hackage.scm | 18 +-
6 files changed, 1009 insertions(+), 637 deletions(-)
create mode 100644 guix/import/cabal.scm
diff --git a/Makefile.am b/Makefile.am
index d54e281..b42a7f5 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -89,6 +89,8 @@ MODULES = \
guix/import/utils.scm \
guix/import/gnu.scm \
guix/import/snix.scm \
+ guix/import/cabal.scm \
+ guix/import/hackage.scm \
guix/scripts/download.scm \
guix/scripts/build.scm \
guix/scripts/archive.scm \
@@ -104,6 +106,7 @@ MODULES = \
guix/scripts/lint.scm \
guix/scripts/import/gnu.scm \
guix/scripts/import/nix.scm \
+ guix/scripts/import/hackage.scm \
guix/scripts/environment.scm \
guix/scripts/publish.scm \
guix.scm \
@@ -173,6 +176,7 @@ SCM_TESTS = \
tests/build-utils.scm \
tests/packages.scm \
tests/snix.scm \
+ tests/hackage.scm \
tests/store.scm \
tests/monads.scm \
tests/gexp.scm \
diff --git a/doc/guix.texi b/doc/guix.texi
index 70604b7..453e71f 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3201,14 +3201,25 @@ Specific command-line options are:
@table @code
@item --no-test-dependencies
@itemx -t
-Do not include dependencies only required to run the test suite.
+Do not include dependencies only required to run the test suites.
+@item --cabal-environment=@var{alist}
+@itemx -e @var{alist}
+@var{alist} is a Scheme alist defining the environment in which the
+Cabal conditionals are evaluated. The accepted keys are: @samp{os},
+@samp{arch}, @samp{impl} and a string representing the name of a flag.
+The value associated with a flag has to be either the symbol
+@verb{'true'} or @verb{'false'}. The value associated with other keys
+has to conform to the Cabal file format definition. The default value
+associated with the keys @samp{os}, @samp{arch} and @samp{impl} is
+@samp{linux}, @samp{x86_64} and @samp{ghc} respectively.
@end table
The command below imports meta-data for the latest version of the
-@code{HTTP} Haskell package without including test dependencies:
+@code{HTTP} Haskell package without including test dependencies and
+specifying the value of the flag @samp{network-uri} as @verb{'false'}:
@example
-guix import hackage -t HTTP
+guix import hackage -t -e "'((\"network-uri\" . false))" HTTP
@end example
A specific package version may optionally be specified by following the
diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
new file mode 100644
index 0000000..fd4bbd6
--- /dev/null
+++ b/guix/import/cabal.scm
@@ -0,0 +1,902 @@
+;;; 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 (guix monads)
+ #:export (read-cabal
+ parse-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.
+
+;; This record stores the state information needed during parsing of Cabal
+;; files.
+(define-record-type <cabal-parse-state>
+ (make-cabal-parse-state lines minimum-indent indents conditionals
+ true-group? true-group false-group
+ true-group?-stack true-group-stack false-group-stack)
+ cabal-parse-state?
+ (lines cabal-parse-state-lines)
+ (minimum-indent cabal-parse-state-minimum-indent)
+ (indents cabal-parse-state-indents)
+ (conditionals cabal-parse-state-conditionals)
+ (true-group? cabal-parse-state-true-group?)
+ (true-group cabal-parse-state-true-group)
+ (false-group cabal-parse-state-false-group)
+ (true-group?-stack cabal-parse-state-true-group?-stack)
+ (true-group-stack cabal-parse-state-true-group-stack)
+ (false-group-stack cabal-parse-state-false-group-stack))
+
+(define key-value-rx
+ ;; Regular expression matching "key: value"
+ (make-regexp "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$"))
+
+(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
+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) #\,)
+ (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 the 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-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))))))
+
+(define (read-cabal port)
+ "Parses a Cabal file from PORT. Return an S-expression representing the
+content of the file. 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."
+ (let ((lines (strip-insignificant-lines port)))
+ (call-with-values
+ (lambda ()
+ (run-with-state (parse-cabal '())
+ (make-cabal-parse-state lines -1 '() '() #t '() '() '() '() '())))
+ (lambda (result state) result))))
+
+(define (parse-cabal result)
+ "Parse a Cabal file and append its content to RESULT (a list). Return the
+updated result as a monadic value in the state monad."
+ (mlet* %state-monad ((state (current-state)))
+ (match state
+ (($ <cabal-parse-state> lines minimum-indent indents conditionals
+ true-group? true-group false-group
+ true-group?-stack true-group-stack
+ false-group-stack)
+ (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))))
+ ((key-value-rx-result) (has-key? line))
+ ((end-of-file?) (null? lines))
+ ((is-simple-key-value?) (and (= next-line-indent current-indent)
+ key-value-rx-result))
+ ((is-multi-line-key-value?) (and (> next-line-indent current-indent)
+ key-value-rx-result))
+ ((key) (and=> key-value-rx-result
+ (lambda (rx-res)
+ (string-downcase (match:substring rx-res 1)))))
+ ((value) (and=> key-value-rx-result (cut match:substring <> 2))))
+ (cond
+ (end-of-file? (return (reverse result)))
+ (is-simple-key-value?
+ (>>= (state-add-entry (list key `(,value)) result (cdr lines))
+ parse-cabal))
+ (is-multi-line-key-value?
+ (let*-values
+ (((value-lst lines)
+ (multi-line-value (cdr lines)
+ (if (string-null? value) '() `(,value)))))
+ (>>= (state-add-entry (list key value-lst) result lines)
+ parse-cabal)))
+ (else ; it's a section
+ (let* ((section-header (string-tokenize (string-downcase line)))
+ (section-type (string->symbol (first section-header)))
+ (section-name (if (> (length section-header) 1)
+ (second section-header)
+ "")))
+ (mbegin %current-monad
+ (set-current-state
+ (set-fields state
+ ((cabal-parse-state-minimum-indent) current-indent)
+ ((cabal-parse-state-lines) (cdr lines))))
+ (>>=
+ (>>= (parse-cabal-section '())
+ (lambda (section-contents)
+ (mlet* %state-monad ((state (current-state)))
+ (mbegin %current-monad
+ (set-current-state
+ (set-fields state
+ ((cabal-parse-state-minimum-indent) -1)))
+ (return
+ (cons (append
+ (if (string-null? section-name)
+ (list 'section section-type)
+ (list 'section section-type section-name))
+ (list section-contents))
+ result))))))
+ parse-cabal))))))))))
+
+(define (parse-cabal-section result)
+ "Parse a section of a cabal file and append its content to RESULT (a list).
+Return the updated result as a value in the state monad."
+ (mlet* %state-monad ((state (current-state)))
+ (match state
+ (($ <cabal-parse-state> lines minimum-indent indents conditionals
+ true-group? true-group false-group
+ true-group?-stack true-group-stack
+ false-group-stack)
+ (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))))
+ ((key-value-rx-result) (has-key? line))
+ ((end-of-section?) (or (<= current-indent minimum-indent)
+ (null? lines)))
+ ;; If this is the last line of the section, then it can't be the
+ ;; start of a conditional or an 'else'.
+ ((last-line-of-section?) (<= next-line-indent minimum-indent))
+ ((is-simple-key-value?) (or (and (= next-line-indent current-indent)
+ key-value-rx-result)
+ (and (pair? conditionals)
+ (= next-line-indent (first indents))
+ (string-prefix? "else" next-line))))
+ ((is-multi-line-key-value?) (and (> next-line-indent current-indent)
+ key-value-rx-result))
+ ((end-of-cond?)
+ (and (pair? conditionals)
+ (or (and (= next-line-indent (first indents))
+ (not (string-prefix? "else" next-line)))
+ (< next-line-indent (first indents)))))
+ ((is-else?) (and (pair? conditionals)
+ (= current-indent (first indents))
+ (string-prefix? "else" line)))
+ ((condition) (cabal-conditional-line->sexp line))
+ ((key) (and=> key-value-rx-result
+ (lambda (rx-res)
+ (string-downcase (match:substring rx-res 1)))))
+ ((value) (and=> key-value-rx-result
+ (cut match:substring <> 2))))
+ (cond
+ (end-of-section?
+ (if (pair? indents)
+ (state-reduce-indentation (1- (length indents)) #f result lines)
+ (return result)))
+ (last-line-of-section?
+ (if (pair? indents)
+ (state-reduce-indentation
+ (1- (length indents)) (list key `(,value)) result (cdr lines))
+ (mbegin %current-monad
+ (set-current-state
+ (set-fields state ((cabal-parse-state-lines) (cdr lines))))
+ (return (cons (list key `(,value)) result)))))
+ (is-simple-key-value?
+ (>>= (state-add-entry (list key `(,value)) result (cdr lines))
+ parse-cabal-section))
+ (is-multi-line-key-value?
+ (let*-values
+ ;; VALUE-LST is the full multi-line value and LINES are the
+ ;; remaining lines to be parsed (from the line following the
+ ;; multi-line value). We need to check if we are at the end of
+ ;; a conditional or at the end of the section.
+ (((value-lst lines)
+ (multi-line-value (cdr lines)
+ (if (string-null? value) '() `(,value))))
+ ((ind line) (if (null? lines)
+ (values 0 "")
+ (line-indentation+rest (first lines))))
+ ((end-of-cond?) (and (pair? conditionals)
+ (or (and (= ind (first indents))
+ (not (string-prefix? "else" line)))
+ (< ind (first indents)))))
+ ;; If IND is not in INDENTS, assume that we are at the end of
+ ;; the section.
+ ((idx) (or (and=>
+ (list-index (cut = ind <>) indents)
+ (cut + <> (if (string-prefix? "else" line) -1 0)))
+ (1- (length indents)))))
+ (if end-of-cond?
+ (>>= (state-reduce-indentation idx (list key value-lst)
+ result lines)
+ parse-cabal-section)
+ (>>= (state-add-entry (list key value-lst) result lines)
+ parse-cabal-section))))
+ (end-of-cond?
+ (let ((idx (+ (list-index (cut = next-line-indent <>) indents)
+ (if (string-prefix? "else" next-line) -1 0))))
+ (>>= (state-reduce-indentation idx (list key `(,value)) result
+ (if (pair? lines) (cdr lines) '()))
+ parse-cabal-section)))
+ (is-else?
+ (mbegin %current-monad
+ (set-current-state
+ (set-fields state
+ ((cabal-parse-state-lines) (cdr lines))
+ ((cabal-parse-state-true-group?) #f)))
+ (parse-cabal-section result)))
+ (condition
+ (mbegin %current-monad
+ (state-add-conditional condition current-indent)
+ (parse-cabal-section result)))))))))
+
+(define (state-reduce-indentation index entry result lines)
+ "Given RESULT, if ENTRY is not #f, add it as appropriate and return the
+updated result as a value in the state monad. Update the state according to
+the reduction of the indentation level specified by INDEX, an index of an
+entry in the 'indentations' field of the state. As an example, if there are
+two nested conditional levels, the first starting at indentation 2 and the
+second at indentation 4, then the 'indentations' field of state is '(4 2) and
+an INDEX value of 0 means that the second conditional is finished. Set the
+remaining lines to be parsed to LINES."
+ (lambda (state)
+ (match state
+ (($ <cabal-parse-state> _ minimum-indent indents conditionals
+ true-group? true-group false-group
+ true-group?-stack true-group-stack
+ false-group-stack)
+ ;; The suffix '-d' stays for 'drop'.
+ (let*-values (((inds-d inds) (split-at indents (1+ index)))
+ ((conds-d conds) (split-at conditionals (1+ index)))
+ ((t-g?-s-d t-g?-s)
+ (if (> (length true-group?-stack) index)
+ (split-at true-group?-stack (1+ index))
+ (values true-group?-stack '())))
+ ((t-g-s-d t-g-s)
+ (if (> (length true-group-stack) index)
+ (split-at true-group-stack (1+ index))
+ (values true-group-stack '())))
+ ((f-g-s-d f-g-s)
+ (if (> (length false-group-stack) index)
+ (split-at false-group-stack (1+ index))
+ (values false-group-stack '())))
+ ((t-g?)
+ (if (> (length true-group?-stack) index)
+ (last t-g?-s-d) #t))
+ ((t-g) (if (and true-group? entry)
+ (cons entry true-group)
+ true-group))
+ ((f-g) (if (or true-group? (not entry))
+ false-group
+ (cons entry false-group)))
+ ((res) result))
+ (let reduce-by-one ((conds-d conds-d) (t-g t-g) (f-g f-g) (res res)
+ (t-g?-s-d t-g?-s-d) (t-g-s-d t-g-s-d)
+ (f-g-s-d f-g-s-d))
+ (cond
+ ((null? conds-d)
+ (values res
+ (set-fields state
+ ((cabal-parse-state-lines) lines)
+ ((cabal-parse-state-indents) inds)
+ ((cabal-parse-state-conditionals) conds)
+ ((cabal-parse-state-true-group?) t-g?)
+ ((cabal-parse-state-true-group) t-g)
+ ((cabal-parse-state-false-group) f-g)
+ ((cabal-parse-state-true-group?-stack) t-g?-s)
+ ((cabal-parse-state-true-group-stack) t-g-s)
+ ((cabal-parse-state-false-group-stack) f-g-s))))
+ ((null? t-g?-s-d)
+ (reduce-by-one (cdr conds-d) '() '()
+ (cons `(if ,(first conds-d) ,t-g ,f-g) res)
+ t-g?-s t-g-s f-g-s))
+ ((first t-g?-s-d)
+ (reduce-by-one (cdr conds-d)
+ (cons `(if ,(first conds-d) ,t-g ,f-g)
+ (first t-g-s-d))
+ (first f-g-s-d) res
+ (cdr t-g?-s-d) (cdr t-g-s-d) (cdr f-g-s-d)))
+ (else
+ (reduce-by-one (cdr conds-d) (first t-g-s-d)
+ (cons `(if ,(first conds-d) ,t-g ,f-g)
+ (first f-g-s-d))
+ res
+ (cdr t-g?-s-d) (cdr t-g-s-d) (cdr f-g-s-d))))))))))
+
+(define (state-add-entry entry result lines)
+ "Given the current RESULT, adds ENTRY as appropriate. Set the remaining
+lines to be parsed to LINES. Retrun the updated result as a value in the
+state monad."
+ (lambda (state)
+ (match state
+ (($ <cabal-parse-state> _ minimum-indent indents conditionals
+ true-group? true-group false-group
+ true-group?-stack true-group-stack
+ false-group-stack)
+ (cond
+ ((null? conditionals)
+ (values (cons entry result)
+ (set-fields state
+ ((cabal-parse-state-lines) lines))))
+ (true-group?
+ (values result
+ (set-fields state
+ ((cabal-parse-state-true-group)
+ (cons entry true-group))
+ ((cabal-parse-state-lines) lines))))
+ (else
+ (values result
+ (set-fields state
+ ((cabal-parse-state-false-group)
+ (cons entry false-group))
+ ((cabal-parse-state-lines) lines)))))))))
+
+(define (state-add-conditional condition indentation)
+ "Add CONDITION at INDENTATION level to the current state. Return the value
+*unspecified* in the state monad."
+ (lambda (state)
+ (match state
+ (($ <cabal-parse-state> lines minimum-indent indents conditionals
+ true-group? true-group false-group
+ true-group?-stack true-group-stack
+ false-group-stack)
+ (if (null? conditionals)
+ (values '*unspecified*
+ (set-fields state
+ ((cabal-parse-state-lines) (cdr lines))
+ ((cabal-parse-state-conditionals)
+ (cons condition conditionals))
+ ((cabal-parse-state-indents)
+ (cons indentation indents))
+ ((cabal-parse-state-true-group?) #t)))
+ (values '*unspecified*
+ (set-fields state
+ ((cabal-parse-state-lines) (cdr lines))
+ ((cabal-parse-state-conditionals)
+ (cons condition conditionals))
+ ((cabal-parse-state-indents)
+ (cons indentation indents))
+ ((cabal-parse-state-true-group?) #t)
+ ((cabal-parse-state-true-group) '())
+ ((cabal-parse-state-false-group) '())
+ ((cabal-parse-state-true-group?-stack)
+ (cons true-group? true-group?-stack))
+ ((cabal-parse-state-true-group-stack)
+ (cons true-group true-group-stack))
+ ((cabal-parse-state-false-group-stack)
+ (cons false-group false-group-stack)))))))))
+
+(define condition-rx
+ ;; Regexp for conditionals.
+ (make-regexp "^if +(.*)$"))
+
+(define (cabal-extract-condition line)
+ "Extract the test condition from a conditional LINE."
+ (let ((rx-result (regexp-exec condition-rx (string-downcase line))))
+ (if rx-result (match:substring rx-result 1) #f)))
+
+(define (cabal-conditional-line->sexp line)
+ "Extract the test condition from LINE and convert it into an S-expression."
+ (let ((conditional (cabal-extract-condition line)))
+ (and=> conditional
+ (compose cabal-test-keywords->sexp
+ cabal-conditional->sexp-like
+ cabal-impl-with-and->impl-and))))
+
+(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 tests-rx
+ ;; Cabal test keywords
+ (make-regexp "(os|arch|flag|impl) *\\(([ a-zA-Z0-9_.<>=-]+)\\)"))
+
+(define impl-with-and
+ (make-regexp
+ "(impl) *\\(([ a-zA-Z0-9_-]+) *([ 0-9_.<>=-]+) *(&&) *([ 0-9_.<>=-]+) *\\)"))
+
+(define (cabal-impl-with-and->impl-and conditional)
+ "Transform any compiler version range specificication appearing in
+CONDITIONAL into two specifications and an 'and' conjunction. For example,
+the specification \"impl(ghc >= 7.2 && < 7.6)\" is transformed into
+\"impl(ghc >= 7.2 ) && impl(ghc < 7.6)\"."
+ (regexp-substitute/global #f impl-with-and
+ conditional
+ 'pre 1 "(" 2 3 ") " 4 " " 1 "(" 2 5 ")" 'post))
+
+(define (cabal-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 (cabal-test-keywords->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
+ " *([a-zA-Z0-9_-]+) *([<>=]*) *([0-9.]*) *"
+ test-keyword-ornament))))
+ (regexp-substitute/global
+ #f rx sexp
+ 'pre pre-match 2 3 4 post-match 'post)))
+ (_ sexp)))
+ sexp-like-cond
+ '(("(os)" "(os \"" "\")")
+ ("(arch)" "(arch \"" "\")")
+ ("(impl)" "(impl \"" "\")")
+ ("(flag)" "(flag \"" "\")")))
+ read))
+
+;; 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 (impl haskell)
+ (let* ((haskell-implementation (or (assoc-ref env "impl") "ghc"))
+ (impl-rx-result-with-version
+ (string-match "([a-zA-Z0-9_]+)-([0-9.]+)" haskell-implementation))
+ (impl-name (or (and=> impl-rx-result-with-version
+ (cut match:substring <> 1))
+ haskell-implementation))
+ (impl-version (and=> impl-rx-result-with-version
+ (cut match:substring <> 2)))
+ (cabal-rx-result-with-version
+ (string-match "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *" haskell))
+ (cabal-rx-result-without-version
+ (string-match "([a-zA-Z0-9_-]+)" haskell))
+ (cabal-impl-name (or (and=> cabal-rx-result-with-version
+ (cut match:substring <> 1))
+ (match:substring
+ cabal-rx-result-without-version 1)))
+ (cabal-impl-version (and=> cabal-rx-result-with-version
+ (cut match:substring <> 3)))
+ (cabal-impl-operator (and=> cabal-rx-result-with-version
+ (cut match:substring <> 2)))
+ (comparison (and=> cabal-impl-operator
+ (cut string-append "string" <>))))
+ (if (and cabal-impl-version impl-version)
+ (eval-string
+ (string-append "(string" cabal-impl-operator
+ " \"" haskell-implementation "\""
+ " \"" cabal-impl-name "-" cabal-impl-version "\")"))
+ (string-match cabal-impl-name impl-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 do 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 '())
+ (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 1b27803..478d42c 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
@@ -746,22 +191,28 @@ 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))
+ ,@(maybe-inputs 'inputs dependencies)
+ (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)
+ (cabal-environment '()))
"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?))))
+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 (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
diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm
index f7c18cd..92ff941 100644
--- a/guix/scripts/import/hackage.scm
+++ b/guix/scripts/import/hackage.scm
@@ -34,7 +34,8 @@
;;;
(define %default-options
- '((include-test-dependencies? . #t)))
+ '((include-test-dependencies? . #t)
+ ('cabal-environment . '())))
(define (show-help)
(display (_ "Usage: guix import hackage PACKAGE-NAME
@@ -45,6 +46,9 @@ package will be generated. If no version suffix is pecified, then the
generated package definition will correspond to the latest available
version.\n"))
(display (_ "
+ -e ALIST, --cabal-environment=ALIST
+ specify environment for Cabal evaluation"))
+ (display (_ "
-h, --help display this help and exit"))
(display (_ "
-t, --no-test-dependencies don't include test only dependencies"))
@@ -67,6 +71,11 @@ version.\n"))
(alist-cons 'include-test-dependencies? #f
(alist-delete 'include-test-dependencies?
result))))
+ (option '(#\e "cabal-environment") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'cabal-environment (read/eval arg)
+ (alist-delete 'cabal-environment
+ result))))
%standard-import-options))
\f
@@ -95,7 +104,8 @@ version.\n"))
(let ((sexp (hackage->guix-package
package-name
#:include-test-dependencies?
- (assoc-ref opts 'include-test-dependencies?))))
+ (assoc-ref opts 'include-test-dependencies?)
+ #:cabal-environment (assoc-ref opts 'cabal-environment))))
(unless sexp
(leave (_ "failed to download cabal file for package '~a'~%")
package-name))
diff --git a/tests/hackage.scm b/tests/hackage.scm
index 23b854c..dca5074 100644
--- a/tests/hackage.scm
+++ b/tests/hackage.scm
@@ -63,16 +63,13 @@ executable cabal
")
(define test-cond-1
- "(os(darwin) || !(flag(debug))) && flag(cips)")
+ "if (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))
+(define cabal-conditional-line->sexp
+ (@@ (guix import cabal) cabal-conditional-line->sexp))
(test-begin "hackage")
@@ -118,12 +115,9 @@ executable cabal
(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)
+(test-assert "cabal-conditional-line->sexp"
+ (match (cabal-conditional-line->sexp test-cond-1)
+ (('and ('or ('os "darwin") ('not ('flag "debug"))) ('flag "cips"))
#t)
(x
(pk 'fail x #f))))
--
2.2.1
^ permalink raw reply related [flat|nested] 19+ messages in thread
* Re: hackage importer
@ 2015-04-26 11:52 Federico Beffa
0 siblings, 0 replies; 19+ messages in thread
From: Federico Beffa @ 2015-04-26 11:52 UTC (permalink / raw)
To: Ludovic Courtès, Guix-devel
Federico Beffa <beffa@ieee.org> writes:
> Please find attached a patch reorganizing the code as you suggest.
Just noticed that I forgot to delete 'parse-cabal' from the public
interface of the cabal module.
Regards,
Fede
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-04-26 11:38 ` Federico Beffa
@ 2015-05-02 12:48 ` Ludovic Courtès
2015-06-01 15:20 ` Federico Beffa
0 siblings, 1 reply; 19+ messages in thread
From: Ludovic Courtès @ 2015-05-02 12:48 UTC (permalink / raw)
To: Federico Beffa; +Cc: Guix-devel
Federico Beffa <beffa@ieee.org> skribis:
> Please find attached a patch reorganizing the code as you suggest.
Woow, neat! Impressive work. I think this is a great improvement.
I have a bunch of stylistic comments below, and some open questions as
well.
> From bc8cdab1e322a25002a3d9cf33eddd856c8a81d8 Mon Sep 17 00:00:00 2001
> From: Federico Beffa <beffa@fbengineering.ch>
> Date: Sun, 26 Apr 2015 11:22:29 +0200
> Subject: [PATCH] import: hackage: Refactor parsing code and add new option.
>
> * guix/import/cabal.scm: New file.
>
> * guix/import/hackage.scm: Update to use the new Cabal parsing module.
>
> * tests/hackage.scm: Update tests for private functions.
>
> * guix/scripts/import/hackage.scm: Add new '--cabal-environment' option.
>
> * doc/guix.texi: ... and document it.
>
> * Makefile.am (MODULES): Add 'guix/import/cabal.scm',
> 'guix/import/hackage.scm' and 'guix/scripts/import/hackage.scm'.
> (SCM_TESTS): Add 'tests/hackage.scm'.
No newlines between entries.
[...]
> +;; This record stores the state information needed during parsing of Cabal
> +;; files.
> +(define-record-type <cabal-parse-state>
> + (make-cabal-parse-state lines minimum-indent indents conditionals
> + true-group? true-group false-group
> + true-group?-stack true-group-stack false-group-stack)
[...]
> + (make-cabal-parse-state lines -1 '() '() #t '() '() '() '() '())))
I’m not claiming this must done now, but it may improve readability to
use ‘define-record-type*’. That way, with appropriate field default
values, one could write something like:
(cabal-parse-state
(lines lines))
That would also allow the use of ‘inherit’, which is slightly less
verbose than ‘set-fields’. WDYT?
Besides, could you add comments to explain the meaning of the various
fields? I’m particularly curious about ‘true-group?’ & co. ;-)
> +(define (parse-cabal result)
> + "Parse a Cabal file and append its content to RESULT (a list). Return the
> +updated result as a monadic value in the state monad."
> + (mlet* %state-monad ((state (current-state)))
> + (match state
> + (($ <cabal-parse-state> lines minimum-indent indents conditionals
> + true-group? true-group false-group
> + true-group?-stack true-group-stack
> + false-group-stack)
> + (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))))
> + ((key-value-rx-result) (has-key? line))
> + ((end-of-file?) (null? lines))
> + ((is-simple-key-value?) (and (= next-line-indent current-indent)
> + key-value-rx-result))
> + ((is-multi-line-key-value?) (and (> next-line-indent current-indent)
> + key-value-rx-result))
> + ((key) (and=> key-value-rx-result
> + (lambda (rx-res)
> + (string-downcase (match:substring rx-res 1)))))
> + ((value) (and=> key-value-rx-result (cut match:substring <> 2))))
> + (cond
> + (end-of-file? (return (reverse result)))
> + (is-simple-key-value?
> + (>>= (state-add-entry (list key `(,value)) result (cdr lines))
> + parse-cabal))
> + (is-multi-line-key-value?
> + (let*-values
> + (((value-lst lines)
> + (multi-line-value (cdr lines)
> + (if (string-null? value) '() `(,value)))))
> + (>>= (state-add-entry (list key value-lst) result lines)
> + parse-cabal)))
> + (else ; it's a section
> + (let* ((section-header (string-tokenize (string-downcase line)))
> + (section-type (string->symbol (first section-header)))
> + (section-name (if (> (length section-header) 1)
> + (second section-header)
> + "")))
> + (mbegin %current-monad
> + (set-current-state
> + (set-fields state
> + ((cabal-parse-state-minimum-indent) current-indent)
> + ((cabal-parse-state-lines) (cdr lines))))
> + (>>=
> + (>>= (parse-cabal-section '())
> + (lambda (section-contents)
> + (mlet* %state-monad ((state (current-state)))
> + (mbegin %current-monad
> + (set-current-state
> + (set-fields state
> + ((cabal-parse-state-minimum-indent) -1)))
> + (return
> + (cons (append
> + (if (string-null? section-name)
> + (list 'section section-type)
> + (list 'section section-type section-name))
> + (list section-contents))
> + result))))))
> + parse-cabal))))))))))
This procedure is intimidating. I think this is partly due to its
length, to the big let-values, the long identifiers, the many local
variables, nested binds, etc.
Would it be possible to create auxiliary procedures that would help?
I’m thinking of procedures that take a <cabal-parse-state> and return
the necessary info, like ‘cabal-parse-state-indentation’,
‘cabal-parse-state-key’, ‘cabal-parse-state-multiline?’,
‘cabal-parse-state-eof?’, etc. WDYT?
Also, please try hard to avoid car and cdr and use ‘match’ instead.
(BTW it’s a good idea to use the state monad here!)
> +(define (parse-cabal-section result)
> + "Parse a section of a cabal file and append its content to RESULT (a list).
> +Return the updated result as a value in the state monad."
> + (mlet* %state-monad ((state (current-state)))
> + (match state
> + (($ <cabal-parse-state> lines minimum-indent indents conditionals
> + true-group? true-group false-group
> + true-group?-stack true-group-stack
> + false-group-stack)
> + (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))))
> + ((key-value-rx-result) (has-key? line))
> + ((end-of-section?) (or (<= current-indent minimum-indent)
> + (null? lines)))
> + ;; If this is the last line of the section, then it can't be the
> + ;; start of a conditional or an 'else'.
> + ((last-line-of-section?) (<= next-line-indent minimum-indent))
> + ((is-simple-key-value?) (or (and (= next-line-indent current-indent)
> + key-value-rx-result)
> + (and (pair? conditionals)
> + (= next-line-indent (first indents))
> + (string-prefix? "else" next-line))))
> + ((is-multi-line-key-value?) (and (> next-line-indent current-indent)
> + key-value-rx-result))
> + ((end-of-cond?)
> + (and (pair? conditionals)
> + (or (and (= next-line-indent (first indents))
> + (not (string-prefix? "else" next-line)))
> + (< next-line-indent (first indents)))))
> + ((is-else?) (and (pair? conditionals)
> + (= current-indent (first indents))
> + (string-prefix? "else" line)))
> + ((condition) (cabal-conditional-line->sexp line))
> + ((key) (and=> key-value-rx-result
> + (lambda (rx-res)
> + (string-downcase (match:substring rx-res 1)))))
> + ((value) (and=> key-value-rx-result
> + (cut match:substring <> 2))))
> + (cond
> + (end-of-section?
> + (if (pair? indents)
> + (state-reduce-indentation (1- (length indents)) #f result lines)
> + (return result)))
> + (last-line-of-section?
> + (if (pair? indents)
> + (state-reduce-indentation
> + (1- (length indents)) (list key `(,value)) result (cdr lines))
> + (mbegin %current-monad
> + (set-current-state
> + (set-fields state ((cabal-parse-state-lines) (cdr lines))))
> + (return (cons (list key `(,value)) result)))))
> + (is-simple-key-value?
> + (>>= (state-add-entry (list key `(,value)) result (cdr lines))
> + parse-cabal-section))
> + (is-multi-line-key-value?
> + (let*-values
> + ;; VALUE-LST is the full multi-line value and LINES are the
> + ;; remaining lines to be parsed (from the line following the
> + ;; multi-line value). We need to check if we are at the end of
> + ;; a conditional or at the end of the section.
> + (((value-lst lines)
> + (multi-line-value (cdr lines)
> + (if (string-null? value) '() `(,value))))
> + ((ind line) (if (null? lines)
> + (values 0 "")
> + (line-indentation+rest (first lines))))
> + ((end-of-cond?) (and (pair? conditionals)
> + (or (and (= ind (first indents))
> + (not (string-prefix? "else" line)))
> + (< ind (first indents)))))
> + ;; If IND is not in INDENTS, assume that we are at the end of
> + ;; the section.
> + ((idx) (or (and=>
> + (list-index (cut = ind <>) indents)
> + (cut + <> (if (string-prefix? "else" line) -1 0)))
> + (1- (length indents)))))
> + (if end-of-cond?
> + (>>= (state-reduce-indentation idx (list key value-lst)
> + result lines)
> + parse-cabal-section)
> + (>>= (state-add-entry (list key value-lst) result lines)
> + parse-cabal-section))))
> + (end-of-cond?
> + (let ((idx (+ (list-index (cut = next-line-indent <>) indents)
> + (if (string-prefix? "else" next-line) -1 0))))
> + (>>= (state-reduce-indentation idx (list key `(,value)) result
> + (if (pair? lines) (cdr lines) '()))
> + parse-cabal-section)))
> + (is-else?
> + (mbegin %current-monad
> + (set-current-state
> + (set-fields state
> + ((cabal-parse-state-lines) (cdr lines))
> + ((cabal-parse-state-true-group?) #f)))
> + (parse-cabal-section result)))
> + (condition
> + (mbegin %current-monad
> + (state-add-conditional condition current-indent)
> + (parse-cabal-section result)))))))))
This one is also very intimidating and it seems to duplicate some of the
code of the previous one, so maybe the propose <cabal-state> procedures
will help here as well.
> +(define (state-reduce-indentation index entry result lines)
s/reduce/decrease/
> + "Given RESULT, if ENTRY is not #f, add it as appropriate and return the
> +updated result as a value in the state monad. Update the state according to
> +the reduction of the indentation level specified by INDEX, an index of an
s/reduction/decrease/
> +entry in the 'indentations' field of the state.
Could you explain what RESULT and ENTRY are? Also, it seems to do two
different things: compute a value function of RESULT and ENTRY, and
update the current indentation. Should it be two separate procedures?
> As an example, if there are
> +two nested conditional levels, the first starting at indentation 2 and the
> +second at indentation 4, then the 'indentations' field of state is '(4 2) and
> +an INDEX value of 0 means that the second conditional is finished. Set the
> +remaining lines to be parsed to LINES."
> + (lambda (state)
> + (match state
> + (($ <cabal-parse-state> _ minimum-indent indents conditionals
> + true-group? true-group false-group
> + true-group?-stack true-group-stack
> + false-group-stack)
> + ;; The suffix '-d' stays for 'drop'.
> + (let*-values (((inds-d inds) (split-at indents (1+ index)))
> + ((conds-d conds) (split-at conditionals (1+ index)))
> + ((t-g?-s-d t-g?-s)
> + (if (> (length true-group?-stack) index)
> + (split-at true-group?-stack (1+ index))
> + (values true-group?-stack '())))
> + ((t-g-s-d t-g-s)
> + (if (> (length true-group-stack) index)
> + (split-at true-group-stack (1+ index))
> + (values true-group-stack '())))
> + ((f-g-s-d f-g-s)
> + (if (> (length false-group-stack) index)
> + (split-at false-group-stack (1+ index))
> + (values false-group-stack '())))
> + ((t-g?)
> + (if (> (length true-group?-stack) index)
> + (last t-g?-s-d) #t))
> + ((t-g) (if (and true-group? entry)
> + (cons entry true-group)
> + true-group))
> + ((f-g) (if (or true-group? (not entry))
> + false-group
> + (cons entry false-group)))
> + ((res) result))
> + (let reduce-by-one ((conds-d conds-d) (t-g t-g) (f-g f-g) (res res)
> + (t-g?-s-d t-g?-s-d) (t-g-s-d t-g-s-d)
> + (f-g-s-d f-g-s-d))
This is somewhat scary ;-) but I’m not sure how to improve it.
> + (values '*unspecified*
Did you mean *unspecified*, without the quote, which evaluates to *the*
unspecified value?
> +(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
There are no keyboards in Scheme. :-)
[...]
> + (define (impl haskell)
> + (let* ((haskell-implementation (or (assoc-ref env "impl") "ghc"))
> + (impl-rx-result-with-version
> + (string-match "([a-zA-Z0-9_]+)-([0-9.]+)" haskell-implementation))
> + (impl-name (or (and=> impl-rx-result-with-version
> + (cut match:substring <> 1))
> + haskell-implementation))
> + (impl-version (and=> impl-rx-result-with-version
> + (cut match:substring <> 2)))
> + (cabal-rx-result-with-version
> + (string-match "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *" haskell))
> + (cabal-rx-result-without-version
> + (string-match "([a-zA-Z0-9_-]+)" haskell))
> + (cabal-impl-name (or (and=> cabal-rx-result-with-version
> + (cut match:substring <> 1))
> + (match:substring
> + cabal-rx-result-without-version 1)))
> + (cabal-impl-version (and=> cabal-rx-result-with-version
> + (cut match:substring <> 3)))
> + (cabal-impl-operator (and=> cabal-rx-result-with-version
> + (cut match:substring <> 2)))
> + (comparison (and=> cabal-impl-operator
> + (cut string-append "string" <>))))
Again I feel we need one or more auxiliary procedures and/or data types
here to simplify this part (fewer local variables), as well as shorter
identifiers. WDYT?
> --- a/tests/hackage.scm
> +++ b/tests/hackage.scm
> @@ -63,16 +63,13 @@ executable cabal
> ")
>
The existing tests here are fine, but they are more like integration
tests (they test the whole pipeline.) Maybe it would be nice to
directly exercise ‘read-cabal’ and ‘eval-cabal’ individually?
Thanks for all of this!
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-05-02 12:48 ` Ludovic Courtès
@ 2015-06-01 15:20 ` Federico Beffa
2015-06-05 7:30 ` Ludovic Courtès
0 siblings, 1 reply; 19+ messages in thread
From: Federico Beffa @ 2015-06-01 15:20 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Guix-devel
[-- Attachment #1: Type: text/plain, Size: 5124 bytes --]
Hi,
sorry for taking so long to answer!
On Sat, May 2, 2015 at 2:48 PM, Ludovic Courtès <ludo@gnu.org> wrote:
>> Subject: [PATCH] import: hackage: Refactor parsing code and add new option.
>>
>> * guix/import/cabal.scm: New file.
>>
>> * guix/import/hackage.scm: Update to use the new Cabal parsing module.
>>
>> * tests/hackage.scm: Update tests for private functions.
>>
>> * guix/scripts/import/hackage.scm: Add new '--cabal-environment' option.
>>
>> * doc/guix.texi: ... and document it.
>>
>> * Makefile.am (MODULES): Add 'guix/import/cabal.scm',
>> 'guix/import/hackage.scm' and 'guix/scripts/import/hackage.scm'.
>> (SCM_TESTS): Add 'tests/hackage.scm'.
>
> No newlines between entries.
Done.
[...]
> This procedure is intimidating. I think this is partly due to its
> length, to the big let-values, the long identifiers, the many local
> variables, nested binds, etc.
Ok, this procedure has now ... disappeared ... or rather it is now
hidden in a huge, but invisible macro ;-)
I've added support for braces delimited blocks. In so doing the
complexity of an ad-hoc solution increased further and decided that it
was time to study (and use) a proper parser.
But, a couple of words on your remarks:
- Thanks to your comment about long list of local variables I
(re-)discovered the (test => expr) form of cond clauses. Very useful!
- The nested use of the >>= function didn't look nice and the reason
is that it is really meant as a way to sequence monadic functions as
in (>>= m f1 f2 ...). Unfortunately the current version of >>= in
guile only accepts 2 arguments (1 function), hence the nesting. It
would be nice to correct that :-)
In any case, I had to give up with the state monad because the lalr
parser in Guile doesn't play nice with the functional programming
paradigm.
>> +(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
>
> There are no keyboards in Scheme. :-)
??
> [...]
>
>> + (define (impl haskell)
>> + (let* ((haskell-implementation (or (assoc-ref env "impl") "ghc"))
>> + (impl-rx-result-with-version
>> + (string-match "([a-zA-Z0-9_]+)-([0-9.]+)" haskell-implementation))
>> + (impl-name (or (and=> impl-rx-result-with-version
>> + (cut match:substring <> 1))
>> + haskell-implementation))
>> + (impl-version (and=> impl-rx-result-with-version
>> + (cut match:substring <> 2)))
>> + (cabal-rx-result-with-version
>> + (string-match "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *" haskell))
>> + (cabal-rx-result-without-version
>> + (string-match "([a-zA-Z0-9_-]+)" haskell))
>> + (cabal-impl-name (or (and=> cabal-rx-result-with-version
>> + (cut match:substring <> 1))
>> + (match:substring
>> + cabal-rx-result-without-version 1)))
>> + (cabal-impl-version (and=> cabal-rx-result-with-version
>> + (cut match:substring <> 3)))
>> + (cabal-impl-operator (and=> cabal-rx-result-with-version
>> + (cut match:substring <> 2)))
>> + (comparison (and=> cabal-impl-operator
>> + (cut string-append "string" <>))))
>
> Again I feel we need one or more auxiliary procedures and/or data types
> here to simplify this part (fewer local variables), as well as shorter
> identifiers. WDYT?
I've added two help functions to make it easier to read.
> The existing tests here are fine, but they are more like integration
> tests (they test the whole pipeline.) Maybe it would be nice to
> directly exercise ‘read-cabal’ and ‘eval-cabal’ individually?
It is true that the tests are for the whole pipeline, but they catch
most of the problems (problems in any function along the chain) with
the smallest number of tests :-). I'm not very keen in doing fine
grained testing. Sorry.
I've removed the test with TABs because the Cabal documentation says
explicitly that they are not allowed.
https://www.haskell.org/cabal/users-guide/developing-packages.html#package-descriptions
I've changed the second test to check the use of braces (multi-line
values have still to be indented).
Regards,
Fede
[-- Attachment #2: 0001-import-hackage-Refactor-parsing-code-and-add-new-opt.patch --]
[-- Type: text/x-diff, Size: 76795 bytes --]
From f422ea9aff3aa8425c80eaadf50628c24d54495a Mon Sep 17 00:00:00 2001
From: Federico Beffa <beffa@fbengineering.ch>
Date: Sun, 26 Apr 2015 11:22:29 +0200
Subject: [PATCH] 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'.
---
Makefile.am | 4 +
doc/guix.texi | 22 +-
guix/import/cabal.scm | 802 ++++++++++++++++++++++++++++++++++++++++
guix/import/hackage.scm | 700 ++++-------------------------------
guix/scripts/import/hackage.scm | 65 +++-
tests/hackage.scm | 49 +--
6 files changed, 959 insertions(+), 683 deletions(-)
create mode 100644 guix/import/cabal.scm
diff --git a/Makefile.am b/Makefile.am
index d54e281..b42a7f5 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -89,6 +89,8 @@ MODULES = \
guix/import/utils.scm \
guix/import/gnu.scm \
guix/import/snix.scm \
+ guix/import/cabal.scm \
+ guix/import/hackage.scm \
guix/scripts/download.scm \
guix/scripts/build.scm \
guix/scripts/archive.scm \
@@ -104,6 +106,7 @@ MODULES = \
guix/scripts/lint.scm \
guix/scripts/import/gnu.scm \
guix/scripts/import/nix.scm \
+ guix/scripts/import/hackage.scm \
guix/scripts/environment.scm \
guix/scripts/publish.scm \
guix.scm \
@@ -173,6 +176,7 @@ SCM_TESTS = \
tests/build-utils.scm \
tests/packages.scm \
tests/snix.scm \
+ tests/hackage.scm \
tests/store.scm \
tests/monads.scm \
tests/gexp.scm \
diff --git a/doc/guix.texi b/doc/guix.texi
index 70604b7..c70f833 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3199,16 +3199,30 @@ dependencies.
Specific command-line options are:
@table @code
+@item --stdin
+@itemx -s
+Read a Cabal file from the standard input.
@item --no-test-dependencies
@itemx -t
-Do not include dependencies only required to run the test suite.
+Do not include dependencies required by the test suites only.
+@item --cabal-environment=@var{alist}
+@itemx -e @var{alist}
+@var{alist} is a Scheme alist defining the environment in which the
+Cabal conditionals are evaluated. The accepted keys are: @code{os},
+@code{arch}, @code{impl} and a string representing the name of a flag.
+The value associated with a flag has to be either the symbol
+@code{true} or @code{false}. The value associated with other keys
+has to conform to the Cabal file format definition. The default value
+associated with the keys @code{os}, @code{arch} and @code{impl} is
+@samp{linux}, @samp{x86_64} and @samp{ghc} respectively.
@end table
The command below imports meta-data for the latest version of the
-@code{HTTP} Haskell package without including test dependencies:
+@code{HTTP} Haskell package without including test dependencies and
+specifying the value of the flag @samp{network-uri} as @code{false}:
@example
-guix import hackage -t HTTP
+guix import hackage -t -e "'((\"network-uri\" . false))" HTTP
@end example
A specific package version may optionally be specified by following the
@@ -3217,8 +3231,6 @@ 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
-
-Currently only indentation structured Cabal files are supported.
@end table
The structure of the @command{guix import} code is modular. It would be
diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
new file mode 100644
index 0000000..b20fde8
--- /dev/null
+++ b/guix/import/cabal.scm
@@ -0,0 +1,802 @@
+;;; 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
+(define context-stack (make-stack))
+
+;; 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)))
+ (cabal-file-name (or file-name (port-filename port) "standard input"))
+ (context-stack 'clear!)
+ (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 1b27803..1c54c74 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,32 @@ 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))
+ ,@(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)
+ (read-from-stdin? #f)
+ (cabal-environment '()))
"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?))))
+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 read-from-stdin?
+ (read-cabal)
+ (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
diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm
index f7c18cd..05aaeb6 100644
--- a/guix/scripts/import/hackage.scm
+++ b/guix/scripts/import/hackage.scm
@@ -34,7 +34,9 @@
;;;
(define %default-options
- '((include-test-dependencies? . #t)))
+ '((include-test-dependencies? . #t)
+ (read-from-stdin? . #f)
+ ('cabal-environment . '())))
(define (show-help)
(display (_ "Usage: guix import hackage PACKAGE-NAME
@@ -45,8 +47,13 @@ package will be generated. If no version suffix is pecified, then the
generated package definition will correspond to the latest available
version.\n"))
(display (_ "
+ -e ALIST, --cabal-environment=ALIST
+ specify environment for Cabal evaluation"))
+ (display (_ "
-h, --help display this help and exit"))
(display (_ "
+ -s, --stdin read from standard input"))
+ (display (_ "
-t, --no-test-dependencies don't include test only dependencies"))
(display (_ "
-V, --version display version information and exit"))
@@ -67,6 +74,16 @@ version.\n"))
(alist-cons 'include-test-dependencies? #f
(alist-delete 'include-test-dependencies?
result))))
+ (option '(#\s "stdin") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'read-from-stdin? #t
+ (alist-delete 'read-from-stdin?
+ result))))
+ (option '(#\e "cabal-environment") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'cabal-environment (read/eval arg)
+ (alist-delete 'cabal-environment
+ result))))
%standard-import-options))
\f
@@ -84,23 +101,41 @@ version.\n"))
(alist-cons 'argument arg result))
%default-options))
+ (define (run-importer package-name opts error-fn)
+ (let ((sexp (hackage->guix-package
+ package-name
+ #:include-test-dependencies?
+ (assoc-ref opts 'include-test-dependencies?)
+ #:read-from-stdin?
+ (assoc-ref opts 'read-from-stdin?)
+ #:cabal-environment
+ (assoc-ref opts 'cabal-environment))))
+ (unless sexp (error-fn))
+ sexp))
+
(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~%"))))))
+ (if (assoc-ref opts 'read-from-stdin?)
+ (match args
+ (()
+ (run-importer "stdin" opts
+ (lambda ()
+ (leave (_ "failed to import cabal file from '~a'~%"))
+ package-name)))
+ ((many ...)
+ (leave (_ "too many arguments~%"))))
+ (match args
+ ((package-name)
+ (run-importer package-name opts
+ (lambda ()
+ (leave
+ (_ "failed to download cabal file for package '~a'~%"))
+ package-name)))
+ (()
+ (leave (_ "too few arguments~%")))
+ ((many ...)
+ (leave (_ "too many arguments~%")))))))
diff --git a/tests/hackage.scm b/tests/hackage.scm
index 23b854c..f0dc875 100644
--- a/tests/hackage.scm
+++ b/tests/hackage.scm
@@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-hackage)
+ #:use-module (guix import cabal)
#:use-module (guix import hackage)
#:use-module (guix tests)
#:use-module (srfi srfi-64)
@@ -35,45 +36,20 @@ executable cabal
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
+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)
@@ -115,19 +91,6 @@ executable cabal
(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
--
2.2.1
^ permalink raw reply related [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-06-01 15:20 ` Federico Beffa
@ 2015-06-05 7:30 ` Ludovic Courtès
2015-06-05 15:19 ` Federico Beffa
0 siblings, 1 reply; 19+ messages in thread
From: Ludovic Courtès @ 2015-06-05 7:30 UTC (permalink / raw)
To: Federico Beffa; +Cc: Guix-devel
Howdy!
Federico Beffa <beffa@ieee.org> skribis:
> On Sat, May 2, 2015 at 2:48 PM, Ludovic Courtès <ludo@gnu.org> wrote:
[...]
>> This procedure is intimidating. I think this is partly due to its
>> length, to the big let-values, the long identifiers, the many local
>> variables, nested binds, etc.
>
> Ok, this procedure has now ... disappeared ... or rather it is now
> hidden in a huge, but invisible macro ;-)
> I've added support for braces delimited blocks. In so doing the
> complexity of an ad-hoc solution increased further and decided that it
> was time to study (and use) a proper parser.
Yay, good idea!
> But, a couple of words on your remarks:
>
> - Thanks to your comment about long list of local variables I
> (re-)discovered the (test => expr) form of cond clauses. Very useful!
> - The nested use of the >>= function didn't look nice and the reason
> is that it is really meant as a way to sequence monadic functions as
> in (>>= m f1 f2 ...). Unfortunately the current version of >>= in
> guile only accepts 2 arguments (1 function), hence the nesting. It
> would be nice to correct that :-)
Sure, I have it in my to-do list. :-) I looked at it quickly and it
seems less trivial than initially envisioned though.
>>> +(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
>>
>> There are no keyboards in Scheme. :-)
>
> ??
Oops, these should have read “keywords”, not “keyboards.” :-)
>> The existing tests here are fine, but they are more like integration
>> tests (they test the whole pipeline.) Maybe it would be nice to
>> directly exercise ‘read-cabal’ and ‘eval-cabal’ individually?
>
> It is true that the tests are for the whole pipeline, but they catch
> most of the problems (problems in any function along the chain) with
> the smallest number of tests :-). I'm not very keen in doing fine
> grained testing. Sorry.
>
> I've removed the test with TABs because the Cabal documentation says
> explicitly that they are not allowed.
> https://www.haskell.org/cabal/users-guide/developing-packages.html#package-descriptions
But are they actually used in practice?
> I've changed the second test to check the use of braces (multi-line
> values have still to be indented).
OK.
> From f422ea9aff3aa8425c80eaadf50628c24d54495a Mon Sep 17 00:00:00 2001
> From: Federico Beffa <beffa@fbengineering.ch>
> Date: Sun, 26 Apr 2015 11:22:29 +0200
> Subject: [PATCH] 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'.
[...]
> +(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)))))
Fair enough. :-) I wonder what happens exactly when trying to return
monadic values in the parser.
> +;; Stack to track the structure of nested blocks
> +(define context-stack (make-stack))
What about making it either a SRFI-39 parameter, or a parameter to
‘make-cabal-parser’?
I’ve only read through quickly, but the rest of the file looks lean and
clean!
> +(define* (hackage->guix-package package-name #:key
> + (include-test-dependencies? #t)
> + (read-from-stdin? #f)
> + (cabal-environment '()))
Instead of #:read-from-stdin?, what about adding a #:port argument?
That way, it would either read from PORT, or fetch from Hackage. That
seems more idiomatic and more flexible.
Also please mention it in the docstring.
> -(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))))
I’m a bit scared when we add new code *and* remove tests. ;-)
Could you add a couple of representative tests? I’m sure you ran tests
by hand at the REPL, so it should be a matter of adding them in the file.
Thanks for the nice refactoring & new features!
Ludo’.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-06-05 7:30 ` Ludovic Courtès
@ 2015-06-05 15:19 ` Federico Beffa
2015-06-09 7:38 ` Ludovic Courtès
0 siblings, 1 reply; 19+ messages in thread
From: Federico Beffa @ 2015-06-05 15:19 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Guix-devel
[-- Attachment #1: Type: text/plain, Size: 3716 bytes --]
On Fri, Jun 5, 2015 at 9:30 AM, Ludovic Courtès <ludo@gnu.org> wrote:
>> I've removed the test with TABs because the Cabal documentation says
>> explicitly that they are not allowed.
>> https://www.haskell.org/cabal/users-guide/developing-packages.html#package-descriptions
>
> But are they actually used in practice?
When I prepared the very first version of the importer I did find one
case among all the ones I tried. I believe that now that package has
been update to a new version and doesn't include TABs anymore.
> [...]
>
>> +(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)))))
>
> Fair enough. :-) I wonder what happens exactly when trying to return
> monadic values in the parser.
Given that the parser repeatedly calls the tunk generated by
'make-lexer' without passing any state or knowing anything about to
which monad it may belong to, I thought that it would not work. But,
as you see, I'm new to Scheme, new to monads, and new to Lisp in
general.
>
>> +;; Stack to track the structure of nested blocks
>> +(define context-stack (make-stack))
>
> What about making it either a SRFI-39 parameter, or a parameter to
> ‘make-cabal-parser’?
I made it a parameter. Thanks for suggesting it! It made me realize
what they are really used for :-)
Do you think it is correct to say that they serve the purpose of
special variables in Lisp? (I'm looking a little bit into Common Lisp
as well.)
>> +(define* (hackage->guix-package package-name #:key
>> + (include-test-dependencies? #t)
>> + (read-from-stdin? #f)
>> + (cabal-environment '()))
>
> Instead of #:read-from-stdin?, what about adding a #:port argument?
> That way, it would either read from PORT, or fetch from Hackage. That
> seems more idiomatic and more flexible.
Absolutely! Changed.
>
> Also please mention it in the docstring.
Done.
>
>> -(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))))
>
> I’m a bit scared when we add new code *and* remove tests. ;-)
>
> Could you add a couple of representative tests? I’m sure you ran tests
> by hand at the REPL, so it should be a matter of adding them in the file.
The reason for deleting the test is that that particular function
doesn't exist anymore. The functionality that it did provide is now
integrated in the parser. So, I've added one new test which exercises
'read-cabal' with a bunch of nested conditionals.
Thanks for the review!
Fede
[-- Attachment #2: 0001-import-hackage-Refactor-parsing-code-and-add-new-opt.patch --]
[-- Type: text/x-diff, Size: 78952 bytes --]
From 8a28ed0f3c3077ce12d4924c59e317c52a68a77e Mon Sep 17 00:00:00 2001
From: Federico Beffa <beffa@fbengineering.ch>
Date: Sun, 26 Apr 2015 11:22:29 +0200
Subject: [PATCH] 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'.
---
Makefile.am | 4 +
doc/guix.texi | 22 +-
guix/import/cabal.scm | 815 ++++++++++++++++++++++++++++++++++++++++
guix/import/hackage.scm | 703 ++++------------------------------
guix/scripts/import/hackage.scm | 66 +++-
tests/hackage.scm | 88 +++--
6 files changed, 1017 insertions(+), 681 deletions(-)
create mode 100644 guix/import/cabal.scm
diff --git a/Makefile.am b/Makefile.am
index d54e281..b42a7f5 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -89,6 +89,8 @@ MODULES = \
guix/import/utils.scm \
guix/import/gnu.scm \
guix/import/snix.scm \
+ guix/import/cabal.scm \
+ guix/import/hackage.scm \
guix/scripts/download.scm \
guix/scripts/build.scm \
guix/scripts/archive.scm \
@@ -104,6 +106,7 @@ MODULES = \
guix/scripts/lint.scm \
guix/scripts/import/gnu.scm \
guix/scripts/import/nix.scm \
+ guix/scripts/import/hackage.scm \
guix/scripts/environment.scm \
guix/scripts/publish.scm \
guix.scm \
@@ -173,6 +176,7 @@ SCM_TESTS = \
tests/build-utils.scm \
tests/packages.scm \
tests/snix.scm \
+ tests/hackage.scm \
tests/store.scm \
tests/monads.scm \
tests/gexp.scm \
diff --git a/doc/guix.texi b/doc/guix.texi
index 70604b7..c70f833 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3199,16 +3199,30 @@ dependencies.
Specific command-line options are:
@table @code
+@item --stdin
+@itemx -s
+Read a Cabal file from the standard input.
@item --no-test-dependencies
@itemx -t
-Do not include dependencies only required to run the test suite.
+Do not include dependencies required by the test suites only.
+@item --cabal-environment=@var{alist}
+@itemx -e @var{alist}
+@var{alist} is a Scheme alist defining the environment in which the
+Cabal conditionals are evaluated. The accepted keys are: @code{os},
+@code{arch}, @code{impl} and a string representing the name of a flag.
+The value associated with a flag has to be either the symbol
+@code{true} or @code{false}. The value associated with other keys
+has to conform to the Cabal file format definition. The default value
+associated with the keys @code{os}, @code{arch} and @code{impl} is
+@samp{linux}, @samp{x86_64} and @samp{ghc} respectively.
@end table
The command below imports meta-data for the latest version of the
-@code{HTTP} Haskell package without including test dependencies:
+@code{HTTP} Haskell package without including test dependencies and
+specifying the value of the flag @samp{network-uri} as @code{false}:
@example
-guix import hackage -t HTTP
+guix import hackage -t -e "'((\"network-uri\" . false))" HTTP
@end example
A specific package version may optionally be specified by following the
@@ -3217,8 +3231,6 @@ 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
-
-Currently only indentation structured Cabal files are supported.
@end table
The structure of the @command{guix import} code is modular. It would be
diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
new file mode 100644
index 0000000..dfeba88
--- /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 1b27803..b5574a8 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
diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm
index f7c18cd..e5e9b0e 100644
--- a/guix/scripts/import/hackage.scm
+++ b/guix/scripts/import/hackage.scm
@@ -34,7 +34,9 @@
;;;
(define %default-options
- '((include-test-dependencies? . #t)))
+ '((include-test-dependencies? . #t)
+ (read-from-stdin? . #f)
+ ('cabal-environment . '())))
(define (show-help)
(display (_ "Usage: guix import hackage PACKAGE-NAME
@@ -45,8 +47,13 @@ package will be generated. If no version suffix is pecified, then the
generated package definition will correspond to the latest available
version.\n"))
(display (_ "
+ -e ALIST, --cabal-environment=ALIST
+ specify environment for Cabal evaluation"))
+ (display (_ "
-h, --help display this help and exit"))
(display (_ "
+ -s, --stdin read from standard input"))
+ (display (_ "
-t, --no-test-dependencies don't include test only dependencies"))
(display (_ "
-V, --version display version information and exit"))
@@ -67,6 +74,16 @@ version.\n"))
(alist-cons 'include-test-dependencies? #f
(alist-delete 'include-test-dependencies?
result))))
+ (option '(#\s "stdin") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'read-from-stdin? #t
+ (alist-delete 'read-from-stdin?
+ result))))
+ (option '(#\e "cabal-environment") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'cabal-environment (read/eval arg)
+ (alist-delete 'cabal-environment
+ result))))
%standard-import-options))
\f
@@ -84,23 +101,42 @@ version.\n"))
(alist-cons 'argument arg result))
%default-options))
+ (define (run-importer package-name opts error-fn)
+ (let ((sexp (hackage->guix-package
+ package-name
+ #:include-test-dependencies?
+ (assoc-ref opts 'include-test-dependencies?)
+ #:port (if (assoc-ref opts 'read-from-stdin?)
+ (current-input-port)
+ #f)
+ #:cabal-environment
+ (assoc-ref opts 'cabal-environment))))
+ (unless sexp (error-fn))
+ sexp))
+
(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~%"))))))
+ (if (assoc-ref opts 'read-from-stdin?)
+ (match args
+ (()
+ (run-importer "stdin" opts
+ (lambda ()
+ (leave (_ "failed to import cabal file from '~a'~%"))
+ package-name)))
+ ((many ...)
+ (leave (_ "too many arguments~%"))))
+ (match args
+ ((package-name)
+ (run-importer package-name opts
+ (lambda ()
+ (leave
+ (_ "failed to download cabal file for package '~a'~%"))
+ package-name)))
+ (()
+ (leave (_ "too few arguments~%")))
+ ((many ...)
+ (leave (_ "too many arguments~%")))))))
diff --git a/tests/hackage.scm b/tests/hackage.scm
index 23b854c..229bee3 100644
--- a/tests/hackage.scm
+++ b/tests/hackage.scm
@@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-hackage)
+ #:use-module (guix import cabal)
#:use-module (guix import hackage)
#:use-module (guix tests)
#:use-module (srfi srfi-64)
@@ -35,44 +36,44 @@ executable cabal
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
+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))
+;; A fragment of a real Cabal file with minor modification to check precedence
+;; of 'and' over 'or'.
+(define test-read-cabal-1
+ "name: test-me
+library
+ -- Choose which library versions to use.
+ if flag(base4point8)
+ Build-depends: base >= 4.8 && < 5
+ else
+ if flag(base4)
+ Build-depends: base >= 4 && < 4.8
+ else
+ if flag(base3)
+ Build-depends: base >= 3 && < 4
+ else
+ Build-depends: base < 3
+ if flag(base4point8) || flag(base4) && flag(base3)
+ Build-depends: random
+ Build-depends: containers
+
+ -- Modules that are always built.
+ Exposed-Modules:
+ Test.QuickCheck.Exception
+")
(test-begin "hackage")
@@ -115,18 +116,25 @@ executable cabal
(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)
+(test-assert "read-cabal test 1"
+ (match (call-with-input-string test-read-cabal-1 read-cabal)
+ ((("name" ("test-me"))
+ ('section 'library
+ (('if ('flag "base4point8")
+ (("build-depends" ("base >= 4.8 && < 5")))
+ (('if ('flag "base4")
+ (("build-depends" ("base >= 4 && < 4.8")))
+ (('if ('flag "base3")
+ (("build-depends" ("base >= 3 && < 4")))
+ (("build-depends" ("base < 3"))))))))
+ ('if ('or ('flag "base4point8")
+ ('and ('flag "base4") ('flag "base3")))
+ (("build-depends" ("random")))
+ ())
+ ("build-depends" ("containers"))
+ ("exposed-modules" ("Test.QuickCheck.Exception")))))
#t)
- (x
- (pk 'fail x #f))))
+ (x (pk 'fail x #f))))
(test-end "hackage")
--
2.2.1
^ permalink raw reply related [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-06-05 15:19 ` Federico Beffa
@ 2015-06-09 7:38 ` Ludovic Courtès
2015-06-09 8:38 ` Federico Beffa
0 siblings, 1 reply; 19+ messages in thread
From: Ludovic Courtès @ 2015-06-09 7:38 UTC (permalink / raw)
To: Federico Beffa; +Cc: Guix-devel
Federico Beffa <beffa@ieee.org> skribis:
> On Fri, Jun 5, 2015 at 9:30 AM, Ludovic Courtès <ludo@gnu.org> wrote:
[...]
>>> +(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)))))
>>
>> Fair enough. :-) I wonder what happens exactly when trying to return
>> monadic values in the parser.
>
> Given that the parser repeatedly calls the tunk generated by
> 'make-lexer' without passing any state or knowing anything about to
> which monad it may belong to, I thought that it would not work. But,
> as you see, I'm new to Scheme, new to monads, and new to Lisp in
> general.
I think the rules can return any kind of value, so there shouldn’t be a
problem with returning monadic values (of course it won’t bind them for
you, but that’s not a problem.) Anyway, an exercise for later. ;-)
>>> +;; Stack to track the structure of nested blocks
>>> +(define context-stack (make-stack))
>>
>> What about making it either a SRFI-39 parameter, or a parameter to
>> ‘make-cabal-parser’?
>
> I made it a parameter. Thanks for suggesting it! It made me realize
> what they are really used for :-)
> Do you think it is correct to say that they serve the purpose of
> special variables in Lisp? (I'm looking a little bit into Common Lisp
> as well.)
Not sure what you mean by “special variables” (and I’m not familiar with
CL), but the concept is fairly common: It’s dynamic scoping, which is
the default in elisp, sometimes called “fluids”, sometimes “parameters.”
> From 8a28ed0f3c3077ce12d4924c59e317c52a68a77e Mon Sep 17 00:00:00 2001
> From: Federico Beffa <beffa@fbengineering.ch>
> Date: Sun, 26 Apr 2015 11:22:29 +0200
> Subject: [PATCH] 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'.
OK to commit, thank you!
(I had not realized the hackage.scm files were missing from the Makefile
until now.)
Thanks,
Ludo’.
PS: Commit 751630c adds n-ary >>= for your pleasure. ;-)
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: hackage importer
2015-06-09 7:38 ` Ludovic Courtès
@ 2015-06-09 8:38 ` Federico Beffa
0 siblings, 0 replies; 19+ messages in thread
From: Federico Beffa @ 2015-06-09 8:38 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Guix-devel
On Tue, Jun 9, 2015 at 9:38 AM, Ludovic Courtès <ludo@gnu.org> wrote:
> OK to commit, thank you!
Pushed.
> PS: Commit 751630c adds n-ary >>= for your pleasure. ;-)
Thanks :-)
Fede
^ permalink raw reply [flat|nested] 19+ messages in thread
end of thread, other threads:[~2015-06-09 8:38 UTC | newest]
Thread overview: 19+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2015-04-26 11:52 hackage importer Federico Beffa
-- strict thread matches above, loose matches on Subject: below --
2015-03-13 17:59 Federico Beffa
2015-03-15 14:38 ` Ludovic Courtès
2015-03-15 22:29 ` Federico Beffa
2015-03-22 20:12 ` Federico Beffa
2015-03-26 13:09 ` Ludovic Courtès
2015-03-28 8:53 ` Federico Beffa
2015-03-29 13:58 ` Ludovic Courtès
2015-03-29 16:55 ` Federico Beffa
2015-03-31 13:33 ` Ludovic Courtès
2015-04-03 13:01 ` Federico Beffa
2015-04-05 18:24 ` Ludovic Courtès
2015-04-26 11:38 ` Federico Beffa
2015-05-02 12:48 ` Ludovic Courtès
2015-06-01 15:20 ` Federico Beffa
2015-06-05 7:30 ` Ludovic Courtès
2015-06-05 15:19 ` Federico Beffa
2015-06-09 7:38 ` Ludovic Courtès
2015-06-09 8:38 ` Federico Beffa
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.