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