diff options
Diffstat (limited to 'guix/import')
| -rw-r--r-- | guix/import/cabal.scm | 70 | ||||
| -rw-r--r-- | guix/import/elpa.scm | 4 | ||||
| -rw-r--r-- | guix/import/gem.scm | 48 | ||||
| -rw-r--r-- | guix/import/opam.scm | 193 | ||||
| -rw-r--r-- | guix/import/pypi.scm | 10 |
5 files changed, 286 insertions, 39 deletions
diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index 09130e4498..4b2bfd4a25 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -139,8 +139,8 @@ to the stack." "Generate a parser for Cabal files." (lalr-parser ;; --- token definitions - (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE - (right: IF FLAG EXEC TEST-SUITE SOURCE-REPO BENCHMARK LIB OCURLY) + (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE -ANY -NONE + (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB OCURLY) (left: OR) (left: PROPERTY AND) (right: ELSE NOT)) @@ -150,6 +150,7 @@ to the stack." (sections source-repo) : (append $1 (list $2)) (sections executables) : (append $1 $2) (sections test-suites) : (append $1 $2) + (sections custom-setup) : (append $1 $2) (sections benchmarks) : (append $1 $2) (sections lib-sec) : (append $1 (list $2)) () : '()) @@ -172,6 +173,7 @@ to the stack." (ts-sec) : (list $1)) (ts-sec (TEST-SUITE OCURLY exprs CCURLY) : `(section test-suite ,$1 ,$3) (TEST-SUITE open exprs close) : `(section test-suite ,$1 ,$3)) + (custom-setup (CUSTOM-SETUP exprs) : (list `(section custom-setup ,$1 ,$2))) (benchmarks (benchmarks bm-sec) : (append $1 (list $2)) (bm-sec) : (list $1)) (bm-sec (BENCHMARK OCURLY exprs CCURLY) : `(section benchmark ,$1 ,$3) @@ -211,6 +213,10 @@ to the stack." (FALSE) : 'false (TEST OPAREN ID RELATION VERSION CPAREN) : `(,$1 ,(string-append $3 " " $4 " " $5)) + (TEST OPAREN ID -ANY CPAREN) + : `(,$1 ,(string-append $3 " -any")) + (TEST OPAREN ID -NONE CPAREN) + : `(,$1 ,(string-append $3 " -none")) (TEST OPAREN ID RELATION VERSION AND RELATION VERSION CPAREN) : `(and (,$1 ,(string-append $3 " " $4 " " $5)) (,$1 ,(string-append $3 " " $7 " " $8))) @@ -349,6 +355,9 @@ matching a string against the created regexp." (define is-test-suite (make-rx-matcher "^test-suite +([a-z0-9_-]+)" regexp/icase)) +(define is-custom-setup (make-rx-matcher "^(custom-setup)" + regexp/icase)) + (define is-benchmark (make-rx-matcher "^benchmark +([a-z0-9_-]+)" regexp/icase)) @@ -362,13 +371,17 @@ matching a string against the created regexp." (define (is-false s) (string-ci=? s "false")) +(define (is-any s) (string-ci=? s "-any")) + +(define (is-none s) (string-ci=? s "-none")) + (define (is-and s) (string=? s "&&")) (define (is-or s) (string=? s "||")) (define (is-id s port) (let ((cabal-reserved-words - '("if" "else" "library" "flag" "executable" "test-suite" + '("if" "else" "library" "flag" "executable" "test-suite" "custom-setup" "source-repository" "benchmark")) (spaces (read-while (cut char-set-contains? char-set:blank <>) port)) (c (peek-char port))) @@ -392,8 +405,11 @@ matching a string against the created regexp." (define (lex-version loc port) (make-lexical-token 'VERSION loc - (read-while char-numeric? port - (cut char=? #\. <>) char-numeric?))) + (read-while (lambda (x) + (or (char-numeric? x) + (char=? x #\*) + (char=? x #\.))) + port))) (define* (read-while is? port #:optional (is-if-followed-by? (lambda (c) #f)) @@ -435,6 +451,8 @@ string with the read characters." (define (lex-test-suite ts-rx-res loc) (lex-rx-res ts-rx-res 'TEST-SUITE loc)) +(define (lex-custom-setup ts-rx-res loc) (lex-rx-res ts-rx-res 'CUSTOM-SETUP loc)) + (define (lex-benchmark bm-rx-res loc) (lex-rx-res bm-rx-res 'BENCHMARK loc)) (define (lex-lib loc) (make-lexical-token 'LIB loc #f)) @@ -447,6 +465,10 @@ string with the read characters." (define (lex-false loc) (make-lexical-token 'FALSE loc #f)) +(define (lex-any loc) (make-lexical-token '-ANY loc #f)) + +(define (lex-none loc) (make-lexical-token '-NONE loc #f)) + (define (lex-and loc) (make-lexical-token 'AND loc #f)) (define (lex-or loc) (make-lexical-token 'OR loc #f)) @@ -514,6 +536,8 @@ LOC is the current port location." ((is-test w port) (lex-test w loc)) ((is-true w) (lex-true loc)) ((is-false w) (lex-false loc)) + ((is-any w) (lex-any loc)) + ((is-none w) (lex-none loc)) ((is-and w) (lex-and loc)) ((is-or w) (lex-or loc)) ((is-id w port) (lex-id w loc)) @@ -529,6 +553,7 @@ the current port location." ((is-src-repo s) => (cut lex-src-repo <> loc)) ((is-exec s) => (cut lex-exec <> loc)) ((is-test-suite s) => (cut lex-test-suite <> loc)) + ((is-custom-setup s) => (cut lex-custom-setup <> loc)) ((is-benchmark s) => (cut lex-benchmark <> loc)) ((is-lib s) (lex-lib loc)) ((is-else s) (lex-else loc)) @@ -658,6 +683,12 @@ If #f use the function 'port-filename' to obtain it." (name cabal-test-suite-name) (dependencies cabal-test-suite-dependencies)) ; list of <cabal-dependency> +(define-record-type <cabal-custom-setup> + (make-cabal-custom-setup name dependencies) + cabal-custom-setup? + (name cabal-custom-setup-name) + (dependencies cabal-custom-setup-dependencies)) ; list of <cabal-dependency> + (define (cabal-flags->alist flag-list) "Retrun an alist associating the flag name to its default value from a list of <cabal-flag> objects." @@ -694,13 +725,20 @@ the ordering operation and the version." (let* ((with-ver-matcher-fn (make-rx-matcher "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *")) (without-ver-matcher-fn (make-rx-matcher "([a-zA-Z0-9_-]+)")) + (without-ver-matcher-fn-2 (make-rx-matcher "([a-zA-Z0-9_-]+) (-any|-none)")) (name (or (and=> (with-ver-matcher-fn spec) (cut match:substring <> 1)) + (and=> (without-ver-matcher-fn-2 spec) + (cut match:substring <> 1)) (match:substring (without-ver-matcher-fn spec) 1))) - (operator (and=> (with-ver-matcher-fn spec) - (cut match:substring <> 2))) - (version (and=> (with-ver-matcher-fn spec) - (cut match:substring <> 3)))) + (operator (or (and=> (with-ver-matcher-fn spec) + (cut match:substring <> 2)) + (and=> (without-ver-matcher-fn-2 spec) + (cut match:substring <> 2)))) + (version (or (and=> (with-ver-matcher-fn spec) + (cut match:substring <> 3)) + (and=> (without-ver-matcher-fn-2 spec) + (cut match:substring <> 2))))) (values name operator version))) (define (impl haskell) @@ -716,6 +754,8 @@ the ordering operation and the version." ((string= spec-op ">") (version>? comp-ver spec-ver)) ((string= spec-op "<=") (not (version>? comp-ver spec-ver))) ((string= spec-op "<") (not (version>=? comp-ver spec-ver))) + ((string= spec-op "-any") #t) + ((string= spec-op "-none") #f) (else (raise (condition (&message (message "Failed to evaluate 'impl' test.")))))) @@ -728,7 +768,6 @@ the ordering operation and the version." (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 (() '()) @@ -755,6 +794,8 @@ the ordering operation and the version." ;; no need to evaluate flag parameters (('section 'flag name parameters) (list 'section 'flag name parameters)) + (('section 'custom-setup parameters) + (list 'section 'custom-setup parameters)) ;; library does not have a name parameter (('section 'library parameters) (list 'section 'library (eval parameters))) @@ -795,12 +836,15 @@ See the manual for limitations."))))))) (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." +'executable, 'flag, 'test-suite, 'custom-setup, '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))) + ((custom-setup) (make-cabal-custom-setup + name (dependencies parameters "setup-depends"))) ((executable) (make-cabal-executable name (dependencies parameters))) ((source-repository) (make-cabal-source-repository @@ -843,10 +887,10 @@ to be added between the values found in different key/value pairs." (define dependency-name-version-rx (make-regexp "([a-zA-Z0-9_-]+) *(.*)")) -(define (dependencies key-values-list) +(define* (dependencies key-values-list #:optional (key "build-depends")) "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" ",") + (let ((deps (string-tokenize (lookup-join key-values-list key ",") (char-set-complement (char-set #\,))))) (map (lambda (d) (let ((rx-result (regexp-exec dependency-name-version-rx d))) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 65e0be45ab..c37afaf8e6 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -187,7 +187,9 @@ include VERSION." (url (package-source-url kind name ver repo))) (make-elpa-package name ver (ensure-list reqs) synopsis kind - (package-home-page (first rest)) + (package-home-page (match rest + (() #f) + ((one) one))) (fetch-package-description kind name repo) url))) (_ #f)))) diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 646163fb7b..ea576b5e4a 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> +;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,7 +34,8 @@ #:use-module (guix base32) #:use-module (guix build-system ruby) #:export (gem->guix-package - %gem-updater)) + %gem-updater + gem-recursive-import)) (define (rubygems-fetch name) "Return an alist representation of the RubyGems metadata for the package NAME, @@ -115,29 +117,30 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES." ((license) (license->symbol license)) (_ `(list ,@(map license->symbol licenses))))))) -(define* (gem->guix-package package-name #:optional version) +(define* (gem->guix-package package-name #:optional (repo 'rubygems) version) "Fetch the metadata for PACKAGE-NAME from rubygems.org, and return the `package' s-expression corresponding to that package, or #f on failure." (let ((package (rubygems-fetch package-name))) (and package - (let ((name (assoc-ref package "name")) - (version (assoc-ref package "version")) - (hash (assoc-ref package "sha")) - (synopsis (assoc-ref package "info")) ; nothing better to use - (description (beautify-description - (assoc-ref package "info"))) - (home-page (assoc-ref package "homepage_uri")) - (dependencies (map (lambda (dep) - (let ((name (assoc-ref dep "name"))) - (if (string=? name "bundler") - "bundler" ; special case, no prefix - (ruby-package-name name)))) - (assoc-ref* package "dependencies" - "runtime"))) - (licenses (map string->license - (assoc-ref package "licenses")))) - (make-gem-sexp name version hash home-page synopsis - description dependencies licenses))))) + (let* ((name (assoc-ref package "name")) + (version (assoc-ref package "version")) + (hash (assoc-ref package "sha")) + (synopsis (assoc-ref package "info")) ; nothing better to use + (description (beautify-description + (assoc-ref package "info"))) + (home-page (assoc-ref package "homepage_uri")) + (dependencies-names (map (lambda (dep) (assoc-ref dep "name")) + (assoc-ref* package "dependencies" "runtime"))) + (dependencies (map (lambda (dep) + (if (string=? dep "bundler") + "bundler" ; special case, no prefix + (ruby-package-name dep))) + dependencies-names)) + (licenses (map string->license + (assoc-ref package "licenses")))) + (values (make-gem-sexp name version hash home-page synopsis + description dependencies licenses) + dependencies-names))))) (define (guix-package->gem-name package) "Given a PACKAGE built from rubygems.org, return the name of the @@ -192,3 +195,8 @@ package on RubyGems." (description "Updater for RubyGem packages") (pred gem-package?) (latest latest-release))) + +(define* (gem-recursive-import package-name #:optional version) + (recursive-import package-name '() + #:repo->guix-package gem->guix-package + #:guix-name ruby-package-name)) diff --git a/guix/import/opam.scm b/guix/import/opam.scm new file mode 100644 index 0000000000..f252bdc31a --- /dev/null +++ b/guix/import/opam.scm @@ -0,0 +1,193 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix import opam) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module ((ice-9 rdelim) #:select (read-line)) + #:use-module (srfi srfi-1) + #:use-module (web uri) + #:use-module (guix http-client) + #:use-module (guix utils) + #:use-module (guix import utils) + #:use-module ((guix licenses) #:prefix license:) + #:export (opam->guix-package)) + +(define (opam-urls) + "Fetch the urls.txt file from the opam repository and returns the list of +URLs it contains." + (let ((port (http-fetch/cached (string->uri "https://opam.ocaml.org/urls.txt")))) + (let loop ((result '())) + (let ((line (read-line port))) + (if (eof-object? line) + (begin + (close port) + result) + (loop (cons line result))))))) + +(define (vhash-ref hashtable key default) + (match (vhash-assoc key hashtable) + (#f default) + ((_ . x) x))) + +(define (hashtable-update hashtable line) + "Parse @var{line} to get the name and version of the package and adds them +to the hashtable." + (let* ((line (string-split line #\ ))) + (match line + ((url foo ...) + (if (equal? url "repo") + hashtable + (match (string-split url #\/) + ((type name1 versionstr foo ...) + (if (equal? type "packages") + (match (string-split versionstr #\.) + ((name2 versions ...) + (let ((version (string-join versions "."))) + (if (equal? name1 name2) + (let ((curr (vhash-ref hashtable name1 '()))) + (vhash-cons name1 (cons version curr) hashtable)) + hashtable))) + (_ hashtable)) + hashtable)) + (_ hashtable)))) + (_ hashtable)))) + +(define (urls->hashtable urls) + "Transform urls.txt in a hashtable whose keys are package names and values +the list of available versions." + (let ((hashtable vlist-null)) + (let loop ((urls urls) (hashtable hashtable)) + (match urls + (() hashtable) + ((url rest ...) (loop rest (hashtable-update hashtable url))))))) + +(define (latest-version versions) + "Find the most recent version from a list of versions." + (match versions + ((first rest ...) + (let loop ((versions rest) (m first)) + (match versions + (() m) + ((first rest ...) + (loop rest (if (version>? m first) m first)))))))) + +(define (fetch-package-url uri) + "Fetch and parse the url file. Return the URL the package can be downloaded +from." + (let ((port (http-fetch uri))) + (let loop ((result #f)) + (let ((line (read-line port))) + (if (eof-object? line) + (begin + (close port) + result) + (let* ((line (string-split line #\ ))) + (match line + ((key value rest ...) + (if (member key '("archive:" "http:")) + (loop (string-trim-both value #\")) + (loop result)))))))))) + +(define (fetch-package-metadata uri) + "Fetch and parse the opam file. Return an association list containing the +homepage, the license and the list of inputs." + (let ((port (http-fetch uri))) + (let loop ((result '()) (dependencies? #f)) + (let ((line (read-line port))) + (if (eof-object? line) + (begin + (close port) + result) + (let* ((line (string-split line #\ ))) + (match line + ((key value ...) + (let ((dependencies? + (if dependencies? + (not (equal? key "]")) + (equal? key "depends:"))) + (val (string-trim-both (string-join value "") #\"))) + (cond + ((equal? key "homepage:") + (loop (cons `("homepage" . ,val) result) dependencies?)) + ((equal? key "license:") + (loop (cons `("license" . ,val) result) dependencies?)) + ((and dependencies? (not (equal? val "["))) + (match (string-split val #\{) + ((val rest ...) + (let ((curr (assoc-ref result "inputs")) + (new (string-trim-both + val (list->char-set '(#\] #\[ #\"))))) + (loop (cons `("inputs" . ,(cons new (if curr curr '()))) result) + (if (string-contains val "]") #f dependencies?)))))) + (else (loop result dependencies?)))))))))))) + +(define (string->license str) + (cond + ((equal? str "MIT") '(license:expat)) + ((equal? str "GPL2") '(license:gpl2)) + ((equal? str "LGPLv2") '(license:lgpl2)) + (else `()))) + +(define (ocaml-name->guix-name name) + (cond + ((equal? name "ocamlfind") "ocaml-findlib") + ((string-prefix? "ocaml" name) name) + ((string-prefix? "conf-" name) (substring name 5)) + (else (string-append "ocaml-" name)))) + +(define (dependencies->inputs dependencies) + "Transform the list of dependencies in a list of inputs." + (if (not dependencies) + '() + (map (lambda (input) + (list input (list 'unquote (string->symbol input)))) + (map ocaml-name->guix-name dependencies)))) + +(define (opam->guix-package name) + (let* ((hashtable (urls->hashtable (opam-urls))) + (versions (vhash-ref hashtable name #f))) + (unless (eq? versions #f) + (let* ((version (latest-version versions)) + (package-url (string-append "https://opam.ocaml.org/packages/" name + "/" name "." version "/")) + (url-url (string-append package-url "url")) + (opam-url (string-append package-url "opam")) + (source-url (fetch-package-url url-url)) + (metadata (fetch-package-metadata opam-url)) + (dependencies (assoc-ref metadata "inputs")) + (inputs (dependencies->inputs dependencies))) + (call-with-temporary-output-file + (lambda (temp port) + (and (url-fetch source-url temp) + `(package + (name ,(ocaml-name->guix-name name)) + (version ,version) + (source + (origin + (method url-fetch) + (uri ,source-url) + (sha256 (base32 ,(guix-hash-url temp))))) + (build-system ocaml-build-system) + ,@(if (null? inputs) + '() + `((inputs ,(list 'quasiquote inputs)))) + (home-page ,(assoc-ref metadata "homepage")) + (synopsis "") + (description "") + (license ,@(string->license (assoc-ref metadata "license"))))))))))) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 6beab6b010..25560bac46 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -51,8 +51,7 @@ (define (pypi-fetch name) "Return an alist representation of the PyPI metadata for the package NAME, or #f on failure." - (json-fetch-alist (string-append "https://pypi.python.org/pypi/" - name "/json"))) + (json-fetch-alist (string-append "https://pypi.org/pypi/" name "/json"))) ;; For packages found on PyPI that lack a source distribution. (define-condition-type &missing-source-error &error @@ -87,7 +86,7 @@ package." (string-append "python-" (snake-case name)))) (define (guix-package->pypi-name package) - "Given a Python PACKAGE built from pypi.python.org, return the name of the + "Given a Python PACKAGE built from pypi.org, return the name of the package on PyPI." (define (url->pypi-name url) (hyphen-package-name->name+version @@ -269,7 +268,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (license ,(license->symbol license))))))) (define (pypi->guix-package package-name) - "Fetch the metadata for PACKAGE-NAME from pypi.python.org, and return the + "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the `package' s-expression corresponding to that package, or #f on failure." (let ((package (pypi-fetch package-name))) (and package @@ -304,7 +303,8 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." "Return true if PACKAGE is a Python package from PyPI." (define (pypi-url? url) - (or (string-prefix? "https://pypi.python.org/" url) + (or (string-prefix? "https://pypi.org/" url) + (string-prefix? "https://pypi.python.org/" url) (string-prefix? "https://pypi.io/packages" url))) (let ((source-url (and=> (package-source package) origin-uri)) |