summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/import/cran.scm254
-rw-r--r--guix/import/utils.scm5
-rw-r--r--guix/scripts/import.scm4
3 files changed, 190 insertions, 73 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 9c964701b1..51c7ea7b2f 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -24,6 +24,7 @@
#:use-module ((ice-9 rdelim) #:select (read-string read-line))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (ice-9 receive)
@@ -32,11 +33,13 @@
#:use-module (guix http-client)
#:use-module (gcrypt hash)
#:use-module (guix store)
+ #:use-module ((guix serialization) #:select (write-file))
#:use-module (guix base32)
#:use-module ((guix download) #:select (download-to-store))
#:use-module (guix import utils)
#:use-module ((guix build utils) #:select (find-files))
#:use-module (guix utils)
+ #:use-module (guix git)
#:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri))
#:use-module (guix upstream)
#:use-module (guix packages)
@@ -166,11 +169,25 @@ bioconductor package NAME, or #F if the package is unknown."
(bioconductor-packages-list type))
(cut assoc-ref <> "Version")))
+;; 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)))
+
;; Little helper to download URLs only once.
(define download
(memoize
- (lambda (url)
- (with-store store (download-to-store store url)))))
+ (lambda* (url #:optional git)
+ (with-store store
+ (if git
+ (latest-repository-commit store url)
+ (download-to-store store url))))))
(define (fetch-description repository name)
"Return an alist of the contents of the DESCRIPTION file for the R package
@@ -211,7 +228,18 @@ from ~s: ~a (~s)~%"
(string-append dir "/DESCRIPTION") read-string))
(lambda (meta)
(if (boolean? type) meta
- (cons `(bioconductor-type . ,type) meta))))))))))))
+ (cons `(bioconductor-type . ,type) meta))))))))))
+ ((git)
+ ;; Download the git repository at "NAME"
+ (call-with-values
+ (lambda () (download name #t))
+ (lambda (dir commit)
+ (and=> (description->alist (with-input-from-file
+ (string-append dir "/DESCRIPTION") read-string))
+ (lambda (meta)
+ (cons* `(git . ,name)
+ `(git-commit . ,commit)
+ meta))))))))
(define (listify meta field)
"Look up FIELD in the alist META. If FIELD contains a comma-separated
@@ -256,7 +284,7 @@ empty list when the FIELD cannot be found."
(define cran-guix-name (cut guix-name "r-" <>))
-(define (needs-fortran? tarball)
+(define (tarball-needs-fortran? tarball)
"Check if the TARBALL contains Fortran source files."
(define (check pattern)
(parameterize ((current-error-port (%make-void-port "rw+"))
@@ -266,69 +294,127 @@ empty list when the FIELD cannot be found."
(check "*.f95")
(check "*.f")))
+(define (directory-needs-fortran? dir)
+ "Check if the directory DIR contains Fortran source files."
+ (match (find-files dir "\\.f(90|95)?")
+ (() #f)
+ (_ #t)))
+
+(define (needs-fortran? thing tarball?)
+ "Check if the THING contains Fortran source files."
+ (if tarball?
+ (tarball-needs-fortran? thing)
+ (directory-needs-fortran? thing)))
+
+(define (files-match-pattern? directory regexp . file-patterns)
+ "Return #T if any of the files matching FILE-PATTERNS in the DIRECTORY match
+the given REGEXP."
+ (let ((pattern (make-regexp regexp)))
+ (any (lambda (file)
+ (call-with-input-file file
+ (lambda (port)
+ (let loop ()
+ (let ((line (read-line port)))
+ (cond
+ ((eof-object? line) #f)
+ ((regexp-exec pattern line) #t)
+ (else (loop))))))))
+ (apply find-files directory file-patterns))))
+
(define (tarball-files-match-pattern? tarball regexp . file-patterns)
"Return #T if any of the files represented by FILE-PATTERNS in the TARBALL
match the given REGEXP."
(call-with-temporary-directory
(lambda (dir)
- (let ((pattern (make-regexp regexp)))
- (parameterize ((current-error-port (%make-void-port "rw+")))
- (apply system* "tar"
- "xf" tarball "-C" dir
- `("--wildcards" ,@file-patterns)))
- (any (lambda (file)
- (call-with-input-file file
- (lambda (port)
- (let loop ()
- (let ((line (read-line port)))
- (cond
- ((eof-object? line) #f)
- ((regexp-exec pattern line) #t)
- (else (loop))))))))
- (find-files dir))))))
-
-(define (needs-zlib? tarball)
+ (parameterize ((current-error-port (%make-void-port "rw+")))
+ (apply system* "tar"
+ "xf" tarball "-C" dir
+ `("--wildcards" ,@file-patterns)))
+ (files-match-pattern? dir regexp))))
+
+(define (directory-needs-zlib? dir)
+ "Return #T if any of the Makevars files in the src directory DIR contain a
+zlib linker flag."
+ (files-match-pattern? dir "-lz" "(Makevars.*|configure.*)"))
+
+(define (tarball-needs-zlib? tarball)
"Return #T if any of the Makevars files in the src directory of the TARBALL
contain a zlib linker flag."
(tarball-files-match-pattern?
tarball "-lz"
"*/src/Makevars*" "*/src/configure*" "*/configure*"))
-(define (needs-pkg-config? tarball)
+(define (needs-zlib? thing tarball?)
+ "Check if the THING contains files indicating a dependency on zlib."
+ (if tarball?
+ (tarball-needs-zlib? thing)
+ (directory-needs-zlib? thing)))
+
+(define (directory-needs-pkg-config? dir)
+ "Return #T if any of the Makevars files in the src directory DIR reference
+the pkg-config tool."
+ (files-match-pattern? dir "pkg-config"
+ "(Makevars.*|configure.*)"))
+
+(define (tarball-needs-pkg-config? tarball)
"Return #T if any of the Makevars files in the src directory of the TARBALL
reference the pkg-config tool."
(tarball-files-match-pattern?
tarball "pkg-config"
"*/src/Makevars*" "*/src/configure*" "*/configure*"))
+(define (needs-pkg-config? thing tarball?)
+ "Check if the THING contains files indicating a dependency on pkg-config."
+ (if tarball?
+ (tarball-needs-pkg-config? thing)
+ (directory-needs-pkg-config? thing)))
+
+;; 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)))
+
(define (description->package repository meta)
"Return the `package' s-expression for an R package published on REPOSITORY
from the alist META, which was derived from the R package's DESCRIPTION file."
(let* ((base-url (case repository
((cran) %cran-url)
- ((bioconductor) %bioconductor-url)))
+ ((bioconductor) %bioconductor-url)
+ ((git) #f)))
(uri-helper (case repository
((cran) cran-uri)
- ((bioconductor) bioconductor-uri)))
+ ((bioconductor) bioconductor-uri)
+ ((git) #f)))
(name (assoc-ref meta "Package"))
(synopsis (assoc-ref meta "Title"))
(version (assoc-ref meta "Version"))
(license (string->license (assoc-ref meta "License")))
;; Some packages have multiple home pages. Some have none.
- (home-page (match (listify meta "URL")
- ((url rest ...) url)
- (_ (string-append base-url name))))
- (source-url (match (apply uri-helper name version
- (case repository
- ((bioconductor)
- (list (assoc-ref meta 'bioconductor-type)))
- (else '())))
- ((url rest ...) url)
- ((? string? url) url)
- (_ #f)))
- (tarball (download source-url))
+ (home-page (case repository
+ ((git) (assoc-ref meta 'git))
+ (else (match (listify meta "URL")
+ ((url rest ...) url)
+ (_ (string-append base-url name))))))
+ (source-url (case repository
+ ((git) (assoc-ref meta 'git))
+ (else
+ (match (apply uri-helper name version
+ (case repository
+ ((bioconductor)
+ (list (assoc-ref meta 'bioconductor-type)))
+ (else '())))
+ ((url rest ...) url)
+ ((? string? url) url)
+ (_ #f)))))
+ (git? (assoc-ref meta 'git))
+ (source (download source-url git?))
(sysdepends (append
- (if (needs-zlib? tarball) '("zlib") '())
+ (if (needs-zlib? source (not git?)) '("zlib") '())
(filter (lambda (name)
(not (member name invalid-packages)))
(map string-downcase (listify meta "SystemRequirements")))))
@@ -339,41 +425,67 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
(listify meta "Imports")
(listify meta "LinkingTo")
(delete "R"
- (listify meta "Depends"))))))
+ (listify meta "Depends")))))
+ (package
+ `(package
+ (name ,(cran-guix-name name))
+ (version ,(case repository
+ ((git)
+ `(git-version ,version revision commit))
+ (else version)))
+ (source (origin
+ (method ,(if git?
+ 'git-fetch
+ 'url-fetch))
+ (uri ,(case repository
+ ((git)
+ `(git-reference
+ (url ,(assoc-ref meta 'git))
+ (commit commit)))
+ (else
+ `(,(procedure-name uri-helper) ,name version
+ ,@(or (and=> (assoc-ref meta 'bioconductor-type)
+ (lambda (type)
+ (list (list 'quote type))))
+ '())))))
+ ,@(if git?
+ '((file-name (git-file-name name version)))
+ '())
+ (sha256
+ (base32
+ ,(bytevector->nix-base32-string
+ (case repository
+ ((git)
+ (file-hash source (negate vcs-file?) #t))
+ (else (file-sha256 source))))))))
+ ,@(if (not (and git?
+ (equal? (string-append "r-" name)
+ (cran-guix-name name))))
+ `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
+ '())
+ (build-system r-build-system)
+ ,@(maybe-inputs sysdepends)
+ ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
+ ,@(maybe-inputs
+ `(,@(if (needs-fortran? source (not git?))
+ '("gfortran") '())
+ ,@(if (needs-pkg-config? source (not git?))
+ '("pkg-config") '()))
+ 'native-inputs)
+ (home-page ,(if (string-null? home-page)
+ (string-append base-url name)
+ home-page))
+ (synopsis ,synopsis)
+ (description ,(beautify-description (or (assoc-ref meta "Description")
+ "")))
+ (license ,license))))
(values
- `(package
- (name ,(cran-guix-name name))
- (version ,version)
- (source (origin
- (method url-fetch)
- (uri (,(procedure-name uri-helper) ,name version
- ,@(or (and=> (assoc-ref meta 'bioconductor-type)
- (lambda (type)
- (list (list 'quote type))))
- '())))
- (sha256
- (base32
- ,(bytevector->nix-base32-string (file-sha256 tarball))))))
- ,@(if (not (equal? (string-append "r-" name)
- (cran-guix-name name)))
- `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
- '())
- (build-system r-build-system)
- ,@(maybe-inputs sysdepends)
- ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
- ,@(maybe-inputs
- `(,@(if (needs-fortran? tarball)
- '("gfortran") '())
- ,@(if (needs-pkg-config? tarball)
- '("pkg-config") '()))
- 'native-inputs)
- (home-page ,(if (string-null? home-page)
- (string-append base-url name)
- home-page))
- (synopsis ,synopsis)
- (description ,(beautify-description (or (assoc-ref meta "Description")
- "")))
- (license ,license))
+ (case repository
+ ((git)
+ `(let ((commit ,(assoc-ref meta 'git-commit))
+ (revision "1"))
+ ,package))
+ (else package))
propagate)))
(define cran->guix-package
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 2a3b7341fb..252875eeab 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -2,7 +2,7 @@
;;; Copyright © 2012, 2013, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
-;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
;;;
@@ -252,6 +252,9 @@ package definition."
(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)
,guix-package))))
(define (build-system-modules)
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 0b326e1049..c6cc93fad8 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
+;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -113,7 +114,8 @@ Run IMPORTER with ARGS.\n"))
(pretty-print expr (newline-rewriting-port
(current-output-port))))))
(match (apply (resolve-importer importer) args)
- ((and expr ('package _ ...))
+ ((and expr (or ('package _ ...)
+ ('let _ ...)))
(print expr))
((? list? expressions)
(for-each (lambda (expr)