mirror of git://git.savannah.gnu.org/guix.git
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
parent
0705f79c6f
commit
a415474873
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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~%")))))))
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue