diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm new file mode 100644 index 0000000..35af03d --- /dev/null +++ b/guix/import/hackage.scm @@ -0,0 +1,1021 @@ +;;; 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)) + +;; Part 1: +;; +;; Functions used to read a cabal file and do some pre-processing: discarding +;; comments and empty lines. + +;; List of libraries distributed with ghc (7.8.4). +(define ghc-standard-libraries + '("haskell98" ; 2.0.0.3 + "hoopl" ; 3.10.0.1 + "base" + "transformers" ; 0.3.0.0 + "deepseq" ; 1.3.0.2 + "array" ; 0.5.0.0 + "binary" ; 0.7.1.0 + "bytestring" ; 0.10.4.0 + "containers" ; 0.5.5.1 + "time" ; 1.4.2 + "Cabal" ; 1.18.1.5 (but not "cabal-install") + "bin-package-db" ; 0.0.0.0 + "ghc-prim" + "integer-gmp" + "Win32" ; 2.3.0.2 + "template-haskell" + "process" ; 1.2.0.0 + "haskeline" ; 0.7.1.2 + "terminfo" ; 0.4.0.0 + "directory" ; 1.2.1.0 + "filepath" ; 1.3.0.2 + "old-locale" ; 1.0.0.6 + "unix" ; 2.7.0.1 + "old-time" ; 1.1.0.2 + "pretty" ; 1.1.1.1 + "xhtml" ; 3000.2.1 + "hpc")) ; 0.6.0.1 + +;; 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 guix-name-prefix "haskell-") + +;; Regular expression matching "key: value" +(define key-value-rx + "([a-zA-Z0-9-]+): *(\\w?.*)$") + +;; Regular expression matching a section "head sub-head ..." +(define sections-rx + "([a-zA-Z0-9\\(\\)-]+)") + +;; Cabal comment. +(define comment-rx + "^ *--") + +;; Check if the current line includes a key +(define (has-key? line) + (string-match key-value-rx line)) + +(define (comment-line? line) + (string-match comment-rx line)) + +;; returns the number of indentation spaces and the rest of the line. +(define (line-indentation+rest line) + (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))))) + +;; Part 1 main function: read a cabal fila and filter empty lines and comments. +;; Returns a list composed by the pre-processed lines of the file. +(define (read-cabal port) + (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. + +;; 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. Returns two values: (VALUES values-lst remaining-lines) +(define (multi-line-value lines seed) + (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)))))) + +;; Parses a cabal file in the form of a list of lines as produced by +;; READ-CABAL and returns its content in the following form: +;; +;; (((head1 sub-head1 ... key1) (value)) +;; ((head2 sub-head2 ... key2) (value2)) +;; ...). +;; +;; where all elements are strings. +;; +;; We try do deduce the format from the following document: +;; https://www.haskell.org/cabal/users-guide/developing-packages.html +;; +;; Key values are case-insensitive. We therefore lowercase them. Values are +;; case-sensitive. +;; +;; Currently only only layout structured files are parsed. Braces {} +;; structured files are not handled. +(define (cabal->key-values lines) + (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*-values (((idx) (+ (list-index + (lambda (x) (= next-line-indent x)) + indents) + (if (has-key? next-line) 1 0))) + ((_ sec) (split-at sections idx)) + ((_ ind) (split-at 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)))))))) + +;; Find if a string represent a conditional +(define condition-rx + (make-regexp "^if +(.*)$")) + +;; Split sections in individual words with exception for the predicate of an +;; 'if' conditional. +(define (split-section section) + (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)) + (() '()))) + +;; Split all strings included in the list of keys into individual words, with +;; exception for 'if' predicates. Returns an entry with the key list composed +;; by single words. This is used to read flags. +(define (pre-process-entries-keys entries) + (match entries + ((entry rest ...) + (cons (pre-process-entry-keys entry) + (pre-process-entries-keys rest))) + (() + '()))) + +;; Read flags and returns an alist where each pair is composed by the name of +;; a flag and its value: "True" or "False". +(define (get-flags pre-processed-entries) + (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: +;; +;; So far we did read the cabal file and extracted flags information. Now we +;; need to evaluate the conditions and process the entries accordingly. + +;; Cabal test keywords +(define tests-rx + (make-regexp "(os|arch|flag|impl)\\(([a-zA-Z0-9_-]+)\\)")) + +;; Parentheses within conditions +(define parens-rx + (make-regexp "\\((.+)\\)")) + +;; OR operator in conditions +(define or-rx + (make-regexp " +\\|\\| +")) + +;; AND operator in conditions +(define and-rx + (make-regexp " +&& +")) + +;; NOT operator in conditions +(define not-rx + (make-regexp "^!.+")) + +;; Returns a list with the arguments of (logic) bianry operators. MATCH-LST +;; is the result of "list-match" against a binary operator regexp. +(define (bi-op-args str match-lst) + (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)))))) + +;; If there is a single argument there is no binary operation to perform. We +;; just return the argument. Takes a list as produced by +;; "bi-op-argsf". Returns a string. +(define (bi-op->sexp-like bi-op args) + (if (= (length args) 1) + (first args) + (string-append "(" bi-op + (fold (lambda (arg seed) (string-append seed " " arg)) + "" args) ")"))) + +;; Takes a string and checks for negation symbol. +(define (not->sexp-like arg) + (if (regexp-exec not-rx arg) + (string-append "(not " + (substring arg 1 (string-length arg)) + ")") + arg)) + +;; Convert a CABAL conditional string into a string with equivalent SCHEME +;; syntax. This procedure accepts only simple conditionals without +;; parentheses. +(define (parens-less-cond->sexp-like conditional) + ;; 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 "§§") + +;; Convert a CABAL conditional string into a string with equivalent SCHEME +;; syntax. +(define (conditional->sexp-like conditional) + ;; 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))))))) + +;; Substitute SCHEME #t or #f according to the value of flags. (Default to +;; "True") +(define (eval-flags sexp-like-cond flags) + (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))) + +;; We need to substitute test keywords "os(...)" and "arch(...)" with +;; S-expression functions that perform the check when we want to build the +;; package. +;; +;; (%current-system) returns, e.g., "x86_64-linux" or "i686-linux". +(define (eval-tests sexp-like-cond) + (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 + '(("(os|arch)" "(string-match \"" "\" (%current-system))"))) + read)) + +;; We check for the cabal test "impl(...)". Assume the module declaring the +;; generated package includes a local variable called "haskell-implementation" +;; with a value of the form NAME-VERSION against which we compare. +(define (eval-impl sexp-like-cond) + (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))))) + +;; META is the result of "cabal->key-values". Returns the list associated with +;; a specific KEY. Since the value can be a list (as for "description"), we +;; always return a list. +(define (key->values meta key) + (match meta + (() '()) + (((((? (lambda(x) (equal? x key)))) v) r ...) + v) + (((k v) r ...) + (key->values (cdr meta) key)) + (_ "key Not fount"))) + +;; Returns all entries with a key starting with key-start and ending with +;; key-end as in (key-start ... key-end). +(define (key-start-end->entries meta key-start 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 (guix-name name) + (if (string-prefix? guix-name-prefix name) + (string-downcase name) + (string-append guix-name-prefix (string-downcase name)))) + +;; Split the comma separated list of dependencies coming from the cabal file +;; and return a list with inputs suitable for the GUIX package. Currently the +;; version information is discarded. +(define (split-dependencies ls) + (define (split-at-comma d) + (map + (lambda (m) + (let ((name (guix-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)) + +;; Genrate an S-expression containing the list of dependencies. 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 (dependencies-cond->sexp meta) + + (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))))))))))))) + +;; Filter the libraries already included in the Haskell compiler standard +;; libraries. Currently we imply the use of GHC. +(define (filter-standard-libraries ls) + (let ((real-name-rx (make-regexp + (string-append guix-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) + ((? (cut member <> + ;; GUIX names are all lower-case. + (map (cut string-downcase <>) + ghc-standard-libraries))) + 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 read-cabal)))))) + (and=> cabal cabal->key-values))) + +;; List of valid values from +;; https://www.haskell.org +;; /cabal/release/cabal-latest/doc/API/Cabal/Distribution-License.html. +(define string->license + (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 from the metadata in +META." + + (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 guix-name inputs) + (match (filter-standard-libraries inputs) + (() + '()) + ((inputs ...) + (list (list guix-name + (list 'quasiquote inputs)))))) + + (let ((tarball (with-store store + (download-to-store store source-url)))) + `(package + (name ,(guix-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (string-append ,@(factorize-uri source-url version))) + (sha256 + (base32 + ,(bytevector->nix-base32-string (file-sha256 tarball)))))) + (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))) + +;; Part 5: +;; +;; Some variables used to test the varisous functions. + +(define test-1 + '("head 1" + " kh1: vh1" + " kh2: vh2" + "name: mtl")) + +(define test-2 + '("head 1" + " subh 1" + " kh1: vh1" + " kh2: vh2" + "name: mtl")) + +(define test-3 + '("head 1" + " subh 1" + " kh1: vh1" + " subh 2" + " kh2: vh2" + " kh3: vh3" + "name: mtl")) + +(define test-4 + '("Library" + " Build-Depends: basee" + " Exposed-Modules: Testing.Test1" + " Extensions: CPP" + " if flag(debug)" + " GHC-Options: -DDEBUG" + " if !os(windows)" + " CC-Options: \"-DDEBUG\"" + " else" + " CC-Options: \"-DNDEBUG else\"" + " if flag(webfrontend)" + " Build-Depends: cgi > 0.42" + " Other-Modules: Testing.WebStuff")) + +(define test-5 + '("Flag Debug" + " Description: Enable debug support" + " Default: False" + "Library" + " Build-Depends: base" + " if flag(debug)" + " GHC-Options: -DDEBUG" + " if !os(windows)" + " CC-Options: \"-DDEBUG\"" + " else" + " CC-Options: \"-DNDEBUG\"")) + +(define test-6 + '("Flag Debug" + " Description: Enable debug support" + " Default: False" + "Flag Cips" + " Description: This is a journey into the sound..." + " Default: True" + "if flag(debug)" + " GHC-Options: -DDEBUG" + " if !os(windows)" + " CC-Options: \"-DDEBUG\"" + " else" + " CC-Options: \"-DNDEBUG\"")) + +(define test-7 + '("executable cabal" + " main-is: Main.hs" + " build-depends:" + " array >= 0.1 && < 0.6," + " base >= 4.3 && < 5" + " if flag(old-directory)" + " build-depends: directory >= 1 && < 1.2, old-time >= 1 && < 1.2," + " process >= 1.0.1.1 && < 1.1.0.2" + " else" + " build-depends: directory >= 1.2 && < 1.3," + " process >= 1.1.0.2 && < 1.3" + " if flag(network-uri)" + " build-depends: network-uri >= 2.6, network >= 2.6" + " else" + " build-depends: network >= 2.4 && < 2.6" + " if os(windows)" + " build-depends: Win32 >= 2 && < 3" + " cpp-options: -DWIN32" + " else" + " build-depends: unix >= 2.0 && < 2.8")) + +(define test-dep-1 + '((("executable cabal" "build-depends") + ("array >= 0.1")) + (("executable cabal" "build-depends") + ("fbe >= 0.2")))) + +(define test-dep-2 + '((("executable cabal" "if flag(cips)" "build-depends") + ("fbe >= 0.2")))) + +(define test-dep-3 + '((("executable cabal" "if flag(cips)" "build-depends") + ("fbe >= 0.2")) + (("executable cabal" "else" "build-depends") + ("fbeee >= 0.3")) + )) + +(define test-dep-4 + '((("executable cabal" "if flag(a)" "if flag(b)" "build-depends") + ("network-uri >= 2.6, network >= 2.6")) + (("executable cabal" "if flag(a)" "else" "build-depends") + ("fbeeeee >= 0.3")) + (("executable cabal" "build-depends") + ("network >= 0.1")) + )) + +(define test-dep-5 + '((("executable cabal" "if flag(a)" "if flag(b)" "build-depends") + ("fbe >= 0.2")) + (("executable cabal" "if flag(a)" "else" "build-depends") + ("fbe >= 0.3")) + (("executable cabal" "else" "build-depends") + ("fbe >= 0.4")) + )) + +(define test-dep-6 + '((("executable cabal" "if flag(a)" "if flag(b)" "build-depends") + ("fbe >= 0.2")) + (("executable cabal" "if flag(a)" "else" "build-depends") + ("fbe >= 0.3")) + (("executable cabal" "else" "build-depends") + ("fbe >= 0.4")) + (("executable cabal" "build-depends") + ("array >= 0.1")) + )) + +(define test-dep-10 + '((("executable cabal" "build-depends") + ("array >= 0.1 && < 0.6," "base >= 4.3 && < 5")) + (("executable cabal" "if flag(old-directory)" "build-depends") + ("directory >= 1 && < 1.2," "process >= 1.0.1.1 && < 1.1.0.2")) + (("executable cabal" "else" "build-depends") + ("directory >= 1.2 && < 1.3," "process >= 1.1.0.2 && < 1.3")) + (("executable cabal" "if flag(network-uri)" "build-depends") + ("network-uri >= 2.6, network >= 2.6")) + (("executable cabal" "else" "build-depends") + ("network >= 2.4 && < 2.6")) + (("executable cabal" "if os(windows)" "build-depends") + ("Win32 >= 2 && < 3")) + (("executable cabal" "else" "build-depends") + ("unix >= 2.0 && < 2.8")))) + +(define test-dep-10a + '((("executable cabal" "build-depends") + ("array >= 0.1 && < 0.6," "base >= 4.3 && < 5")) + (("executable cabal" "if flag(old-directory)" "build-depends") + ("directory >= 1 && < 1.2, old-time >= 1 && < 1.2")) + (("executable cabal" "else" "build-depends") + ("directory >= 1.2 && < 1.3," "process >= 1.1.0.2 && < 1.3")) + (("executable cabal" "if flag(network-uri)" "build-depends") + ("network-uri >= 2.6, network >= 2.6")) + (("executable cabal" "else" "build-depends") + ("network >= 2.4 && < 2.6")) + (("executable cabal" "if os(windows)" "build-depends") + ("Win32 >= 2 && < 3")) + (("executable cabal" "else" "build-depends") + ("unix >= 2.0 && < 2.8")))) + +(define test-dep-11 + '((("executable cabal" "if flag(old-directory)" "if flag(network-uri)" "build-depends") + ("network-uri >= 2.6, network >= 2.6")) + (("executable cabal" "if flag(old-directory)" "if flag(network-uri)" "if flag(cips)" "build-depends") + ("network-uri >= 2.6, network >= 2.6")) + (("executable cabal" "if flag(old-directory)" "else" "build-depends") + ("network >= 2.4 && < 2.6")) + (("executable cabal" "else" "build-depends") + ("directory >= 1.2 && < 1.3," "process >= 1.1.0.2 && < 1.3")) + (("executable cabal" "else" "if flag(cips)" "build-depends") + ("cip >= 1.2")))) + +(define test-dep-12 + '((("executable cabal" "build-depends") + ("array >= 0.1 && < 0.6," "base >= 4.3 && < 5")) + (("executable cabal" "if flag(old-directory)" "build-depends") + ("directory >= 1 && < 1.2," "process >= 1.0.1.1 && < 1.1.0.2")) + (("executable cabal" "if flag(old-directory)" "if flag(network-uri)" "build-depends") + ("network-uri >= 2.6, network >= 2.6")) + (("executable cabal" "if flag(old-directory)" "else" "build-depends") + ("network >= 2.4 && < 2.6")) + (("executable cabal" "else" "build-depends") + ("directory >= 1.2 && < 1.3," "process >= 1.1.0.2 && < 1.3")))) + +(define test-dep-13 + '((("executable cabal" "if os(linux)" "if flag(debug)" "build-depends") + ("network-uri >= 2.6, network >= 2.6")) + (("executable cabal" "if os(linux)" "if flag(debug)" "if flag(cips)" "build-depends") + ("network-uri >= 2.6, network >= 2.6")) + (("executable cabal" "if os(linux)" "else" "build-depends") + ("network >= 2.4 && < 2.6")) + (("executable cabal" "else" "build-depends") + ("directory >= 1.2 && < 1.3," "process >= 1.1.0.2 && < 1.3")) + (("executable cabal" "else" "if flag(cips)" "build-depends") + ("cip >= 1.2")))) + +(define test-cond-1 + "(os(darwin) && !(arch(i386))) || os(freebsd)") + +(define test-cond-2 + "(os(darwin) || !(arch(i386))) && os(freebsd)") + +(define test-cond-3 + "os(darwin) && arch(i386) || os(freebsd)") + +(define test-cond-4 + "os(darwin) && !arch(i386) || !os(freebsd)") + +(define test-cond-5 + "os(darwin) && !arch(i386) && !os(freebsd)") + +(define test-cond-6 + "(os(darwin) || !(flag(debug))) && flag(cips)") + +(define test-cond-7 + "(os(darwin) || !(flag(debug))) && flag(cips) && flag(fbe)") + +(define test-cond-8 + "os(linux) && impl(ghc)") + +(define test-cond-9 + "os(linux) && impl(ghc <= 6.1.0)") + +;; Run some tests + +;; (display (cabal->key-values +;; (call-with-input-file "mtl.cabal" read-cabal))) +;; (display (cabal->key-values +;; (call-with-input-file "/home/beffa/tmp/cabal-install.cabal" read-cabal))) +;; (display (get-flags (pre-process-entries-keys (cabal->key-values test-5)))) +;; (newline) +;; (display (conditional->sexp-like test-cond-2)) +;; (newline) +;; (display +;; (eval-flags (conditional->sexp-like test-cond-6) +;; (get-flags (pre-process-entries-keys (cabal->key-values test-6))))) +;; (newline) +;; (key->values (cabal->key-values test-1) "name") +;; (newline) +;; (key-start-end->entries (cabal->key-values test-4) "Library" "CC-Options") +;; (newline) +;; (eval-tests (conditional->sexp-like test-cond-6)) +;; +;;; cabal.scm ends here diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 7e75c10..06b4c17 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -73,7 +73,7 @@ rather than \\n." ;;; Entry point. ;;; -(define importers '("gnu" "nix" "pypi" "cpan")) +(define importers '("gnu" "nix" "pypi" "cpan" "hackage")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm new file mode 100644 index 0000000..22a9888 --- /dev/null +++ b/guix/scripts/import/hackage.scm @@ -0,0 +1,96 @@ +;;; 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 scripts import hackage) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix import hackage) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-hackage)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import hackage PACKAGE-NAME +Import and convert the Hackage package for PACKAGE-NAME. If PACKAGE-NAME +includes a suffix constituted by a dash followed by a numerical version (as +used with GUIX packages), then a definition for the specified version of the +package will be generated. If no version suffix is pecified, then the +generated package definition will correspond to the latest available +version.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import hackage"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-hackage . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (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))) + (unless sexp + (leave (_ "failed to download cabal file for package '~a'~%") + package-name)) + sexp)) + (() + (leave (_ "too few arguments~%"))) + ((many ...) + (leave (_ "too many arguments~%"))))))