[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: import: hackage: Refactor parsing code and add new options.
|
From: |
Federico Beffa |
|
Subject: |
01/01: import: hackage: Refactor parsing code and add new options. |
|
Date: |
Tue, 09 Jun 2015 08:06:41 +0000 |
beffa pushed a commit to branch master
in repository guix.
commit a4154748730b28fd98ff30d968c755c37802a49a
Author: Federico Beffa <address@hidden>
Date: Sun Apr 26 11:22:29 2015 +0200
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(-)
diff --git a/Makefile.am b/Makefile.am
index 6478aeb..2b84467 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -93,6 +93,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 \
@@ -108,6 +110,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 \
@@ -178,6 +181,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 c62e44e..be7a292 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3754,16 +3754,30 @@ dependencies.
Specific command-line options are:
@table @code
address@hidden --stdin
address@hidden -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.
address@hidden address@hidden
address@hidden -e @var{alist}
address@hidden is a Scheme alist defining the environment in which the
+Cabal conditionals are evaluated. The accepted keys are: @code{os},
address@hidden, @code{impl} and a string representing the name of a flag.
+The value associated with a flag has to be either the symbol
address@hidden 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
address@hidden, @samp{x86_64} and @samp{ghc} respectively.
@end table
The command below imports meta-data for the latest version of the
address@hidden Haskell package without including test dependencies:
address@hidden 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
@@ -3772,8 +3786,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 <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix import 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))
@@ -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")