From 447c6b8f1ee6cc1d4edba44cabef1b28b75c7608 Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Sun, 8 Mar 2015 07:48:38 +0100 Subject: [PATCH 3/5] import: Add hackage importer. * guix/import/hackage.scm: New file. --- guix/import/hackage.scm | 787 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 787 insertions(+) create mode 100644 guix/import/hackage.scm diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm new file mode 100644 index 0000000..5f2f46e --- /dev/null +++ b/guix/import/hackage.scm @@ -0,0 +1,787 @@ +;;; 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 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-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 store) + #:use-module (guix hash) + #:use-module (guix base32) + #:use-module ((guix utils) #:select (call-with-temporary-output-file)) + #:export (hackage->guix-package)) + +;; (use-modules (ice-9 match)) +;; (use-modules (ice-9 regex)) +;; (use-modules (ice-9 rdelim)) +;; (use-modules (ice-9 receive)) +;; (use-modules (ice-9 pretty-print)) +;; (use-modules (srfi srfi-26)) +;; (use-modules (srfi srfi-11)) +;; (use-modules (srfi srfi-1)) + +;; Part 1: +;; +;; Functions used to read a Cabal file and do some pre-processing: discarding +;; comments and empty lines. + +(define ghc-standard-libraries + ;; List of libraries distributed with ghc (7.8.4). + '("haskell98" + "hoopl" + "base" + "transformers" + "deepseq" + "array" + "binary" + "bytestring" + "containers" + "time" + "cabal" + "bin-package-db" + "ghc-prim" + "integer-gmp" + "win32" + "template-haskell" + "process" + "haskeline" + "terminfo" + "directory" + "filepath" + "old-locale" + "unix" + "old-time" + "pretty" + "xhtml" + "hpc")) + +;; Libraries present in the "Haskell Platform" 2014.2.0 and not included in +;; the GHC standard libraries: +;; +;; "zlib" ; 0.5.4.1 +;; "async" ; 2.0.1.5 +;; "stm" ; 2.4.2 +;; "mtl" ; 2.1.3.1 +;; "primitive" ; 0.5.2.1 +;; "parallel" ; 3.2.0.4 +;; "attoparsec" ; 0.10.4.0 +;; "case-insensitive" ; 1.1.0.3 +;; "syb" ; 0.4.1 +;; "containers" ; 0.5.5.1 +;; "fgl" ; 5.5.0.1 +;; "unordered-containers" ; 0.2.3.3 +;; "hashable" ; 1.2.1.0 +;; "split" ; 0.2.2 +;; "text" ; 1.1.0.0 +;; "vector" ; 0.10.9.1 +;; "GLURaw" ; 1.4.0.1 +;; "OpenGL" ; 2.9.2.0 +;; "OpenGLRaw" ; 1.5.0.0 +;; "GLUT" ; 2.5.1.1 +;; "haskell-src" ; 1.0.1.6 +;; "network" ; 2.4.2.2 +;; "HTTP" ; 4000.2.10 +;; "random" ; 1.0.1.1 +;; "HUnit" ; 1.2.5.2 +;; "QuickCheck" ; 2.6 +;; "html" ; 1.0.1.2 +;; "parsec" ; 3.1.5 +;; "regex-compat" ; 0.95.1 +;; "regex-base" ; 0.93.2 +;; "regex-posix" ; 0.95.2 + +(define package-name-prefix "ghc-") + +(define key-value-rx + ;; Regular expression matching "key: value" + (make-regexp "([a-zA-Z0-9-]+): *(\\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)) + (if (or (null? line-lst) (not (eqv? (first line-lst) #\space))) + (values count (list->string line-lst)) + (loop (cdr line-lst) (+ count 1))))) + +(define (strip-cabal port) + "Read a Cabal file from PORT and filter empty and comment lines. +Return a list composed by the remaining lines of the file." + (let loop ((line (read-line port)) + (result '())) + (cond + ((eof-object? line) + (reverse result)) + ((or (string-null? line) (comment-line? line)) + (loop (read-line port) result)) + (else + (loop (read-line port) (cons line result)))))) + +;; Part 2: +;; +;; Take the result of part 1 and convert the content of the file in a list of +;; list pairs, where the first list of the pair includes keys while the second +;; is a list of values. + +(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." + (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 current-indent) + (regexp-exec condition-rx next-line-value)) + (values (reverse (cons value seed)) (cdr lines)) + (multi-line-value (cdr lines) (cons value seed)))))) + +(define (read-cabal lines) + "Parses a Cabal file. LINES is a list with each element being a line of a +Cabal file, as produced by STRIP-CABAL. 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. + (let loop + ((lines lines) + (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 (+ (list-index + (lambda (x) (= next-line-indent x)) + indents) + (if (has-key? next-line) 1 0))) + (sec (drop sections idx)) + (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 3: +;; +;; Functions to read information from the Cabal object created by 'read-cabal' +;; and process dependencies conditionals. + +(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-like-cond) + "In the string SEXP-LIKE-COND substitute test keywords \"os(...)\" and +\"arch(...)\" with strings representing Scheme functions performing equivalent +checks." + (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 " \"" 1 "-" 3 "\" " post-match '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 (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 key-end) + "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) + (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 key-end))) + (((k v) r ...) + (key-start-end->entries (cdr meta) key-start key-end)) + (_ "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) + (if (string-prefix? package-name-prefix name) + (string-downcase name) + (string-append package-name-prefix (string-downcase name)))) + +(define (split-dependencies ls) + "Split the comma separated list of dependencies LS coming from the Cabal +file and return a list with inputs suitable for the Guix package. Currently +the version information is discarded." + (define (split-at-comma d) + (map + (lambda (m) + (let ((name (hackage-name->package-name (match:substring m 1)))) + (list name (list 'unquote (string->symbol name))))) + (list-matches dependencies-rx d))) + + (fold (lambda (d p) (append (split-at-comma d) p)) '() ls)) + +(define (dependencies-cond->sexp meta) + "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 "executable cabal") + (key-start-lib "library") + (key-end "build-depends")) + (append + (key-start-end->entries meta key-start-exe key-end) + (key-start-end->entries meta key-start-lib key-end)))) + + (let ((flags (get-flags (pre-process-entries-keys meta)))) + (delete-duplicates + (let loop ((entries (take-dependencies meta)) + (result '())) + (if (null? entries) + 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-dependencies vals) result))) + (else + (let-values (((true-group false-group entries) + (group-and-reduce-level entries '() + key-cond)) + ((cond-final) (eval-tests + (eval-impl + (eval-flags + (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 + (cons `(unquote-splicing + (if ,cond-final + ,(loop true-group '()) + ,(loop false-group '()))) + result))))))))))))) + +(define (standard-library? name) + (member name ghc-standard-libraries)) + +(define (filter-standard-libraries ls) + "Filter from list of inputs LS the libraries already included with the +Haskell compiler. Currently we imply the use of GHC." + (let ((real-name-rx (make-regexp + (string-append package-name-prefix "(\\w+)")))) + (fold (lambda (elem seed) + (if (eq? (first elem) 'unquote-splicing) + (let*-values (((group-cond true-group false-group) + (match (second elem) + ((if c t f ) + (values c t f)) + (_ (values c '() '())))) + ((filtered-true-group) + (filter-standard-libraries true-group)) + ((filtered-false-group) + (filter-standard-libraries false-group))) + (cond + ((and (null? filtered-false-group) + (null? filtered-true-group)) + seed) + ((null? filtered-false-group) + (cons (list 'unquote-splicing + (list 'if group-cond + filtered-true-group)) + seed)) + (else + (cons (list 'unquote-splicing + (list 'if group-cond + filtered-true-group + filtered-false-group)) + seed)))) + (let ((rx-result (regexp-exec real-name-rx (first elem)))) + (match (match:substring rx-result 1) + ((? standard-library?) + seed) + (_ + (cons elem seed)))))) + '() ls))) + +;; Part 4: +;; +;; 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 +version." + (let*-values (((name version) (package-name->name+version name-version)) + ((url) + (if version + (string-append "http://hackage.haskell.org/package/" + name "-" version "/" name ".cabal") + (string-append "http://hackage.haskell.org/package/" + name "/" name ".cabal"))) + ((cabal) + (call-with-temporary-output-file + (lambda (temp port) + (and (url-fetch url temp) + (call-with-input-file temp strip-cabal)))))) + (and=> cabal read-cabal))) + +(define string->license + ;; List of valid values from + ;; https://www.haskell.org + ;; /cabal/release/cabal-latest/doc/API/Cabal/Distribution-License.html. + (match-lambda + ("GPL-2" 'gpl2) + ("GPL-3" 'gpl3) + ("GPL" "'gpl??") + ("AGPL-3" 'agpl3) + ("AGPL" "'agpl??") + ("LGPL-2.1" 'lgpl2.1) + ("LGPL-3" 'lgpl3) + ("LGPL" "'lgpl??") + ("BSD2" 'bsd-2) + ("BSD3" 'bsd-3) + ("MIT" 'expat) + ("ISC" 'isc) + ("MPL" 'mpl2.0) + ("Apache-2.0" 'asl2.0) + ((x) (string->license x)) + ((lst ...) `(list ,@(map string->license lst))) + (_ #f))) + +(define (hackage-module->sexp meta) + "Return the `package' S-expression for a Cabal package. META is the +representation of a Cabal file as produced by 'read-cabal'." + + (define name + (first (key->values meta "name"))) + + (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))) + + (define source-url + (string-append "http://hackage.haskell.org/package/" name + "/" name "-" version ".tar.gz")) + + (define (maybe-inputs hackage-name->package-name inputs) + (match (filter-standard-libraries inputs) + (() + '()) + ((inputs ...) + (list (list hackage-name->package-name + (list 'quasiquote inputs)))))) + + (let ((tarball (with-store store + (download-to-store store source-url)))) + `(package + (name ,(hackage-name->package-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (string-append ,@(factorize-uri source-url version))) + (sha256 + (base32 + ,(if tarball + (bytevector->nix-base32-string (file-sha256 tarball)) + "failed to download tar archive"))))) + (build-system haskell-build-system) + ,@(maybe-inputs 'inputs (dependencies-cond->sexp meta)) + (home-page ,@(key->values meta "homepage")) + (synopsis ,@(key->values meta "synopsis")) + (description ,description) + (license ,(string->license (key->values meta "license")))))) + +(define (hackage->guix-package module-name) + "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 hackage-module->sexp))) + +;;; cabal.scm ends here -- 2.2.1