diff options
Diffstat (limited to 'guix/import')
| -rw-r--r-- | guix/import/cran.scm | 48 | ||||
| -rw-r--r-- | guix/import/crate.scm | 153 | ||||
| -rw-r--r-- | guix/import/elpa.scm | 240 | ||||
| -rw-r--r-- | guix/import/gem.scm | 6 | ||||
| -rw-r--r-- | guix/import/opam.scm | 64 | ||||
| -rw-r--r-- | guix/import/print.scm | 3 | ||||
| -rw-r--r-- | guix/import/pypi.scm | 8 | ||||
| -rw-r--r-- | guix/import/stackage.scm | 5 | ||||
| -rw-r--r-- | guix/import/utils.scm | 92 |
9 files changed, 467 insertions, 152 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm index a1275b4822..fd44d80915 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +29,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 receive) #:use-module (web uri) #:use-module (guix memoization) @@ -49,7 +51,9 @@ #:use-module (guix upstream) #:use-module (guix packages) #:use-module (gnu packages) - #:export (cran->guix-package + #:export (%input-style + + cran->guix-package bioconductor->guix-package cran-recursive-import %cran-updater @@ -72,6 +76,9 @@ ;;; ;;; Code: +(define %input-style + (make-parameter 'variable)) ; or 'specification + (define string->license (match-lambda ("AGPL-3" 'agpl3+) @@ -126,7 +133,11 @@ (define (format-inputs names) "Generate a sorted list of package inputs from a list of package NAMES." (map (lambda (name) - (list name (list 'unquote (string->symbol name)))) + (case (%input-style) + ((specification) + (list name (list 'unquote (list 'specification->package name)))) + (else + (list name (list 'unquote (string->symbol name)))))) (sort names string-ci<?))) (define* (maybe-inputs package-inputs #:optional (type 'inputs)) @@ -139,11 +150,12 @@ package definition." `((,type (,'quasiquote ,(format-inputs package-inputs))))))) (define %cran-url "https://cran.r-project.org/web/packages/") +(define %cran-canonical-url "https://cran.r-project.org/package=") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.11. Bioconductor packages should be +;; The latest Bioconductor release is 3.12. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.11") +(define %bioconductor-version "3.12") (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" @@ -439,6 +451,10 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ((bioconductor) %bioconductor-url) ((git) #f) ((hg) #f))) + (canonical-url-base (case repository + ((cran) %cran-canonical-url) + ((bioconductor) %bioconductor-url) + ((git) #f))) (uri-helper (case repository ((cran) cran-uri) ((bioconductor) bioconductor-uri) @@ -454,7 +470,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ((hg) (assoc-ref meta 'hg)) (else (match (listify meta "URL") ((url rest ...) url) - (_ (string-append base-url name)))))) + (_ (string-append canonical-url-base name)))))) (source-url (case repository ((git) (assoc-ref meta 'git)) ((hg) (assoc-ref meta 'hg)) @@ -568,7 +584,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (define cran->guix-package (memoize - (lambda* (package-name #:optional (repo 'cran)) + (lambda* (package-name #:key (repo 'cran) version) "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' s-expression corresponding to that package, or #f on failure." (let ((description (fetch-description repo package-name))) @@ -577,17 +593,21 @@ s-expression corresponding to that package, or #f on failure." (case repo ((git) ;; Retry import from Bioconductor - (cran->guix-package package-name 'bioconductor)) + (cran->guix-package package-name #:repo 'bioconductor)) ((hg) ;; Retry import from Bioconductor - (cran->guix-package package-name 'bioconductor)) + (cran->guix-package package-name #:repo 'bioconductor)) ((bioconductor) ;; Retry import from CRAN - (cran->guix-package package-name 'cran)) - (else (values #f '())))))))) - -(define* (cran-recursive-import package-name #:optional (repo 'cran)) - (recursive-import package-name repo + (cran->guix-package package-name #:repo 'cran)) + (else + (raise (condition + (&message + (message "couldn't find meta-data for R package"))))))))))) + +(define* (cran-recursive-import package-name #:key (repo 'cran)) + (recursive-import package-name + #:repo repo #:repo->guix-package cran->guix-package #:guix-name cran-guix-name)) @@ -653,7 +673,7 @@ s-expression corresponding to that package, or #f on failure." (input-changes (changed-inputs pkg - (cran->guix-package upstream-name 'bioconductor)))))) + (cran->guix-package upstream-name #:repo 'bioconductor)))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 8c2b76cab4..aee1b01c9f 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net> +;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,16 +27,19 @@ #:use-module (guix import json) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix memoization) #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix utils) + #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) #:export (crate->guix-package guix-package->crate-name string->license @@ -85,10 +88,16 @@ crate-dependency? json->crate-dependency (id crate-dependency-id "crate_id") ;string - (kind crate-dependency-kind "kind" ;'normal | 'dev + (kind crate-dependency-kind "kind" ;'normal | 'dev | 'build string->symbol) (requirement crate-dependency-requirement "req")) ;string +;; Autoload Guile-Semver so we only have a soft dependency. +(module-autoload! (current-module) + '(semver) '(string->semver semver->string semver<?)) +(module-autoload! (current-module) + '(semver ranges) '(string->semver-range semver-range-contains?)) + (define (lookup-crate name) "Look up NAME on https://crates.io and return the corresopnding <crate> record or #f if it was not found." @@ -104,6 +113,8 @@ record or #f if it was not found." (json->crate `(,@alist ("actual_versions" . ,versions)))))))) +(define lookup-crate* (memoize lookup-crate)) + (define (crate-version-dependencies version) "Return the list of <crate-dependency> records of VERSION, a <crate-version>." @@ -141,17 +152,29 @@ record or #f if it was not found." ((args ...) `((arguments (,'quasiquote ,args)))))) +(define (version->semver-prefix version) + "Return the version up to and including the first non-zero part" + (first + (map match:substring + (list-matches "^(0+\\.){,2}[0-9]+" version)))) + (define* (make-crate-sexp #:key name version cargo-inputs cargo-development-inputs - home-page synopsis description license - #:allow-other-keys) + home-page synopsis description license build?) "Return the `package' s-expression for a rust package with the given NAME, VERSION, CARGO-INPUTS, CARGO-DEVELOPMENT-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." + (define (format-inputs inputs) + (map + (match-lambda + ((name version) + (list (crate-name->package-name name) + (version->semver-prefix version)))) + inputs)) + (let* ((port (http-fetch (crate-uri name version))) (guix-name (crate-name->package-name name)) - (cargo-inputs (map crate-name->package-name cargo-inputs)) - (cargo-development-inputs (map crate-name->package-name - cargo-development-inputs)) + (cargo-inputs (format-inputs cargo-inputs)) + (cargo-development-inputs (format-inputs cargo-development-inputs)) (pkg `(package (name ,guix-name) (version ,version) @@ -163,7 +186,10 @@ and LICENSE." (base32 ,(bytevector->nix-base32-string (port-sha256 port)))))) (build-system cargo-build-system) - ,@(maybe-arguments (append (maybe-cargo-inputs cargo-inputs) + ,@(maybe-arguments (append (if build? + '() + '(#:skip-build? #t)) + (maybe-cargo-inputs cargo-inputs) (maybe-cargo-development-inputs cargo-development-inputs))) (home-page ,(match home-page @@ -176,7 +202,7 @@ and LICENSE." ((license) license) (_ `(list ,@license))))))) (close-port port) - pkg)) + (package->definition pkg (version->semver-prefix version)))) (define (string->license string) (filter-map (lambda (license) @@ -187,41 +213,94 @@ and LICENSE." 'unknown-license!))) (string-split string (string->char-set " /")))) -(define* (crate->guix-package crate-name #:optional version) +(define* (crate->guix-package crate-name #:key version include-dev-deps? repo) "Fetch the metadata for CRATE-NAME from crates.io, and return the `package' s-expression corresponding to that package, or #f on failure. -When VERSION is specified, attempt to fetch that version; otherwise fetch the -latest version of CRATE-NAME." +When VERSION is specified, convert it into a semver range and attempt to fetch +the latest version matching this semver range; otherwise fetch the latest +version of CRATE-NAME. If INCLUDE-DEV-DEPS is true then this will also +look up the development dependencs for the given crate." + + (define (semver-range-contains-string? range version) + (semver-range-contains? (string->semver-range range) + (string->semver version))) (define (normal-dependency? dependency) - (eq? (crate-dependency-kind dependency) 'normal)) + (or (eq? (crate-dependency-kind dependency) 'build) + (eq? (crate-dependency-kind dependency) 'normal))) (define crate - (lookup-crate crate-name)) + (lookup-crate* crate-name)) (define version-number (and crate (or version (crate-latest-version crate)))) + ;; find the highest existing package that fulfills the semver <range> + (define (find-package-version name range) + (let* ((semver-range (string->semver-range range)) + (versions + (sort + (filter (lambda (version) + (semver-range-contains? semver-range version)) + (map (lambda (pkg) + (string->semver (package-version pkg))) + (find-packages-by-name + (crate-name->package-name name)))) + semver<?))) + (and (not (null-list? versions)) + (semver->string (last versions))))) + + ;; find the highest version of a crate that fulfills the semver <range> + (define (find-crate-version crate range) + (let* ((semver-range (string->semver-range range)) + (versions + (sort + (filter (lambda (entry) + (semver-range-contains? semver-range (first entry))) + (map (lambda (ver) + (list (string->semver (crate-version-number ver)) + ver)) + (crate-versions crate))) + (match-lambda* (((semver _) ...) + (apply semver<? semver)))))) + (and (not (null-list? versions)) + (second (last versions))))) + + (define (dependency-name+version dep) + (let* ((name (crate-dependency-id dep)) + (req (crate-dependency-requirement dep)) + (existing-version (find-package-version name req))) + (if existing-version + (list name existing-version) + (let* ((crate (lookup-crate* name)) + (ver (find-crate-version crate req))) + (list name + (crate-version-number ver)))))) + (define version* (and crate - (find (lambda (version) - (string=? (crate-version-number version) - version-number)) - (crate-versions crate)))) + (find-crate-version crate version-number))) + + ;; sort and map the dependencies to a list containing + ;; pairs of (name version) + (define (sort-map-dependencies deps) + (sort (map dependency-name+version + deps) + (match-lambda* (((name _) ...) + (apply string-ci<? name))))) (and crate version* - (let* ((dependencies (crate-version-dependencies version*)) - (dep-crates (filter normal-dependency? dependencies)) - (dev-dep-crates (remove normal-dependency? dependencies)) - (cargo-inputs (sort (map crate-dependency-id dep-crates) - string-ci<?)) - (cargo-development-inputs - (sort (map crate-dependency-id dev-dep-crates) - string-ci<?))) + (let* ((dependencies (crate-version-dependencies version*)) + (dep-crates dev-dep-crates (partition normal-dependency? dependencies)) + (cargo-inputs (sort-map-dependencies dep-crates)) + (cargo-development-inputs (if include-dev-deps? + (sort-map-dependencies dev-dep-crates) + '()))) (values - (make-crate-sexp #:name crate-name + (make-crate-sexp #:build? include-dev-deps? + #:name crate-name #:version (crate-version-number version*) #:cargo-inputs cargo-inputs #:cargo-development-inputs cargo-development-inputs @@ -233,13 +312,15 @@ latest version of CRATE-NAME." string->license)) (append cargo-inputs cargo-development-inputs))))) -(define* (crate-recursive-import crate-name #:optional version) - (recursive-import crate-name #f - #:repo->guix-package - (lambda (name repo) - (let ((version (and (string=? name crate-name) - version))) - (crate->guix-package name version))) +(define* (crate-recursive-import crate-name #:key version) + (recursive-import crate-name + #:repo->guix-package (lambda* params + ;; download development dependencies only for the top level package + (let ((include-dev-deps? (equal? (car params) crate-name)) + (crate->guix-package* (memoize crate->guix-package))) + (apply crate->guix-package* + (append params `(#:include-dev-deps? ,include-dev-deps?))))) + #:version version #:guix-name crate-name->package-name)) (define (guix-package->crate-name package) @@ -254,7 +335,7 @@ latest version of CRATE-NAME." ((name _ ...) name)))) (define (crate-name->package-name name) - (string-append "rust-" (string-join (string-split name #\_) "-"))) + (guix-name "rust-" name)) ;;; @@ -277,7 +358,7 @@ latest version of CRATE-NAME." (define %crate-updater (upstream-updater - (name 'crates) + (name 'crate) (description "Updater for crates.io packages") (pred crate-package?) (latest latest-release))) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 871b918f88..c0dc5acf51 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -1,7 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> -;;; Copyright © 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> +;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> +;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,15 +23,20 @@ (define-module (guix import elpa) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) #:use-module (web uri) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) #:use-module (guix http-client) + #:use-module (guix git) + #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix store) #:use-module (guix ui) #:use-module (gcrypt hash) @@ -195,10 +202,143 @@ include VERSION." url))) (_ #f)))) -(define* (elpa-package->sexp pkg #:optional license) +(define* (download-git-repository url ref) + "Fetch the given REF from the Git repository at URL." + (with-store store + (latest-repository-commit store url #:ref ref))) + +(define (package-name->melpa-recipe package-name) + "Fetch the MELPA recipe for PACKAGE-NAME, represented as an alist from +keywords to values." + (define recipe-url + (string-append "https://raw.githubusercontent.com/melpa/melpa/master/recipes/" + package-name)) + + (define (data->recipe data) + (match data + (() '()) + ((key value . tail) + (cons (cons key value) (data->recipe tail))))) + + (let* ((port (http-fetch/cached (string->uri recipe-url) + #:ttl (* 6 3600))) + (data (read port))) + (close-port port) + (data->recipe (cons ':name data)))) + +;; XXX adapted from (guix scripts hash) +(define (file-hash file select? recursive?) + ;; Compute the hash of FILE. + (if recursive? + (let-values (((port get-hash) (open-sha256-port))) + (write-file file port #:select? select?) + (force-output port) + (get-hash)) + (call-with-input-file file port-sha256))) + +;; XXX taken from (guix scripts hash) +(define (vcs-file? file stat) + (case (stat:type stat) + ((directory) + (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) + ((regular) + ;; Git sub-modules have a '.git' file that is a regular text file. + (string=? (basename file) ".git")) + (else + #f))) + +(define (git-repository->origin recipe url) + "Fetch origin details from the Git repository at URL for the provided MELPA +RECIPE." + (define ref + (cond + ((assoc-ref recipe #:branch) + => (lambda (branch) (cons 'branch branch))) + ((assoc-ref recipe #:commit) + => (lambda (commit) (cons 'commit commit))) + (else + '(branch . "master")))) + + (let-values (((directory commit) (download-git-repository url ref))) + `(origin + (method git-fetch) + (uri (git-reference + (url ,url) + (commit ,commit))) + (sha256 + (base32 + ,(bytevector->nix-base32-string + (file-hash directory (negate vcs-file?) #t))))))) + +(define* (melpa-recipe->origin recipe) + "Fetch origin details from the MELPA recipe and associated repository for +the package named PACKAGE-NAME." + (define (github-repo->url repo) + (string-append "https://github.com/" repo ".git")) + (define (gitlab-repo->url repo) + (string-append "https://gitlab.com/" repo ".git")) + + (match (assq-ref recipe ':fetcher) + ('github (git-repository->origin recipe (github-repo->url (assq-ref recipe ':repo)))) + ('gitlab (git-repository->origin recipe (gitlab-repo->url (assq-ref recipe ':repo)))) + ('git (git-repository->origin recipe (assq-ref recipe ':url))) + (#f #f) ; if we're not using melpa then this stops us printing a warning + (_ (warning (G_ "Unsupported MELPA fetcher: ~a, falling back to unstable MELPA source.~%") + (assq-ref recipe ':fetcher)) + #f))) + +(define default-files-spec + ;; This contains more than just the things contained in %default-include and + ;; %default-exclude, presumably because this includes source files (*.in, + ;; *.texi, etc.) which have already been processed for releases. + ;; + ;; Taken from: + ;; https://github.com/melpa/melpa/blob/e8dc709d0ab2b4a68c59315f42858bcb86095f11/package-build/package-build.el#L580-L585 + '("*.el" "*.el.in" "dir" + "*.info" "*.texi" "*.texinfo" + "doc/dir" "doc/*.info" "doc/*.texi" "doc/*.texinfo" + (:exclude ".dir-locals.el" "test.el" "tests.el" "*-test.el" "*-tests.el"))) + +(define* (melpa-recipe->maybe-arguments melpa-recipe) + "Extract arguments for the build system from MELPA-RECIPE." + (define (glob->regexp glob) + (string-append + "^" + (regexp-substitute/global #f "\\*\\*?" glob + 'pre + (lambda (m) + (if (string= (match:substring m 0) "**") + ".*" + "[^/]+")) + 'post) + "$")) + + (let ((files (assq-ref melpa-recipe ':files))) + (if files + (let* ((with-default (apply append (map (lambda (entry) + (if (eq? ':defaults entry) + default-files-spec + (list entry))) + files))) + (inclusions (remove pair? with-default)) + (exclusions (apply append (map (match-lambda + ((':exclude . values) + values) + (_ '())) + with-default)))) + `((arguments '(#:include ',(map glob->regexp inclusions) + #:exclude ',(map glob->regexp exclusions))))) + '()))) + +(define* (elpa-package->sexp pkg #:optional license repo) "Return the `package' S-expression for the Emacs package PKG, a record of type '<elpa-package>'." + (define melpa-recipe + (if (eq? repo 'melpa) + (package-name->melpa-recipe (elpa-package-name pkg)) + #f)) + (define name (elpa-package-name pkg)) (define version (elpa-package-version pkg)) @@ -223,37 +363,49 @@ type '<elpa-package>'." (list (list input-type (list 'quasiquote inputs)))))) - (let ((tarball (with-store store - (download-to-store store source-url)))) - (values - `(package - (name ,(elpa-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 package"))))) - (build-system emacs-build-system) - ,@(maybe-inputs 'propagated-inputs dependencies) - (home-page ,(elpa-package-home-page pkg)) - (synopsis ,(elpa-package-synopsis pkg)) - (description ,(elpa-package-description pkg)) - (license ,license)) - dependencies-names))) - -(define* (elpa->guix-package name #:optional (repo 'gnu)) + (define melpa-source + (melpa-recipe->origin melpa-recipe)) + + (values + `(package + (name ,(elpa-name->package-name name)) + (version ,version) + (source ,(or melpa-source + (let ((tarball (with-store store + (download-to-store store source-url)))) + `(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 package"))))))) + (build-system emacs-build-system) + ,@(maybe-inputs 'propagated-inputs dependencies) + ,@(if melpa-source + (melpa-recipe->maybe-arguments melpa-recipe) + '()) + (home-page ,(elpa-package-home-page pkg)) + (synopsis ,(elpa-package-synopsis pkg)) + (description ,(elpa-package-description pkg)) + (license ,license)) + dependencies-names)) + +(define* (elpa->guix-package name #:key (repo 'gnu) version) "Fetch the package NAME from REPO and produce a Guix package S-expression." (match (fetch-elpa-package name repo) - (#f #f) + (#false + (raise (condition + (&message + (message (format #false + "couldn't find meta-data for ELPA package `~a'." + name)))))) (package ;; ELPA is known to contain only GPLv3+ code. Other repos may contain ;; code under other license but there's no license metadata. (let ((license (and (memq repo '(gnu gnu/http)) 'license:gpl3+))) - (elpa-package->sexp package license))))) + (elpa-package->sexp package license repo))))) ;;; @@ -267,19 +419,24 @@ type '<elpa-package>'." (string-drop (package-name package) 6) (package-name package))) - (let* ((repo 'gnu) - (info (elpa-package-info name repo)) - (version (match info - ((name raw-version . _) - (elpa-version->string raw-version)))) - (url (match info - ((_ raw-version reqs synopsis kind . rest) - (package-source-url kind name version repo))))) - (upstream-source - (package (package-name package)) - (version version) - (urls (list url)) - (signature-urls (list (string-append url ".sig")))))) + (define repo 'gnu) + + (match (elpa-package-info name repo) + (#f + ;; No info, perhaps because PACKAGE is not truly an ELPA package. + #f) + (info + (let* ((version (match info + ((name raw-version . _) + (elpa-version->string raw-version)))) + (url (match info + ((_ raw-version reqs synopsis kind . rest) + (package-source-url kind name version repo))))) + (upstream-source + (package (package-name package)) + (version version) + (urls (list url)) + (signature-urls (list (string-append url ".sig")))))))) (define package-from-gnu.org? (url-predicate (lambda (url) @@ -299,7 +456,8 @@ type '<elpa-package>'." (define elpa-guix-name (cut guix-name "emacs-" <>)) (define* (elpa-recursive-import package-name #:optional (repo 'gnu)) - (recursive-import package-name repo + (recursive-import package-name + #:repo repo #:repo->guix-package elpa->guix-package #:guix-name elpa-guix-name)) diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 3fe240f36a..1f6f94532e 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -122,7 +123,7 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES." ((license) (license->symbol license)) (_ `(list ,@(map license->symbol licenses))))))) -(define* (gem->guix-package package-name #:optional (repo 'rubygems) version) +(define* (gem->guix-package package-name #:key (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 ((gem (rubygems-fetch package-name))) @@ -188,6 +189,7 @@ package on RubyGems." (latest latest-release))) (define* (gem-recursive-import package-name #:optional version) - (recursive-import package-name '() + (recursive-import package-name + #:repo '() #:repo->guix-package gem->guix-package #:guix-name ruby-package-name)) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 6d9eb0a092..670973b193 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> +;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -119,12 +120,29 @@ (define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE)) (define-peg-pattern condition-var all (+ (or (range #\a #\z) "-" ":"))) -(define (get-opam-repository) +(define* (get-opam-repository #:optional repo) "Update or fetch the latest version of the opam repository and return the path to the repository." - (receive (location commit _) - (update-cached-checkout "https://github.com/ocaml/opam-repository") - location)) + (let ((url (cond + ((or (not repo) (equal? repo 'opam)) + "https://github.com/ocaml/opam-repository") + ((string-prefix? "coq-" (symbol->string repo)) + "https://github.com/coq/opam-coq-archive") + ((equal? repo 'coq) "https://github.com/coq/opam-coq-archive") + (else (throw 'unknown-repository repo))))) + (receive (location commit _) + (update-cached-checkout url) + (cond + ((or (not repo) (equal? repo 'opam)) + location) + ((equal? repo 'coq) + (string-append location "/released")) + ((string-prefix? "coq-" (symbol->string repo)) + (string-append location "/" (substring (symbol->string repo) 4))) + (else location))))) + +;; Prevent Guile 3 from inlining this procedure so we can mock it in tests. +(set! get-opam-repository get-opam-repository) (define (latest-version versions) "Find the most recent version from a list of versions." @@ -160,6 +178,7 @@ path to the repository." (substitute-char (cond ((equal? name "ocamlfind") "ocaml-findlib") + ((equal? name "coq") name) ((string-prefix? "ocaml" name) name) ((string-prefix? "conf-" name) (substring name 5)) (else (string-append "ocaml-" name))) @@ -234,12 +253,15 @@ path to the repository." (equal? "ocaml" name)) names))) -(define (depends->inputs depends) +(define (filter-dependencies depends) + "Remove implicit dependencies from the list of dependencies in @var{depends}." (filter (lambda (name) - (and (not (equal? "" name)) - (not (equal? "ocaml" name)) - (not (equal? "ocamlfind" name)))) - (map dependency->input depends))) + (and (not (member name '("" "ocaml" "ocamlfind" "dune" "jbuilder"))) + (not (string-prefix? "base-" name)))) + depends)) + +(define (depends->inputs depends) + (filter-dependencies (map dependency->input depends))) (define (depends->native-inputs depends) (filter (lambda (name) (not (equal? "" name))) @@ -260,18 +282,19 @@ path to the repository." (substring version 1) version))))) -(define* (opam->guix-package name #:key (repository (get-opam-repository))) +(define* (opam->guix-package name #:key (repo 'opam) version) "Import OPAM package NAME from REPOSITORY (a directory name) or, if REPOSITORY is #f, from the official OPAM repository. Return a 'package' sexp or #f on failure." - (and-let* ((opam-file (opam-fetch name repository)) + (and-let* ((opam-file (opam-fetch name (get-opam-repository repo))) (version (assoc-ref opam-file "version")) - (opam-content (pk (assoc-ref opam-file "metadata"))) + (opam-content (assoc-ref opam-file "metadata")) (url-dict (metadata-ref opam-content "url")) (source-url (or (metadata-ref url-dict "src") (metadata-ref url-dict "archive"))) (requirements (metadata-ref opam-content "depends")) - (dependencies (dependency-list->names requirements)) + (names (dependency-list->names requirements)) + (dependencies (filter-dependencies names)) (native-dependencies (depends->native-inputs requirements)) (inputs (dependency-list->inputs (depends->inputs requirements))) (native-inputs (dependency-list->inputs @@ -281,10 +304,7 @@ or #f on failure." (lambda (name) (not (member name '("dune" "jbuilder")))) native-dependencies)))) - ;; If one of these are required at build time, it means we - ;; can use the much nicer dune-build-system. - (let ((use-dune? (or (member "dune" (append dependencies native-dependencies)) - (member "jbuilder" (append dependencies native-dependencies))))) + (let ((use-dune? (member "dune" names))) (call-with-temporary-output-file (lambda (temp port) (and (url-fetch source-url temp) @@ -321,11 +341,11 @@ or #f on failure." (not (member name '("dune" "jbuilder")))) dependencies)))))))) -(define (opam-recursive-import package-name) - (recursive-import package-name #f - #:repo->guix-package (lambda (name repo) - (opam->guix-package name)) - #:guix-name ocaml-name->guix-name)) +(define* (opam-recursive-import package-name #:key repo) + (recursive-import package-name + #:repo->guix-package opam->guix-package + #:guix-name ocaml-name->guix-name + #:repo repo)) (define (guix-name->opam-name name) (if (string-prefix? "ocaml-" name) diff --git a/guix/import/print.scm b/guix/import/print.scm index d21ce57aeb..a2ab810a5c 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -57,7 +57,8 @@ when evaluated." ;; Print either license variable name or the code for a license object (define (license->code lic) (let ((var (variable-name lic '(guix licenses)))) - (or (symbol-append 'license: var) + (if var + (symbol-append 'license: var) `(license (name ,(license-name lic)) (uri ,(license-uri lic)) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 15116e349d..bf4dc50138 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2020 Lars-Dominik Braun <ldb@leibniz-psychology.org> ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -471,7 +472,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (define pypi->guix-package (memoize - (lambda* (package-name) + (lambda* (package-name #:key repo version) "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the `package' s-expression corresponding to that package, or #f on failure." (let* ((project (pypi-fetch package-name)) @@ -495,9 +496,8 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (project-info-license info))))))))) (define (pypi-recursive-import package-name) - (recursive-import package-name #f - #:repo->guix-package (lambda (name repo) - (pypi->guix-package name)) + (recursive-import package-name + #:repo->guix-package pypi->guix-package #:guix-name python->package-name)) (define (string->license str) diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 77cc6350cb..bbd903a2cd 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -109,8 +110,8 @@ included in the Stackage LTS release." (leave-with-message "~a: Stackage package not found" package-name)))))) (define (stackage-recursive-import package-name . args) - (recursive-import package-name #f - #:repo->guix-package (lambda (name repo) + (recursive-import package-name + #:repo->guix-package (lambda* (name #:key repo version) (apply stackage->guix-package (cons name args))) #:guix-name hackage-name->package-name)) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 145515c489..2f5ccf7cea 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> ;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com> +;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,6 +46,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) #:export (factorize-uri flatten @@ -227,13 +229,20 @@ into a proper sentence and by using two spaces between sentences." cleaned 'pre ". " 'post))) (define* (package-names->package-inputs names #:optional (output #f)) - "Given a list of PACKAGE-NAMES, and an optional OUTPUT, tries to generate a -quoted list of inputs, as suitable to use in an 'inputs' field of a package -definition." - (map (lambda (input) - (cons* input (list 'unquote (string->symbol input)) - (or (and output (list output)) - '()))) + "Given a list of PACKAGE-NAMES or (PACKAGE-NAME VERSION) pairs, and an +optional OUTPUT, tries to generate a quoted list of inputs, as suitable to +use in an 'inputs' field of a package definition." + (define (make-input input version) + (cons* input (list 'unquote (string->symbol + (if version + (string-append input "-" version) + input))) + (or (and output (list output)) + '()))) + + (map (match-lambda + ((input version) (make-input input version)) + (input (make-input input #f))) names)) (define* (maybe-inputs package-names #:optional (output #f)) @@ -254,13 +263,21 @@ package definition." ((package-inputs ...) `((native-inputs (,'quasiquote ,package-inputs)))))) -(define (package->definition guix-package) +(define* (package->definition guix-package #:optional append-version?/string) + "If APPEND-VERSION?/STRING is #t, append the package's major+minor +version. If APPEND-VERSION?/string is a string, append this string." (match guix-package - (('package ('name (? string? name)) _ ...) - `(define-public ,(string->symbol name) - ,guix-package)) - (('let anything ('package ('name (? string? name)) _ ...)) - `(define-public ,(string->symbol name) + ((or + ('package ('name name) ('version version) . rest) + ('let _ ('package ('name name) ('version version) . rest))) + + `(define-public ,(string->symbol + (cond + ((string? append-version?/string) + (string-append name "-" append-version?/string)) + ((eq? append-version?/string #t) + (string-append name "-" (version-major+minor version))) + (else name))) ,guix-package)))) (define (build-system-modules) @@ -355,8 +372,12 @@ specifications to look up and replace them with plain symbols instead." (match (assoc-ref meta "license") (#f #f) (l - (or (module-ref (resolve-interface '(guix licenses) #:prefix 'license:) - (spdx-string->license l)) + (or (false-if-exception + (module-ref (resolve-interface '(guix licenses)) + (string->symbol l))) + (false-if-exception + (module-ref (resolve-interface '(guix licenses) #:prefix 'license:) + (spdx-string->license l))) (license:fsdg-compatible l))))))) (define* (read-lines #:optional (port (current-input-port))) @@ -409,32 +430,43 @@ obtain a node's uniquely identifying \"key\"." (cons head result) (set-insert (node-name head) visited)))))))) -(define* (recursive-import package-name repo - #:key repo->guix-package guix-name +(define* (recursive-import package-name + #:key repo->guix-package guix-name version repo #:allow-other-keys) "Return a list of package expressions for PACKAGE-NAME and all its dependencies, sorted in topological order. For each package, -call (REPO->GUIX-PACKAGE NAME REPO), which should return a package expression -and a list of dependencies; call (GUIX-NAME NAME) to obtain the Guix package -name corresponding to the upstream name." +call (REPO->GUIX-PACKAGE NAME :KEYS version repo), which should return a +package expression and a list of dependencies; call (GUIX-NAME NAME) to +obtain the Guix package name corresponding to the upstream name." (define-record-type <node> - (make-node name package dependencies) + (make-node name version package dependencies) node? (name node-name) + (version node-version) (package node-package) (dependencies node-dependencies)) - (define (exists? name) - (not (null? (find-packages-by-name (guix-name name))))) + (define (exists? name version) + (not (null? (find-packages-by-name (guix-name name) version)))) - (define (lookup-node name) - (receive (package dependencies) (repo->guix-package name repo) - (make-node name package dependencies))) + (define (lookup-node name version) + (let* ((package dependencies (repo->guix-package name + #:version version + #:repo repo)) + (normalized-deps (map (match-lambda + ((name version) (list name version)) + (name (list name #f))) dependencies))) + (make-node name version package normalized-deps))) (map node-package - (topological-sort (list (lookup-node package-name)) + (topological-sort (list (lookup-node package-name version)) (lambda (node) - (map lookup-node - (remove exists? + (map (lambda (name-version) + (apply lookup-node name-version)) + (remove (lambda (name-version) + (apply exists? name-version)) (node-dependencies node)))) - node-name))) + (lambda (node) + (string-append + (node-name node) + (or (node-version node) "")))))) |