nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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'.
This commit is contained in:
Federico Beffa 2015-04-26 11:22:29 +02:00
parent 0705f79c6f
commit a415474873
6 changed files with 1015 additions and 679 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile.am
View File

@ -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 \

22
doc/guix.texi
View File

@ -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

815
guix/import/cabal.scm Normal file
View File

@ -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

701
guix/import/hackage.scm
View File

@ -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"))))))
,@(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 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?))))
(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

66
guix/scripts/import/hackage.scm
View File

@ -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~%")))))))

86
tests/hackage.scm
View File

@ -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)")
;; 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
(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))
-- 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")