From bc8cdab1e322a25002a3d9cf33eddd856c8a81d8 Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Sun, 26 Apr 2015 11:22:29 +0200 Subject: [PATCH] import: hackage: Refactor parsing code and add new option. * guix/import/cabal.scm: New file. * guix/import/hackage.scm: Update to use the new Cabal parsing module. * tests/hackage.scm: Update tests for private functions. * guix/scripts/import/hackage.scm: Add new '--cabal-environment' option. * doc/guix.texi: ... and document it. * Makefile.am (MODULES): Add 'guix/import/cabal.scm', 'guix/import/hackage.scm' and 'guix/scripts/import/hackage.scm'. (SCM_TESTS): Add 'tests/hackage.scm'. --- Makefile.am | 4 + doc/guix.texi | 17 +- guix/import/cabal.scm | 902 ++++++++++++++++++++++++++++++++++++++++ guix/import/hackage.scm | 691 ++++-------------------------- guix/scripts/import/hackage.scm | 14 +- tests/hackage.scm | 18 +- 6 files changed, 1009 insertions(+), 637 deletions(-) create mode 100644 guix/import/cabal.scm diff --git a/Makefile.am b/Makefile.am index d54e281..b42a7f5 100644 --- a/Makefile.am +++ b/Makefile.am @@ -89,6 +89,8 @@ MODULES = \ guix/import/utils.scm \ guix/import/gnu.scm \ guix/import/snix.scm \ + guix/import/cabal.scm \ + guix/import/hackage.scm \ guix/scripts/download.scm \ guix/scripts/build.scm \ guix/scripts/archive.scm \ @@ -104,6 +106,7 @@ MODULES = \ guix/scripts/lint.scm \ guix/scripts/import/gnu.scm \ guix/scripts/import/nix.scm \ + guix/scripts/import/hackage.scm \ guix/scripts/environment.scm \ guix/scripts/publish.scm \ guix.scm \ @@ -173,6 +176,7 @@ SCM_TESTS = \ tests/build-utils.scm \ tests/packages.scm \ tests/snix.scm \ + tests/hackage.scm \ tests/store.scm \ tests/monads.scm \ tests/gexp.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 70604b7..453e71f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3201,14 +3201,25 @@ Specific command-line options are: @table @code @item --no-test-dependencies @itemx -t -Do not include dependencies only required to run the test suite. +Do not include dependencies only required to run the test suites. address@hidden address@hidden address@hidden -e @var{alist} address@hidden is a Scheme alist defining the environment in which the +Cabal conditionals are evaluated. The accepted keys are: @samp{os}, address@hidden, @samp{impl} and a string representing the name of a flag. +The value associated with a flag has to be either the symbol address@hidden'true'} or @verb{'false'}. The value associated with other keys +has to conform to the Cabal file format definition. The default value +associated with the keys @samp{os}, @samp{arch} and @samp{impl} is address@hidden, @samp{x86_64} and @samp{ghc} respectively. @end table The command below imports meta-data for the latest version of the address@hidden Haskell package without including test dependencies: address@hidden Haskell package without including test dependencies and +specifying the value of the flag @samp{network-uri} as @verb{'false'}: @example -guix import hackage -t HTTP +guix import hackage -t -e "'((\"network-uri\" . false))" HTTP @end example A specific package version may optionally be specified by following the diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm new file mode 100644 index 0000000..fd4bbd6 --- /dev/null +++ b/guix/import/cabal.scm @@ -0,0 +1,902 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Federico Beffa +;;; +;;; 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 . + +(define-module (guix import cabal) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (guix monads) + #:export (read-cabal + parse-cabal + eval-cabal + + cabal-package? + cabal-package-name + cabal-package-version + cabal-package-license + cabal-package-home-page + cabal-package-source-repository + cabal-package-synopsis + cabal-package-description + cabal-package-executables + cabal-package-library + cabal-package-test-suites + cabal-package-flags + cabal-package-eval-environment + + cabal-source-repository? + cabal-source-repository-use-case + cabal-source-repository-type + cabal-source-repository-location + + cabal-flag? + cabal-flag-name + cabal-flag-description + cabal-flag-default + cabal-flag-manual + + cabal-dependency? + cabal-dependency-name + cabal-dependency-version + + cabal-executable? + cabal-executable-name + cabal-executable-dependencies + + cabal-library? + cabal-library-dependencies + + cabal-test-suite? + cabal-test-suite-name + cabal-test-suite-dependencies)) + +;; Part 1: +;; +;; Functions used to read a Cabal file. + +;; This record stores the state information needed during parsing of Cabal +;; files. +(define-record-type + (make-cabal-parse-state lines minimum-indent indents conditionals + true-group? true-group false-group + true-group?-stack true-group-stack false-group-stack) + cabal-parse-state? + (lines cabal-parse-state-lines) + (minimum-indent cabal-parse-state-minimum-indent) + (indents cabal-parse-state-indents) + (conditionals cabal-parse-state-conditionals) + (true-group? cabal-parse-state-true-group?) + (true-group cabal-parse-state-true-group) + (false-group cabal-parse-state-false-group) + (true-group?-stack cabal-parse-state-true-group?-stack) + (true-group-stack cabal-parse-state-true-group-stack) + (false-group-stack cabal-parse-state-false-group-stack)) + +(define key-value-rx + ;; Regular expression matching "key: value" + (make-regexp "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$")) + +(define comment-rx + ;; Regexp matching Cabal comment lines. + (make-regexp "^ *--")) + +(define (has-key? line) + "Check if LINE includes a key." + (regexp-exec key-value-rx line)) + +(define (comment-line? line) + "Check if LINE is a comment line." + (regexp-exec comment-rx line)) + +(define (line-indentation+rest line) + "Returns two results: The number of indentation spaces and the rest of +LINE (without indentation)." + (let loop ((line-lst (string->list line)) + (count 0)) + ;; Sometimes values are spread over multiple lines and new lines start + ;; with a comma ',' with the wrong indentation. See e.g. haddock-api. + (if (or (null? line-lst) + (not (or + (eqv? (first line-lst) #\space) + (eqv? (first line-lst) #\,) + (eqv? (first line-lst) #\tab)))) + (values count (list->string line-lst)) + (loop (cdr line-lst) (+ count 1))))) + +(define (multi-line-value lines seed) + "Function to read a value split across multiple lines. LINES are the +remaining input lines to be read. SEED is the value read on the same line as +the key. Return two values: A list with the values and the remaining lines to +be processed." + (define (multi-line-value-with-min-indent lines seed min-indent) + (if (null? lines) + (values '() '()) + (let-values (((current-indent value) (line-indentation+rest (first lines))) + ((next-line-indent next-line-value) + (if (null? (cdr lines)) + (values #f "") + (line-indentation+rest (second lines))))) + (if (or (not next-line-indent) (< next-line-indent min-indent) + (regexp-exec condition-rx next-line-value)) + (values (reverse (cons value seed)) (cdr lines)) + (multi-line-value-with-min-indent (cdr lines) (cons value seed) + min-indent))))) + + (let-values (((current-indent value) (line-indentation+rest (first lines)))) + (multi-line-value-with-min-indent lines seed current-indent))) + +(define (read-and-trim-line port) + (let ((line (read-line port))) + (if (string? line) + (string-trim-both line #\return) + line))) + +(define (strip-insignificant-lines port) + (let loop ((line (read-and-trim-line port)) + (result '())) + (cond + ((eof-object? line) + (reverse result)) + ((or (string-null? line) (comment-line? line)) + (loop (read-and-trim-line port) result)) + (else + (loop (read-and-trim-line port) (cons line result)))))) + +(define (read-cabal port) + "Parses a Cabal file from PORT. Return an S-expression representing the +content of the file. We try do deduce the Cabal format from the following +document: https://www.haskell.org/cabal/users-guide/developing-packages.html. +Keys are case-insensitive. We therefore lowercase them. Values are +case-sensitive. Currently only indentation-structured files are parsed. +Braces structured files are not handled." + (let ((lines (strip-insignificant-lines port))) + (call-with-values + (lambda () + (run-with-state (parse-cabal '()) + (make-cabal-parse-state lines -1 '() '() #t '() '() '() '() '()))) + (lambda (result state) result)))) + +(define (parse-cabal result) + "Parse a Cabal file and append its content to RESULT (a list). Return the +updated result as a monadic value in the state monad." + (mlet* %state-monad ((state (current-state))) + (match state + (($ lines minimum-indent indents conditionals + true-group? true-group false-group + true-group?-stack true-group-stack + false-group-stack) + (let*-values + (((current-indent line) + (if (null? lines) + (values 0 "") + (line-indentation+rest (first lines)))) + ((next-line-indent next-line) + (if (or (null? lines) (null? (cdr lines))) + (values 0 "") + (line-indentation+rest (second lines)))) + ((key-value-rx-result) (has-key? line)) + ((end-of-file?) (null? lines)) + ((is-simple-key-value?) (and (= next-line-indent current-indent) + key-value-rx-result)) + ((is-multi-line-key-value?) (and (> next-line-indent current-indent) + key-value-rx-result)) + ((key) (and=> key-value-rx-result + (lambda (rx-res) + (string-downcase (match:substring rx-res 1))))) + ((value) (and=> key-value-rx-result (cut match:substring <> 2)))) + (cond + (end-of-file? (return (reverse result))) + (is-simple-key-value? + (>>= (state-add-entry (list key `(,value)) result (cdr lines)) + parse-cabal)) + (is-multi-line-key-value? + (let*-values + (((value-lst lines) + (multi-line-value (cdr lines) + (if (string-null? value) '() `(,value))))) + (>>= (state-add-entry (list key value-lst) result lines) + parse-cabal))) + (else ; it's a section + (let* ((section-header (string-tokenize (string-downcase line))) + (section-type (string->symbol (first section-header))) + (section-name (if (> (length section-header) 1) + (second section-header) + ""))) + (mbegin %current-monad + (set-current-state + (set-fields state + ((cabal-parse-state-minimum-indent) current-indent) + ((cabal-parse-state-lines) (cdr lines)))) + (>>= + (>>= (parse-cabal-section '()) + (lambda (section-contents) + (mlet* %state-monad ((state (current-state))) + (mbegin %current-monad + (set-current-state + (set-fields state + ((cabal-parse-state-minimum-indent) -1))) + (return + (cons (append + (if (string-null? section-name) + (list 'section section-type) + (list 'section section-type section-name)) + (list section-contents)) + result)))))) + parse-cabal)))))))))) + +(define (parse-cabal-section result) + "Parse a section of a cabal file and append its content to RESULT (a list). +Return the updated result as a value in the state monad." + (mlet* %state-monad ((state (current-state))) + (match state + (($ lines minimum-indent indents conditionals + true-group? true-group false-group + true-group?-stack true-group-stack + false-group-stack) + (let*-values + (((current-indent line) + (if (null? lines) + (values 0 "") + (line-indentation+rest (first lines)))) + ((next-line-indent next-line) + (if (or (null? lines) (null? (cdr lines))) + (values 0 "") + (line-indentation+rest (second lines)))) + ((key-value-rx-result) (has-key? line)) + ((end-of-section?) (or (<= current-indent minimum-indent) + (null? lines))) + ;; If this is the last line of the section, then it can't be the + ;; start of a conditional or an 'else'. + ((last-line-of-section?) (<= next-line-indent minimum-indent)) + ((is-simple-key-value?) (or (and (= next-line-indent current-indent) + key-value-rx-result) + (and (pair? conditionals) + (= next-line-indent (first indents)) + (string-prefix? "else" next-line)))) + ((is-multi-line-key-value?) (and (> next-line-indent current-indent) + key-value-rx-result)) + ((end-of-cond?) + (and (pair? conditionals) + (or (and (= next-line-indent (first indents)) + (not (string-prefix? "else" next-line))) + (< next-line-indent (first indents))))) + ((is-else?) (and (pair? conditionals) + (= current-indent (first indents)) + (string-prefix? "else" line))) + ((condition) (cabal-conditional-line->sexp line)) + ((key) (and=> key-value-rx-result + (lambda (rx-res) + (string-downcase (match:substring rx-res 1))))) + ((value) (and=> key-value-rx-result + (cut match:substring <> 2)))) + (cond + (end-of-section? + (if (pair? indents) + (state-reduce-indentation (1- (length indents)) #f result lines) + (return result))) + (last-line-of-section? + (if (pair? indents) + (state-reduce-indentation + (1- (length indents)) (list key `(,value)) result (cdr lines)) + (mbegin %current-monad + (set-current-state + (set-fields state ((cabal-parse-state-lines) (cdr lines)))) + (return (cons (list key `(,value)) result))))) + (is-simple-key-value? + (>>= (state-add-entry (list key `(,value)) result (cdr lines)) + parse-cabal-section)) + (is-multi-line-key-value? + (let*-values + ;; VALUE-LST is the full multi-line value and LINES are the + ;; remaining lines to be parsed (from the line following the + ;; multi-line value). We need to check if we are at the end of + ;; a conditional or at the end of the section. + (((value-lst lines) + (multi-line-value (cdr lines) + (if (string-null? value) '() `(,value)))) + ((ind line) (if (null? lines) + (values 0 "") + (line-indentation+rest (first lines)))) + ((end-of-cond?) (and (pair? conditionals) + (or (and (= ind (first indents)) + (not (string-prefix? "else" line))) + (< ind (first indents))))) + ;; If IND is not in INDENTS, assume that we are at the end of + ;; the section. + ((idx) (or (and=> + (list-index (cut = ind <>) indents) + (cut + <> (if (string-prefix? "else" line) -1 0))) + (1- (length indents))))) + (if end-of-cond? + (>>= (state-reduce-indentation idx (list key value-lst) + result lines) + parse-cabal-section) + (>>= (state-add-entry (list key value-lst) result lines) + parse-cabal-section)))) + (end-of-cond? + (let ((idx (+ (list-index (cut = next-line-indent <>) indents) + (if (string-prefix? "else" next-line) -1 0)))) + (>>= (state-reduce-indentation idx (list key `(,value)) result + (if (pair? lines) (cdr lines) '())) + parse-cabal-section))) + (is-else? + (mbegin %current-monad + (set-current-state + (set-fields state + ((cabal-parse-state-lines) (cdr lines)) + ((cabal-parse-state-true-group?) #f))) + (parse-cabal-section result))) + (condition + (mbegin %current-monad + (state-add-conditional condition current-indent) + (parse-cabal-section result))))))))) + +(define (state-reduce-indentation index entry result lines) + "Given RESULT, if ENTRY is not #f, add it as appropriate and return the +updated result as a value in the state monad. Update the state according to +the reduction of the indentation level specified by INDEX, an index of an +entry in the 'indentations' field of the state. As an example, if there are +two nested conditional levels, the first starting at indentation 2 and the +second at indentation 4, then the 'indentations' field of state is '(4 2) and +an INDEX value of 0 means that the second conditional is finished. Set the +remaining lines to be parsed to LINES." + (lambda (state) + (match state + (($ _ minimum-indent indents conditionals + true-group? true-group false-group + true-group?-stack true-group-stack + false-group-stack) + ;; The suffix '-d' stays for 'drop'. + (let*-values (((inds-d inds) (split-at indents (1+ index))) + ((conds-d conds) (split-at conditionals (1+ index))) + ((t-g?-s-d t-g?-s) + (if (> (length true-group?-stack) index) + (split-at true-group?-stack (1+ index)) + (values true-group?-stack '()))) + ((t-g-s-d t-g-s) + (if (> (length true-group-stack) index) + (split-at true-group-stack (1+ index)) + (values true-group-stack '()))) + ((f-g-s-d f-g-s) + (if (> (length false-group-stack) index) + (split-at false-group-stack (1+ index)) + (values false-group-stack '()))) + ((t-g?) + (if (> (length true-group?-stack) index) + (last t-g?-s-d) #t)) + ((t-g) (if (and true-group? entry) + (cons entry true-group) + true-group)) + ((f-g) (if (or true-group? (not entry)) + false-group + (cons entry false-group))) + ((res) result)) + (let reduce-by-one ((conds-d conds-d) (t-g t-g) (f-g f-g) (res res) + (t-g?-s-d t-g?-s-d) (t-g-s-d t-g-s-d) + (f-g-s-d f-g-s-d)) + (cond + ((null? conds-d) + (values res + (set-fields state + ((cabal-parse-state-lines) lines) + ((cabal-parse-state-indents) inds) + ((cabal-parse-state-conditionals) conds) + ((cabal-parse-state-true-group?) t-g?) + ((cabal-parse-state-true-group) t-g) + ((cabal-parse-state-false-group) f-g) + ((cabal-parse-state-true-group?-stack) t-g?-s) + ((cabal-parse-state-true-group-stack) t-g-s) + ((cabal-parse-state-false-group-stack) f-g-s)))) + ((null? t-g?-s-d) + (reduce-by-one (cdr conds-d) '() '() + (cons `(if ,(first conds-d) ,t-g ,f-g) res) + t-g?-s t-g-s f-g-s)) + ((first t-g?-s-d) + (reduce-by-one (cdr conds-d) + (cons `(if ,(first conds-d) ,t-g ,f-g) + (first t-g-s-d)) + (first f-g-s-d) res + (cdr t-g?-s-d) (cdr t-g-s-d) (cdr f-g-s-d))) + (else + (reduce-by-one (cdr conds-d) (first t-g-s-d) + (cons `(if ,(first conds-d) ,t-g ,f-g) + (first f-g-s-d)) + res + (cdr t-g?-s-d) (cdr t-g-s-d) (cdr f-g-s-d)))))))))) + +(define (state-add-entry entry result lines) + "Given the current RESULT, adds ENTRY as appropriate. Set the remaining +lines to be parsed to LINES. Retrun the updated result as a value in the +state monad." + (lambda (state) + (match state + (($ _ minimum-indent indents conditionals + true-group? true-group false-group + true-group?-stack true-group-stack + false-group-stack) + (cond + ((null? conditionals) + (values (cons entry result) + (set-fields state + ((cabal-parse-state-lines) lines)))) + (true-group? + (values result + (set-fields state + ((cabal-parse-state-true-group) + (cons entry true-group)) + ((cabal-parse-state-lines) lines)))) + (else + (values result + (set-fields state + ((cabal-parse-state-false-group) + (cons entry false-group)) + ((cabal-parse-state-lines) lines))))))))) + +(define (state-add-conditional condition indentation) + "Add CONDITION at INDENTATION level to the current state. Return the value +*unspecified* in the state monad." + (lambda (state) + (match state + (($ lines minimum-indent indents conditionals + true-group? true-group false-group + true-group?-stack true-group-stack + false-group-stack) + (if (null? conditionals) + (values '*unspecified* + (set-fields state + ((cabal-parse-state-lines) (cdr lines)) + ((cabal-parse-state-conditionals) + (cons condition conditionals)) + ((cabal-parse-state-indents) + (cons indentation indents)) + ((cabal-parse-state-true-group?) #t))) + (values '*unspecified* + (set-fields state + ((cabal-parse-state-lines) (cdr lines)) + ((cabal-parse-state-conditionals) + (cons condition conditionals)) + ((cabal-parse-state-indents) + (cons indentation indents)) + ((cabal-parse-state-true-group?) #t) + ((cabal-parse-state-true-group) '()) + ((cabal-parse-state-false-group) '()) + ((cabal-parse-state-true-group?-stack) + (cons true-group? true-group?-stack)) + ((cabal-parse-state-true-group-stack) + (cons true-group true-group-stack)) + ((cabal-parse-state-false-group-stack) + (cons false-group false-group-stack))))))))) + +(define condition-rx + ;; Regexp for conditionals. + (make-regexp "^if +(.*)$")) + +(define (cabal-extract-condition line) + "Extract the test condition from a conditional LINE." + (let ((rx-result (regexp-exec condition-rx (string-downcase line)))) + (if rx-result (match:substring rx-result 1) #f))) + +(define (cabal-conditional-line->sexp line) + "Extract the test condition from LINE and convert it into an S-expression." + (let ((conditional (cabal-extract-condition line))) + (and=> conditional + (compose cabal-test-keywords->sexp + cabal-conditional->sexp-like + cabal-impl-with-and->impl-and)))) + +(define parens-rx + ;; Parentheses within conditions + (make-regexp "\\((.+)\\)")) + +(define or-rx + ;; OR operator in conditions + (make-regexp " *\\|\\| *")) + +(define and-rx + ;; AND operator in conditions + (make-regexp " *&& *")) + +(define not-rx + ;; NOT operator in conditions + (make-regexp "^!.+")) + +(define (bi-op-args str match-lst) + "Return a list with the arguments of (logic) bianry operators. MATCH-LST +is the result of 'list-match' against a binary operator regexp on STR." + (let ((operators (length match-lst))) + (map (lambda (from to) + (substring str from to)) + (cons 0 (map match:end match-lst)) + (append (map match:start match-lst) (list (string-length str)))))) + +(define (bi-op->sexp-like bi-op args) + "BI-OP is a string with the name of a Scheme operator which in a Cabal file +is represented by a binary operator. ARGS are the arguments of said operator. +Return a string representing an S-expression of the operator applied to its +arguments." + (if (= (length args) 1) + (first args) + (string-append "(" bi-op + (fold (lambda (arg seed) (string-append seed " " arg)) + "" args) ")"))) + +(define (not->sexp-like arg) + "If the string ARG is prefixed by a Cabal negation operator, convert it to +an equivalent Scheme S-expression string." + (if (regexp-exec not-rx arg) + (string-append "(not " + (substring arg 1 (string-length arg)) + ")") + arg)) + +(define (parens-less-cond->sexp-like conditional) + "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme +syntax. This procedure accepts only simple conditionals without parentheses." + ;; The outher operation is the one with the lowest priority: OR + (bi-op->sexp-like + "or" + ;; each OR argument may be an AND operation + (map (lambda (or-arg) + (let ((m-lst (list-matches and-rx or-arg))) + ;; is there an AND operation? + (if (> (length m-lst) 0) + (bi-op->sexp-like + "and" + ;; expand NOT operators when there are ANDs + (map not->sexp-like (bi-op-args or-arg m-lst))) + ;; ... and when there aren't. + (not->sexp-like or-arg)))) + ;; list of OR arguments + (bi-op-args conditional (list-matches or-rx conditional))))) + +(define test-keyword-ornament "__") + +(define tests-rx + ;; Cabal test keywords + (make-regexp "(os|arch|flag|impl) *\\(([ a-zA-Z0-9_.<>=-]+)\\)")) + +(define impl-with-and + (make-regexp + "(impl) *\\(([ a-zA-Z0-9_-]+) *([ 0-9_.<>=-]+) *(&&) *([ 0-9_.<>=-]+) *\\)")) + +(define (cabal-impl-with-and->impl-and conditional) + "Transform any compiler version range specificication appearing in +CONDITIONAL into two specifications and an 'and' conjunction. For example, +the specification \"impl(ghc >= 7.2 && < 7.6)\" is transformed into +\"impl(ghc >= 7.2 ) && impl(ghc < 7.6)\"." + (regexp-substitute/global #f impl-with-and + conditional + 'pre 1 "(" 2 3 ") " 4 " " 1 "(" 2 5 ")" 'post)) + +(define (cabal-conditional->sexp-like conditional) + "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme +syntax." + ;; First we substitute TEST-KEYWORD-ORNAMENT for parentheses around tests + ;; keywords so that parentheses are only used to set precedences. This + ;; substantially simplify parsing. + (let ((conditional + (regexp-substitute/global #f tests-rx conditional + 'pre 1 test-keyword-ornament 2 + test-keyword-ornament 'post))) + (let loop ((sub-cond conditional)) + (let ((rx-result (regexp-exec parens-rx sub-cond))) + (cond + (rx-result + (parens-less-cond->sexp-like + (string-append + (match:prefix rx-result) + (loop (match:substring rx-result 1)) + (match:suffix rx-result)))) + (else + (parens-less-cond->sexp-like sub-cond))))))) + +(define (cabal-test-keywords->sexp sexp-like-cond) + "In the string SEXP-LIKE-COND substitute test keywords \"os(...)\" and +\"arch(...)\" with equivalent Scheme checks. Retrun an S-expression." + (with-input-from-string + (fold-right + (lambda (test sexp) + (match test + ((type pre-match post-match) + (let ((rx (make-regexp + (string-append type test-keyword-ornament + " *([a-zA-Z0-9_-]+) *([<>=]*) *([0-9.]*) *" + test-keyword-ornament)))) + (regexp-substitute/global + #f rx sexp + 'pre pre-match 2 3 4 post-match 'post))) + (_ sexp))) + sexp-like-cond + '(("(os)" "(os \"" "\")") + ("(arch)" "(arch \"" "\")") + ("(impl)" "(impl \"" "\")") + ("(flag)" "(flag \"" "\")"))) + read)) + +;; Part 2: +;; +;; Evaluate the S-expression returned by 'read-cabal'. + +;; This defines the object and interface that we provide to access the Cabal +;; file information. Note that this does not include all the pieces of +;; information of the Cabal file, but only the ones we currently are +;; interested in. +(define-record-type + (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! + (lambda (package port) + (format port "#" + (cabal-package-name package) + (cabal-package-version package)))) + +(define-record-type + (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 + (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! + (lambda (package port) + (format port "#" + (cabal-flag-name package) + (cabal-flag-default package)))) + +(define-record-type + (make-cabal-dependency name version) + cabal-dependency? + (name cabal-dependency-name) + (version cabal-dependency-version)) + +(define-record-type + (make-cabal-executable name dependencies) + cabal-executable? + (name cabal-executable-name) + (dependencies cabal-executable-dependencies)) ; list of + +(define-record-type + (make-cabal-library dependencies) + cabal-library? + (dependencies cabal-library-dependencies)) ; list of + +(define-record-type + (make-cabal-test-suite name dependencies) + cabal-test-suite? + (name cabal-test-suite-name) + (dependencies cabal-test-suite-dependencies)) ; list of + +(define (cabal-flags->alist flag-list) + "Retrun an alist associating the flag name to its default value from a +list of objects." + (map (lambda (flag) (cons (cabal-flag-name flag) (cabal-flag-default flag))) + flag-list)) + +(define (eval-cabal cabal-sexp env) + "Given the CABAL-SEXP produced by 'read-cabal', evaluate all conditionals +and return a 'cabal-package' object. The values of all tests can be +overwritten by specifying the desired value in ENV. ENV must be an alist. +The accepted keys are: \"os\", \"arch\", \"impl\" and a name of a flag. The +value associated with a flag has to be either \"true\" or \"false\". The +value associated with other keys has to conform to the Cabal file format +definition." + (define (os name) + (let ((env-os (or (assoc-ref env "os") "linux"))) + (string-match env-os name))) + + (define (arch name) + (let ((env-arch (or (assoc-ref env "arch") "x86_64"))) + (string-match env-arch name))) + + (define (impl haskell) + (let* ((haskell-implementation (or (assoc-ref env "impl") "ghc")) + (impl-rx-result-with-version + (string-match "([a-zA-Z0-9_]+)-([0-9.]+)" haskell-implementation)) + (impl-name (or (and=> impl-rx-result-with-version + (cut match:substring <> 1)) + haskell-implementation)) + (impl-version (and=> impl-rx-result-with-version + (cut match:substring <> 2))) + (cabal-rx-result-with-version + (string-match "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *" haskell)) + (cabal-rx-result-without-version + (string-match "([a-zA-Z0-9_-]+)" haskell)) + (cabal-impl-name (or (and=> cabal-rx-result-with-version + (cut match:substring <> 1)) + (match:substring + cabal-rx-result-without-version 1))) + (cabal-impl-version (and=> cabal-rx-result-with-version + (cut match:substring <> 3))) + (cabal-impl-operator (and=> cabal-rx-result-with-version + (cut match:substring <> 2))) + (comparison (and=> cabal-impl-operator + (cut string-append "string" <>)))) + (if (and cabal-impl-version impl-version) + (eval-string + (string-append "(string" cabal-impl-operator + " \"" haskell-implementation "\"" + " \"" cabal-impl-name "-" cabal-impl-version "\")")) + (string-match cabal-impl-name impl-name)))) + + (define (cabal-flags) + (make-cabal-section cabal-sexp 'flag)) + + (define (flag name) + (let ((value (or (assoc-ref env name) + (assoc-ref (cabal-flags->alist (cabal-flags)) name)))) + (if (eq? value 'false) #f #t))) + + (define (eval sexp) + (match sexp + (() '()) + ;; nested 'if' + ((('if predicate true-group false-group) rest ...) + (append (if (eval predicate) + (eval true-group) + (eval false-group)) + (eval rest))) + (('if predicate true-group false-group) + (if (eval predicate) + (eval true-group) + (eval false-group))) + (('flag name) (flag name)) + (('os name) (os name)) + (('arch name) (arch name)) + (('impl name) (impl name)) + (('not name) (not (eval name))) + ;; 'and' and 'or' aren't functions, thus we can't use apply + (('and args ...) (fold (lambda (e s) (and e s)) #t (eval args))) + (('or args ...) (fold (lambda (e s) (or e s)) #f (eval args))) + ;; no need to evaluate flag parameters + (('section 'flag name parameters) + (list 'section 'flag name parameters)) + ;; library do not have a name parameter + (('section 'library parameters) + (list 'section 'library (eval parameters))) + (('section type name parameters) + (list 'section type name (eval parameters))) + (((? string? name) values) + (list name values)) + ((element rest ...) + (cons (eval element) (eval rest))) + (_ (raise (condition + (&message (message "Failed to evaluate Cabal file. \ +See the manual for limitations."))))))) + + (define (cabal-evaluated-sexp->package evaluated-sexp) + (let* ((name (lookup-join evaluated-sexp "name")) + (version (lookup-join evaluated-sexp "version")) + (license (lookup-join evaluated-sexp "license")) + (home-page (lookup-join evaluated-sexp "homepage")) + (home-page-or-hackage + (if (string-null? home-page) + (string-append "http://hackage.haskell.org/package/" name) + home-page)) + (source-repository (make-cabal-section evaluated-sexp + 'source-repository)) + (synopsis (lookup-join evaluated-sexp "synopsis")) + (description (lookup-join evaluated-sexp "description")) + (executables (make-cabal-section evaluated-sexp 'executable)) + (lib (make-cabal-section evaluated-sexp 'library)) + (test-suites (make-cabal-section evaluated-sexp 'test-suite)) + (flags '()) + (eval-environment '())) + (make-cabal-package name version license home-page-or-hackage + source-repository synopsis description executables lib + test-suites flags eval-environment))) + + ((compose cabal-evaluated-sexp->package eval) cabal-sexp)) + +(define (make-cabal-section sexp section-type) + "Given an SEXP as produced by 'read-cabal', produce a list of objects +pertaining to SECTION-TYPE sections. SECTION-TYPE must be one of: +'executable, 'flag, 'test-suite, 'source-repository or 'library." + (filter-map (cut match <> + (('section (? (cut equal? <> section-type)) name parameters) + (case section-type + ((test-suite) (make-cabal-test-suite + name (dependencies parameters))) + ((executable) (make-cabal-executable + name (dependencies parameters))) + ((source-repository) (make-cabal-source-repository + name + (lookup-join parameters "type") + (lookup-join parameters "location"))) + ((flag) + (let* ((default (lookup-join parameters "default")) + (default-true-or-false + (if (and default (string-ci=? "false" default)) + 'false + 'true)) + (description (lookup-join parameters "description")) + (manual (lookup-join parameters "manual")) + (manual-true-or-false + (if (and manual (string-ci=? "true" manual)) + 'true + 'false))) + (make-cabal-flag name description + default-true-or-false + manual-true-or-false))) + (else #f))) + (('section (? (cut equal? <> section-type) lib) parameters) + (make-cabal-library (dependencies parameters))) + (_ #f)) + sexp)) + +(define* (lookup-join key-values-list key #:optional (delimiter " ")) + "Lookup and joint all values pertaining to keys of value KEY in +KEY-VALUES-LIST. The optional DELIMITER is used to specify a delimiter string +to be added between the values found in different key/value pairs." + (string-join + (filter-map (cut match <> + (((? (lambda(x) (equal? x key))) value) + (string-join value delimiter)) + (_ #f)) + key-values-list) + delimiter)) + +(define dependency-name-version-rx + (make-regexp "([a-zA-Z0-9_-]+) *(.*)")) + +(define (dependencies key-values-list) + "Return a list of 'cabal-dependency' objects for the dependencies found in +KEY-VALUES-LIST." + (let ((deps (string-tokenize (lookup-join key-values-list "build-depends" ",") + (char-set-complement (char-set #\,))))) + (map (lambda (d) + (let ((rx-result (regexp-exec dependency-name-version-rx d))) + (make-cabal-dependency + (match:substring rx-result 1) + (match:substring rx-result 2)))) + deps))) + +;;; cabal.scm ends here diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 1b27803..478d42c 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -18,28 +18,19 @@ (define-module (guix import hackage) #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 receive) - #:use-module (ice-9 pretty-print) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (srfi srfi-11) #:use-module (srfi srfi-1) #:use-module ((guix download) #:select (download-to-store)) #:use-module ((guix utils) #:select (package-name->name+version)) #:use-module (guix import utils) + #:use-module (guix import cabal) #:use-module (guix store) #:use-module (guix hash) #:use-module (guix base32) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (hackage->guix-package)) -;; Part 1: -;; -;; Functions used to read a Cabal file. - (define ghc-standard-libraries ;; List of libraries distributed with ghc (7.8.4). We include GHC itself as ;; some packages list it. @@ -75,588 +66,12 @@ (define package-name-prefix "ghc-") -(define key-value-rx - ;; Regular expression matching "key: value" - (make-regexp "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$")) - -(define sections-rx - ;; Regular expression matching a section "head sub-head ..." - (make-regexp "([a-zA-Z0-9\\(\\)-]+)")) - -(define comment-rx - ;; Regexp matching Cabal comment lines. - (make-regexp "^ *--")) - -(define (has-key? line) - "Check if LINE includes a key." - (regexp-exec key-value-rx line)) - -(define (comment-line? line) - "Check if LINE is a comment line." - (regexp-exec comment-rx line)) - -(define (line-indentation+rest line) - "Returns two results: The number of indentation spaces and the rest of the -line (without indentation)." - (let loop ((line-lst (string->list line)) - (count 0)) - ;; Sometimes values are spread over multiple lines and new lines start - ;; with a comma ',' with the wrong indentation. See e.g. haddock-api. - (if (or (null? line-lst) - (not (or - (eqv? (first line-lst) #\space) - (eqv? (first line-lst) #\,) ; see, e.g., haddock-api.cabal - (eqv? (first line-lst) #\tab)))) - (values count (list->string line-lst)) - (loop (cdr line-lst) (+ count 1))))) - -(define (multi-line-value lines seed) - "Function to read a value split across multiple lines. LINES are the -remaining input lines to be read. SEED is the value read on the same line as -the key. Return two values: A list with values and the remaining lines to be -processed." - (define (multi-line-value-with-min-indent lines seed min-indent) - (if (null? lines) - (values '() '()) - (let-values (((current-indent value) (line-indentation+rest (first lines))) - ((next-line-indent next-line-value) - (if (null? (cdr lines)) - (values #f "") - (line-indentation+rest (second lines))))) - (if (or (not next-line-indent) (< next-line-indent min-indent) - (regexp-exec condition-rx next-line-value)) - (values (reverse (cons value seed)) (cdr lines)) - (multi-line-value-with-min-indent (cdr lines) (cons value seed) - min-indent))))) - - (let-values (((current-indent value) (line-indentation+rest (first lines)))) - (multi-line-value-with-min-indent lines seed current-indent))) - -(define (read-cabal port) - "Parses a Cabal file from PORT. Return a list of list pairs: - -(((head1 sub-head1 ... key1) (value)) - ((head2 sub-head2 ... key2) (value2)) - ...). - -We try do deduce the Cabal format from the following document: -https://www.haskell.org/cabal/users-guide/developing-packages.html - -Keys are case-insensitive. We therefore lowercase them. Values are -case-sensitive. Currently only indentation-structured files are parsed. -Braces structured files are not handled." ;" <- make emacs happy. - (define (read-and-trim-line port) - (let ((line (read-line port))) - (if (string? line) - (string-trim-both line #\return) - line))) - - (define (strip-insignificant-lines port) - (let loop ((line (read-and-trim-line port)) - (result '())) - (cond - ((eof-object? line) - (reverse result)) - ((or (string-null? line) (comment-line? line)) - (loop (read-and-trim-line port) result)) - (else - (loop (read-and-trim-line port) (cons line result)))))) - - (let loop - ((lines (strip-insignificant-lines port)) - (indents '()) ; only includes indents at start of section heads. - (sections '()) - (result '())) - (let-values - (((current-indent line) - (if (null? lines) - (values 0 "") - (line-indentation+rest (first lines)))) - ((next-line-indent next-line) - (if (or (null? lines) (null? (cdr lines))) - (values 0 "") - (line-indentation+rest (second lines))))) - (if (null? lines) - (reverse result) - (let ((rx-result (has-key? line))) - (cond - (rx-result - (let ((key (string-downcase (match:substring rx-result 1))) - (value (match:substring rx-result 2))) - (cond - ;; Simple single line "key: value". - ((= next-line-indent current-indent) - (loop (cdr lines) indents sections - (cons - (list (reverse (cons key sections)) (list value)) - result))) - ;; Multi line "key: value\n value cont...". - ((> next-line-indent current-indent) - (let*-values (((value-lst lines) - (multi-line-value (cdr lines) - (if (string-null? value) - '() - `(,value))))) - ;; multi-line-value returns to the first line after the - ;; multi-value. - (loop lines indents sections - (cons - (list (reverse (cons key sections)) value-lst) - result)))) - ;; Section ended. - (else - ;; Indentation is reduced. Check by how many levels. - (let* ((idx (and=> (list-index - (lambda (x) (= next-line-indent x)) - indents) - (cut + <> - (if (has-key? next-line) 1 0)))) - (sec - (if idx - (drop sections idx) - (raise - (condition - (&message - (message "unable to parse Cabal file")))))) - (ind (drop indents idx))) - (loop (cdr lines) ind sec - (cons - (list (reverse (cons key sections)) (list value)) - result))))))) - ;; Start of a new section. - ((or (null? indents) - (> current-indent (first indents))) - (loop (cdr lines) (cons current-indent indents) - (cons (string-downcase line) sections) result)) - (else - (loop (cdr lines) indents - (cons (string-downcase line) (cdr sections)) - result)))))))) - -(define condition-rx - ;; Regexp for conditionals. - (make-regexp "^if +(.*)$")) - -(define (split-section section) - "Split SECTION in individual words with exception for the predicate of an -'if' conditional." - (let ((rx-result (regexp-exec condition-rx section))) - (if rx-result - `("if" ,(match:substring rx-result 1)) - (map match:substring (list-matches sections-rx section))))) - -(define (join-sections sec1 sec2) - (fold-right cons sec2 sec1)) - -(define (pre-process-keys key) - (match key - (() '()) - ((sec1 rest ...) - (join-sections (split-section sec1) (pre-process-keys rest))))) - -(define (pre-process-entry-keys entry) - (match entry - ((key value) - (list (pre-process-keys key) value)) - (() '()))) - -(define (pre-process-entries-keys entries) - "ENTRIES is a list of list pairs, a keys list and a valules list, as -produced by 'read-cabal'. Split each element of the keys list into individual -words. This pre-processing is used to read flags." - (match entries - ((entry rest ...) - (cons (pre-process-entry-keys entry) - (pre-process-entries-keys rest))) - (() - '()))) - -(define (get-flags pre-processed-entries) - "PRE-PROCESSED-ENTRIES is a list of list pairs, a keys list and a values -list, as produced by 'read-cabal' and pre-processed by -'pre-process-entries-keys'. Return a list of pairs with the name of flags and -their default value (one of \"False\" or \"True\") as specified in the Cabal file: - -((\"flag1-name\" . \"False-or-True\") ...)." ;" <- make emacs happy - (match pre-processed-entries - (() '()) - (((("flag" flag-name "default") (flag-val)) rest ...) - (cons (cons flag-name flag-val) - (get-flags rest))) - ((entry rest ... ) - (get-flags rest)) - (_ #f))) - -;; Part 2: -;; -;; Functions to read information from the Cabal object created by 'read-cabal' -;; and convert Cabal format dependencies conditionals into equivalent -;; S-expressions. - -(define tests-rx - ;; Cabal test keywords - (make-regexp "(os|arch|flag|impl) *\\(([ a-zA-Z0-9_.<>=-]+)\\)")) - -(define parens-rx - ;; Parentheses within conditions - (make-regexp "\\((.+)\\)")) - -(define or-rx - ;; OR operator in conditions - (make-regexp " +\\|\\| +")) - -(define and-rx - ;; AND operator in conditions - (make-regexp " +&& +")) - -(define not-rx - ;; NOT operator in conditions - (make-regexp "^!.+")) - -(define (bi-op-args str match-lst) - "Return a list with the arguments of (logic) bianry operators. MATCH-LST -is the result of 'list-match' against a binary operator regexp on STR." - (let ((operators (length match-lst))) - (map (lambda (from to) - (substring str from to)) - (cons 0 (map match:end match-lst)) - (append (map match:start match-lst) (list (string-length str)))))) - -(define (bi-op->sexp-like bi-op args) - "BI-OP is a string with the name of a Scheme operator which in a Cabal file -is represented by a binary operator. ARGS are the arguments of said operator. -Return a string representing an S-expression of the operator applied to its -arguments." - (if (= (length args) 1) - (first args) - (string-append "(" bi-op - (fold (lambda (arg seed) (string-append seed " " arg)) - "" args) ")"))) - -(define (not->sexp-like arg) - "If the string ARG is prefixed by a Cabal negation operator, convert it to -an equivalent Scheme S-expression string." - (if (regexp-exec not-rx arg) - (string-append "(not " - (substring arg 1 (string-length arg)) - ")") - arg)) - -(define (parens-less-cond->sexp-like conditional) - "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme -syntax. This procedure accepts only simple conditionals without parentheses." - ;; The outher operation is the one with the lowest priority: OR - (bi-op->sexp-like - "or" - ;; each OR argument may be an AND operation - (map (lambda (or-arg) - (let ((m-lst (list-matches and-rx or-arg))) - ;; is there an AND operation? - (if (> (length m-lst) 0) - (bi-op->sexp-like - "and" - ;; expand NOT operators when there are ANDs - (map not->sexp-like (bi-op-args or-arg m-lst))) - ;; ... and when there aren't. - (not->sexp-like or-arg)))) - ;; list of OR arguments - (bi-op-args conditional (list-matches or-rx conditional))))) - -(define test-keyword-ornament "__") - -(define (conditional->sexp-like conditional) - "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme -syntax." - ;; First we substitute TEST-KEYWORD-ORNAMENT for parentheses around tests - ;; keywords so that parentheses are only used to set precedences. This - ;; substantially simplify parsing. - (let ((conditional - (regexp-substitute/global #f tests-rx conditional - 'pre 1 test-keyword-ornament 2 - test-keyword-ornament 'post))) - (let loop ((sub-cond conditional)) - (let ((rx-result (regexp-exec parens-rx sub-cond))) - (cond - (rx-result - (parens-less-cond->sexp-like - (string-append - (match:prefix rx-result) - (loop (match:substring rx-result 1)) - (match:suffix rx-result)))) - (else - (parens-less-cond->sexp-like sub-cond))))))) - -(define (eval-flags sexp-like-cond flags) - "SEXP-LIKE-COND is a string representing an S-expression conditional. FLAGS -is a list of flag name and value pairs as produced by 'get-flags'. Substitute -\"#t\" or \"#f\" according to the value of flags. (Default to \"True\")." - (fold-right - (lambda (flag sexp) - (match flag - ((name . value) - (let ((rx (make-regexp - (string-append "flag" test-keyword-ornament name - test-keyword-ornament)))) - (regexp-substitute/global - #f rx sexp - 'pre (if (string-ci= value "False") "#f" "#t") 'post))) - (_ sexp))) - sexp-like-cond - (cons '("[a-zA-Z0-9_-]+" . "True") flags))) - -(define (eval-tests->sexp sexp-like-cond) - "In the string SEXP-LIKE-COND substitute test keywords \"os(...)\" and -\"arch(...)\" with equivalent Scheme checks. Retrun an S-expression." - (with-input-from-string - (fold-right - (lambda (test sexp) - (match test - ((type pre-match post-match) - (let ((rx (make-regexp - (string-append type test-keyword-ornament "(\\w+)" - test-keyword-ornament)))) - (regexp-substitute/global - #f rx sexp - 'pre pre-match 2 post-match 'post))) - (_ sexp))) - sexp-like-cond - ;; (%current-system) returns, e.g., "x86_64-linux" or "i686-linux". - '(("(os|arch)" "(string-match \"" "\" (%current-system))"))) - read)) - -(define (eval-impl sexp-like-cond) - "Check for the Cabal test \"impl(...)\" in the string SEXP-LIKE-COND. -Assume the module declaring the generated package includes a local variable -called \"haskell-implementation\" with a string value of the form NAME-VERSION -against which we compare." - (with-output-to-string - (lambda () - (write - (with-input-from-string - (fold-right - (lambda (test sexp) - (match test - ((pre-match post-match) - (let ((rx-with-version - (make-regexp - (string-append - "impl" test-keyword-ornament - "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *" - test-keyword-ornament))) - (rx-without-version - (make-regexp - (string-append "impl" test-keyword-ornament "(\\w+)" - test-keyword-ornament)))) - (if (regexp-exec rx-with-version sexp) - (regexp-substitute/global - #f rx-with-version sexp - 'pre pre-match 2 " " post-match " \"" 1 "-" 3 "\")" 'post) - (regexp-substitute/global - #f rx-without-version sexp - 'pre pre-match "-match \"" 1 "\" " post-match ")" 'post)))) - (_ sexp))) - sexp-like-cond - '(("(string" "haskell-implementation"))) - read))))) - -(define (eval-cabal-keywords sexp-like-cond flags) - ((compose eval-tests->sexp eval-impl (cut eval-flags <> flags)) - sexp-like-cond)) - -(define (key->values meta key) - "META is the representation of a Cabal file as produced by 'read-cabal'. -Return the list of values associated with a specific KEY (a string)." - (match meta - (() '()) - (((((? (lambda(x) (equal? x key)))) v) r ...) - v) - (((k v) r ...) - (key->values (cdr meta) key)) - (_ "key Not fount"))) - -(define (key-start-end->entries meta key-start-rx key-end-rx) - "META is the representation of a Cabal file as produced by 'read-cabal'. -Return all entries whose keys list starts with KEY-START and ends with -KEY-END." - (let ((pred - (lambda (x) - (and (regexp-exec key-start-rx (first x)) - (regexp-exec key-end-rx (last x)))))) - ;; (equal? (list key-start key-end) (list (first x) (last x)))))) - (match meta - (() '()) - ((((? pred k) v) r ...) - (cons `(,k ,v) - (key-start-end->entries (cdr meta) key-start-rx key-end-rx))) - (((k v) r ...) - (key-start-end->entries (cdr meta) key-start-rx key-end-rx)) - (_ "key Not fount")))) - -(define else-rx - (make-regexp "^else$")) - -(define (count-if-else rx-result-ls) - (apply + (map (lambda (m) (if m 1 0)) rx-result-ls))) - -(define (analyze-entry-cond entry) - (let* ((keys (first entry)) - (vals (second entry)) - (rx-cond-result - (map (cut regexp-exec condition-rx <>) keys)) - (rx-else-result - (map (cut regexp-exec else-rx <>) keys)) - (cond-no (count-if-else rx-cond-result)) - (else-no (count-if-else rx-else-result)) - (cond-idx (list-index (lambda (rx) (if rx #t #f)) rx-cond-result)) - (else-idx (list-index (lambda (rx) (if rx #t #f)) rx-else-result)) - (key-cond - (cond - ((or (and cond-idx else-idx (< cond-idx else-idx)) - (and cond-idx (not else-idx))) - (match:substring - (receive (head tail) - (split-at rx-cond-result cond-idx) (first tail)))) - ((or (and cond-idx else-idx (> cond-idx else-idx)) - (and (not cond-idx) else-idx)) - (match:substring - (receive (head tail) - (split-at rx-else-result else-idx) (first tail)))) - (else - "")))) - (values keys vals rx-cond-result - rx-else-result cond-no else-no key-cond))) - -(define (remove-cond entry cond) - (match entry - ((k v) - (list (cdr (member cond k)) v)))) - -(define (group-and-reduce-level entries group group-cond) - (let loop - ((true-group group) - (false-group '()) - (entries entries)) - (if (null? entries) - (values (reverse true-group) (reverse false-group) entries) - (let*-values (((entry) (first entries)) - ((keys vals rx-cond-result rx-else-result - cond-no else-no key-cond) - (analyze-entry-cond entry))) - (cond - ((and (>= (+ cond-no else-no) 1) (string= group-cond key-cond)) - (loop (cons (remove-cond entry group-cond) true-group) false-group - (cdr entries))) - ((and (>= (+ cond-no else-no) 1) (string= key-cond "else")) - (loop true-group (cons (remove-cond entry "else") false-group) - (cdr entries))) - (else - (values (reverse true-group) (reverse false-group) entries))))))) - -(define dependencies-rx - (make-regexp "([a-zA-Z0-9_-]+) *[^,]*,?")) - (define (hackage-name->package-name name) + "Given the NAME of a Cabal package, return the corresponding Guix name." (if (string-prefix? package-name-prefix name) (string-downcase name) (string-append package-name-prefix (string-downcase name)))) -(define (split-and-filter-dependencies ls names-to-filter) - "Split the comma separated list of dependencies LS coming from the Cabal -file, filter packages included in NAMES-TO-FILTER and return a list with -inputs suitable for the Guix package. Currently the version information is -discarded." - (define (split-at-comma-and-filter d) - (fold - (lambda (m seed) - (let* ((name (string-downcase (match:substring m 1))) - (pkg-name (hackage-name->package-name name))) - (if (member name names-to-filter) - seed - (cons (list pkg-name (list 'unquote (string->symbol pkg-name))) - seed)))) - '() - (list-matches dependencies-rx d))) - - (fold (lambda (d p) (append (split-at-comma-and-filter d) p)) '() ls)) - -(define* (dependencies-cond->sexp meta #:key (include-test-dependencies? #t)) - "META is the representation of a Cabal file as produced by 'read-cabal'. -Return an S-expression containing the list of dependencies as expected by the -'inputs' field of a package. The generated S-expressions may include -conditionals as defined in the cabal file. During this process we discard the -version information of the packages." - (define (take-dependencies meta) - (let ((key-start-exe (make-regexp "executable")) - (key-start-lib (make-regexp "library")) - (key-start-tests (make-regexp "test-suite")) - (key-end (make-regexp "build-depends"))) - (append - (key-start-end->entries meta key-start-exe key-end) - (key-start-end->entries meta key-start-lib key-end) - (if include-test-dependencies? - (key-start-end->entries meta key-start-tests key-end) - '())))) - - (let ((flags (get-flags (pre-process-entries-keys meta))) - (augmented-ghc-std-libs (append (key->values meta "name") - ghc-standard-libraries))) - (delete-duplicates - (let loop ((entries (take-dependencies meta)) - (result '())) - (if (null? entries) - (reverse result) - (let*-values (((entry) (first entries)) - ((keys vals rx-cond-result rx-else-result - cond-no else-no key-cond) - (analyze-entry-cond entry))) - (cond - ((= (+ cond-no else-no) 0) - (loop (cdr entries) - (append - (split-and-filter-dependencies vals - augmented-ghc-std-libs) - result))) - (else - (let-values (((true-group false-group entries) - (group-and-reduce-level entries '() - key-cond)) - ((cond-final) (eval-cabal-keywords - (conditional->sexp-like - (last (split-section key-cond))) - flags))) - (loop entries - (cond - ((or (eq? cond-final #t) (equal? cond-final '(not #f))) - (append (loop true-group '()) result)) - ((or (eq? cond-final #f) (equal? cond-final '(not #t))) - (append (loop false-group '()) result)) - (else - (let ((true-group-result (loop true-group '())) - (false-group-result (loop false-group '()))) - (cond - ((and (null? true-group-result) - (null? false-group-result)) - result) - ((null? false-group-result) - (cons `(unquote-splicing - (when ,cond-final ,true-group-result)) - result)) - ((null? true-group-result) - (cons `(unquote-splicing - (unless ,cond-final ,false-group-result)) - result)) - (else - (cons `(unquote-splicing - (if ,cond-final - ,true-group-result - ,false-group-result)) - result)))))))))))))))) - -;; Part 3: -;; -;; Retrive the desired package and its Cabal file from -;; http://hackage.haskell.org and construct the Guix package S-expression. - (define (hackage-fetch name-version) "Return the Cabal file for the package NAME-VERSION, or #f on failure. If the version part is omitted from the package name, then return the latest @@ -696,33 +111,63 @@ version." ((lst ...) `(list ,@(map string->license lst))) (_ #f))) -(define* (hackage-module->sexp meta #:key (include-test-dependencies? #t)) - "Return the `package' S-expression for a Cabal package. META is the + +(define (cabal-dependencies->names cabal include-test-dependencies?) + "Return the list of dependencies names from the CABAL package object. If +INCLUDE-TEST-DEPENDENCIES? is #f, do not include dependencies required by test +suites." + (let* ((lib (cabal-package-library cabal)) + (lib-deps (if (pair? lib) + (map cabal-dependency-name + (append-map cabal-library-dependencies lib)) + '())) + (exe (cabal-package-executables cabal)) + (exe-deps (if (pair? exe) + (map cabal-dependency-name + (append-map cabal-executable-dependencies exe)) + '())) + (ts (cabal-package-test-suites cabal)) + (ts-deps (if (pair? ts) + (map cabal-dependency-name + (append-map cabal-test-suite-dependencies ts)) + '()))) + (if include-test-dependencies? + (delete-duplicates (append lib-deps exe-deps ts-deps)) + (delete-duplicates (append lib-deps exe-deps))))) + +(define (filter-dependencies dependencies own-name) + "Filter the dependencies included with the GHC compiler from DEPENDENCIES, a +list with the names of dependencies. OWN-NAME is the name of the Cabal +package being processed and is used to filter references to itself." + (filter (lambda (d) (not (member (string-downcase d) + (cons own-name ghc-standard-libraries)))) + dependencies)) + +(define* (hackage-module->sexp cabal #:key (include-test-dependencies? #t)) + "Return the `package' S-expression for a Cabal package. CABAL is the representation of a Cabal file as produced by 'read-cabal'." (define name - (first (key->values meta "name"))) + (cabal-package-name cabal)) (define version - (first (key->values meta "version"))) - - (define description - (let*-values (((description) (key->values meta "description")) - ((lines last) - (split-at description (- (length description) 1)))) - (fold-right (lambda (line seed) (string-append line "\n" seed)) - (first last) lines))) + (cabal-package-version cabal)) (define source-url (string-append "http://hackage.haskell.org/package/" name "/" name "-" version ".tar.gz")) - ;; Several packages do not have an official home-page other than on Hackage. - (define home-page - (let ((home-page-entry (key->values meta "homepage"))) - (if (null? home-page-entry) - (string-append "http://hackage.haskell.org/package/" name) - (first home-page-entry)))) + (define dependencies + (let ((names + (map hackage-name->package-name + ((compose (cut filter-dependencies <> + (cabal-package-name cabal)) + (cut cabal-dependencies->names <> + include-test-dependencies?)) + cabal)))) + (map (lambda (name) + (list name (list 'unquote (string->symbol name)))) + names))) (define (maybe-inputs input-type inputs) (match inputs @@ -746,22 +191,28 @@ representation of a Cabal file as produced by 'read-cabal'." (bytevector->nix-base32-string (file-sha256 tarball)) "failed to download tar archive"))))) (build-system haskell-build-system) - ,@(maybe-inputs 'inputs - (dependencies-cond->sexp meta - #:include-test-dependencies? - include-test-dependencies?)) - (home-page ,home-page) - (synopsis ,@(key->values meta "synopsis")) - (description ,description) - (license ,(string->license (key->values meta "license")))))) - -(define* (hackage->guix-package module-name - #:key (include-test-dependencies? #t)) + ,@(maybe-inputs 'inputs dependencies) + (home-page ,(cabal-package-home-page cabal)) + (synopsis ,(cabal-package-synopsis cabal)) + (description ,(cabal-package-description cabal)) + (license ,(string->license (cabal-package-license cabal)))))) + +(define* (hackage->guix-package package-name #:key + (include-test-dependencies? #t) + (cabal-environment '())) "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, and return -the `package' S-expression corresponding to that package, or #f on failure." - (let ((module-meta (hackage-fetch module-name))) - (and=> module-meta (cut hackage-module->sexp <> - #:include-test-dependencies? - include-test-dependencies?)))) +the `package' S-expression corresponding to that package, or #f on failure. +CABAL-ENVIRONMENT is an alist defining the environment in which the Cabal +conditionals are evaluated. The accepted keys are: \"os\", \"arch\", \"impl\" +and the name of a flag. The value associated with a flag has to be either the +symbol 'true' or 'false'. The value associated with other keys has to conform +to the Cabal file format definition. The default value associated with the +keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\" +respectively." + (let ((cabal-meta (hackage-fetch package-name))) + (and=> cabal-meta (compose (cut hackage-module->sexp <> + #:include-test-dependencies? + include-test-dependencies?) + (cut eval-cabal <> cabal-environment))))) ;;; cabal.scm ends here diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index f7c18cd..92ff941 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -34,7 +34,8 @@ ;;; (define %default-options - '((include-test-dependencies? . #t))) + '((include-test-dependencies? . #t) + ('cabal-environment . '()))) (define (show-help) (display (_ "Usage: guix import hackage PACKAGE-NAME @@ -45,6 +46,9 @@ package will be generated. If no version suffix is pecified, then the generated package definition will correspond to the latest available version.\n")) (display (_ " + -e ALIST, --cabal-environment=ALIST + specify environment for Cabal evaluation")) + (display (_ " -h, --help display this help and exit")) (display (_ " -t, --no-test-dependencies don't include test only dependencies")) @@ -67,6 +71,11 @@ version.\n")) (alist-cons 'include-test-dependencies? #f (alist-delete 'include-test-dependencies? result)))) + (option '(#\e "cabal-environment") #t #f + (lambda (opt name arg result) + (alist-cons 'cabal-environment (read/eval arg) + (alist-delete 'cabal-environment + result)))) %standard-import-options)) @@ -95,7 +104,8 @@ version.\n")) (let ((sexp (hackage->guix-package package-name #:include-test-dependencies? - (assoc-ref opts 'include-test-dependencies?)))) + (assoc-ref opts 'include-test-dependencies?) + #:cabal-environment (assoc-ref opts 'cabal-environment)))) (unless sexp (leave (_ "failed to download cabal file for package '~a'~%") package-name)) diff --git a/tests/hackage.scm b/tests/hackage.scm index 23b854c..dca5074 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -63,16 +63,13 @@ executable cabal ") (define test-cond-1 - "(os(darwin) || !(flag(debug))) && flag(cips)") + "if (os(darwin) || !(flag(debug))) && flag(cips)") (define read-cabal (@@ (guix import hackage) read-cabal)) -(define eval-cabal-keywords - (@@ (guix import hackage) eval-cabal-keywords)) - -(define conditional->sexp-like - (@@ (guix import hackage) conditional->sexp-like)) +(define cabal-conditional-line->sexp + (@@ (guix import cabal) cabal-conditional-line->sexp)) (test-begin "hackage") @@ -118,12 +115,9 @@ executable cabal (test-assert "hackage->guix-package test 3" (eval-test-with-cabal test-cabal-3)) -(test-assert "conditional->sexp-like" - (match - (eval-cabal-keywords - (conditional->sexp-like test-cond-1) - '(("debug" . "False"))) - (('and ('or ('string-match "darwin" ('%current-system)) ('not '#f)) '#t) +(test-assert "cabal-conditional-line->sexp" + (match (cabal-conditional-line->sexp test-cond-1) + (('and ('or ('os "darwin") ('not ('flag "debug"))) ('flag "cips")) #t) (x (pk 'fail x #f)))) -- 2.2.1