Commit | Line | Data |
---|---|---|
e1248602 | 1 | ;;; GNU Guix --- Functional package management for GNU |
4ceece45 | 2 | ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022 Ricardo Wurmus <rekado@elephly.net> |
aa692163 | 3 | ;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
db427602 | 4 | ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> |
bea3b177 | 5 | ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> |
b4c677c2 | 6 | ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> |
7229b0e8 | 7 | ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> |
e1248602 RW |
8 | ;;; |
9 | ;;; This file is part of GNU Guix. | |
10 | ;;; | |
11 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
12 | ;;; under the terms of the GNU General Public License as published by | |
13 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
14 | ;;; your option) any later version. | |
15 | ;;; | |
16 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
17 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;;; GNU General Public License for more details. | |
20 | ;;; | |
21 | ;;; You should have received a copy of the GNU General Public License | |
22 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
23 | ||
24 | (define-module (guix import cran) | |
25 | #:use-module (ice-9 match) | |
26 | #:use-module (ice-9 regex) | |
b005c240 | 27 | #:use-module (ice-9 popen) |
2dca8b2d | 28 | #:use-module ((ice-9 rdelim) #:select (read-string read-line)) |
e1248602 | 29 | #:use-module (srfi srfi-1) |
10a1cacb | 30 | #:use-module (srfi srfi-2) |
ad553ec4 | 31 | #:use-module (srfi srfi-11) |
d882c235 | 32 | #:use-module (srfi srfi-26) |
fdbc84b0 | 33 | #:use-module (srfi srfi-34) |
482b8ae2 | 34 | #:use-module (srfi srfi-35) |
ad68f7fa | 35 | #:use-module (ice-9 receive) |
fdbc84b0 | 36 | #:use-module (web uri) |
f9704f17 | 37 | #:use-module (guix memoization) |
e1248602 | 38 | #:use-module (guix http-client) |
219cf509 | 39 | #:use-module (guix diagnostics) |
b4c677c2 | 40 | #:use-module (guix hash) |
219cf509 | 41 | #:use-module (guix i18n) |
e1248602 RW |
42 | #:use-module (guix store) |
43 | #:use-module (guix base32) | |
44 | #:use-module ((guix download) #:select (download-to-store)) | |
45 | #:use-module (guix import utils) | |
b005c240 RW |
46 | #:use-module ((guix build utils) |
47 | #:select (find-files | |
48 | delete-file-recursively | |
49 | with-directory-excursion)) | |
2dca8b2d | 50 | #:use-module (guix utils) |
ad553ec4 | 51 | #:use-module (guix git) |
d0bd632f | 52 | #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri)) |
9e179890 | 53 | #:use-module (guix ui) |
d882c235 LC |
54 | #:use-module (guix upstream) |
55 | #:use-module (guix packages) | |
94e907b9 | 56 | #:use-module (gnu packages) |
5f5e3873 RW |
57 | #:export (%input-style |
58 | ||
59 | cran->guix-package | |
d0bd632f | 60 | bioconductor->guix-package |
ae9e5d66 | 61 | cran-recursive-import |
d0bd632f | 62 | %cran-updater |
ff8c179a | 63 | %bioconductor-updater |
76c0b608 | 64 | %bioconductor-version |
ff8c179a RW |
65 | |
66 | cran-package? | |
67 | bioconductor-package? | |
68 | bioconductor-data-package? | |
cfd1ed84 LC |
69 | bioconductor-experiment-package? |
70 | ||
71 | description->alist | |
72 | description->package)) | |
e1248602 RW |
73 | |
74 | ;;; Commentary: | |
75 | ;;; | |
76 | ;;; Generate a package declaration template for the latest version of an R | |
0f6b9e98 | 77 | ;;; package on CRAN, using the DESCRIPTION file downloaded from |
e1248602 RW |
78 | ;;; cran.r-project.org. |
79 | ;;; | |
80 | ;;; Code: | |
81 | ||
5f5e3873 RW |
82 | (define %input-style |
83 | (make-parameter 'variable)) ; or 'specification | |
84 | ||
afcc6d63 RW |
85 | (define (string->licenses license-string) |
86 | (let ((licenses | |
87 | (map string-trim-both | |
88 | (string-tokenize license-string | |
89 | (char-set-complement (char-set #\|)))))) | |
90 | (string->license licenses))) | |
e1248602 | 91 | |
afcc6d63 RW |
92 | (define string->license |
93 | (let ((prefix identity)) | |
94 | (match-lambda | |
95 | ("AGPL-3" (prefix 'agpl3)) | |
96 | ("AGPL (>= 3)" (prefix 'agpl3+)) | |
97 | ("Artistic-2.0" (prefix 'artistic2.0)) | |
98 | ((or "Apache License 2.0" | |
99 | "Apache License (== 2.0)") | |
100 | (prefix 'asl2.0)) | |
101 | ("BSD_2_clause" (prefix 'bsd-2)) | |
102 | ("BSD_2_clause + file LICENSE" (prefix 'bsd-2)) | |
103 | ("BSD_3_clause" (prefix 'bsd-3)) | |
104 | ("BSD_3_clause + file LICENSE" (prefix 'bsd-3)) | |
105 | ("CC0" (prefix 'cc0)) | |
106 | ("CC BY-SA 4.0" (prefix 'cc-by-sa4.0)) | |
107 | ("CeCILL" (prefix 'cecill)) | |
108 | ((or "GPL" | |
109 | "GNU General Public License") | |
110 | `(list ,(prefix 'gpl2+) ,(prefix 'gpl3+))) | |
111 | ((or "GPL (>= 2)" | |
112 | "GPL (>= 2.0)") | |
113 | (prefix 'gpl2+)) | |
114 | ((or "GPL (> 2)" | |
115 | "GPL (>= 3)" | |
116 | "GPL (>= 3.0)" | |
117 | "GNU General Public License (>= 3)") | |
118 | (prefix 'gpl3+)) | |
119 | ((or "GPL-2" | |
120 | "GNU General Public License version 2") | |
121 | (prefix 'gpl2)) | |
122 | ((or "GPL-3" | |
123 | "GNU General Public License version 3") | |
124 | (prefix 'gpl3)) | |
125 | ((or "GNU Lesser General Public License" | |
126 | "LGPL") | |
127 | (prefix 'lgpl2.0+)) | |
128 | ("LGPL-2" (prefix 'lgpl2.0)) | |
129 | ("LGPL-2.1" (prefix 'lgpl2.1)) | |
130 | ("LGPL-3" (prefix 'lgpl3)) | |
131 | ((or "LGPL (>= 2)" | |
132 | "LGPL (>= 2.0)") | |
133 | (prefix 'lgpl2.0+)) | |
134 | ("LGPL (>= 2.1)" (prefix 'lgpl2.1+)) | |
135 | ("LGPL (>= 3)" (prefix 'lgpl3+)) | |
136 | ("MIT" (prefix 'expat)) | |
137 | ("MIT + file LICENSE" (prefix 'expat)) | |
138 | ("file LICENSE" | |
139 | `(,(prefix 'fsdg-compatible) "file://LICENSE")) | |
140 | ((x) (string->license x)) | |
141 | ((lst ...) `(list ,@(map string->license lst))) | |
142 | (unknown `(,(prefix 'fsdg-compatible) ,unknown))))) | |
0f6b9e98 RW |
143 | |
144 | (define (description->alist description) | |
145 | "Convert a DESCRIPTION string into an alist." | |
146 | (let ((lines (string-split description #\newline)) | |
147 | (parse (lambda (line acc) | |
148 | (if (string-null? line) acc | |
149 | ;; Keys usually start with a capital letter and end with | |
150 | ;; ":". There are some exceptions, unfortunately (such | |
151 | ;; as "biocViews"). There are no blanks in a key. | |
152 | (if (string-match "^[A-Za-z][^ :]+:( |\n|$)" line) | |
153 | ;; New key/value pair | |
154 | (let* ((pos (string-index line #\:)) | |
155 | (key (string-take line pos)) | |
156 | (value (string-drop line (+ 1 pos)))) | |
157 | (cons (cons key | |
158 | (string-trim-both value)) | |
159 | acc)) | |
160 | ;; This is a continuation of the previous pair | |
161 | (match-let ((((key . value) . rest) acc)) | |
162 | (cons (cons key (string-join | |
163 | (list value | |
164 | (string-trim-both line)))) | |
165 | rest))))))) | |
166 | (fold parse '() lines))) | |
167 | ||
e1248602 RW |
168 | (define (format-inputs names) |
169 | "Generate a sorted list of package inputs from a list of package NAMES." | |
170 | (map (lambda (name) | |
5f5e3873 RW |
171 | (case (%input-style) |
172 | ((specification) | |
aa692163 | 173 | `(specification->package ,name)) |
5f5e3873 | 174 | (else |
aa692163 | 175 | (string->symbol name)))) |
e1248602 RW |
176 | (sort names string-ci<?))) |
177 | ||
178 | (define* (maybe-inputs package-inputs #:optional (type 'inputs)) | |
179 | "Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a | |
180 | package definition." | |
181 | (match package-inputs | |
182 | (() | |
183 | '()) | |
184 | ((package-inputs ...) | |
aa692163 | 185 | `((,type (list ,@(format-inputs package-inputs))))))) |
e1248602 | 186 | |
632ea817 | 187 | (define %cran-url "https://cran.r-project.org/web/packages/") |
f14bb29d | 188 | (define %cran-canonical-url "https://cran.r-project.org/package=") |
5713bbf1 | 189 | (define %bioconductor-url "https://bioconductor.org/packages/") |
d0bd632f | 190 | |
556ca8ba | 191 | ;; The latest Bioconductor release is 3.15. Bioconductor packages should be |
d0bd632f | 192 | ;; updated together. |
556ca8ba | 193 | (define %bioconductor-version "3.15") |
84dfdc57 | 194 | |
5063deab | 195 | (define* (bioconductor-packages-list-url #:optional type) |
84dfdc57 | 196 | (string-append "https://bioconductor.org/packages/" |
5063deab RW |
197 | %bioconductor-version |
198 | (match type | |
199 | ('annotation "/data/annotation") | |
200 | ('experiment "/data/experiment") | |
201 | (_ "/bioc")) | |
202 | "/src/contrib/PACKAGES")) | |
84dfdc57 | 203 | |
5063deab | 204 | (define* (bioconductor-packages-list #:optional type) |
84dfdc57 RW |
205 | "Return the latest version of package NAME for the current bioconductor |
206 | release." | |
5063deab | 207 | (let ((url (string->uri (bioconductor-packages-list-url type)))) |
84dfdc57 | 208 | (guard (c ((http-get-error? c) |
219cf509 LC |
209 | (warning (G_ "failed to retrieve list of packages \ |
210 | from ~a: ~a (~a)~%") | |
211 | (uri->string (http-get-error-uri c)) | |
212 | (http-get-error-code c) | |
213 | (http-get-error-reason c)) | |
84dfdc57 RW |
214 | #f)) |
215 | ;; Split the big list on empty lines, then turn each chunk into an | |
216 | ;; alist of attributes. | |
217 | (map (lambda (chunk) | |
218 | (description->alist (string-join chunk "\n"))) | |
af0aefd8 LC |
219 | (let* ((port (http-fetch/cached url)) |
220 | (lines (read-lines port))) | |
221 | (close-port port) | |
222 | (chunk-lines lines)))))) | |
84dfdc57 | 223 | |
5063deab | 224 | (define* (latest-bioconductor-package-version name #:optional type) |
84dfdc57 RW |
225 | "Return the version string corresponding to the latest release of the |
226 | bioconductor package NAME, or #F if the package is unknown." | |
227 | (and=> (find (lambda (meta) | |
228 | (string=? (assoc-ref meta "Package") name)) | |
5063deab | 229 | (bioconductor-packages-list type)) |
84dfdc57 | 230 | (cut assoc-ref <> "Version"))) |
d0bd632f | 231 | |
b3d0617a RW |
232 | ;; Little helper to download URLs only once. |
233 | (define download | |
234 | (memoize | |
8c620a60 | 235 | (lambda* (url #:key method (ref '())) |
ad553ec4 | 236 | (with-store store |
b005c240 RW |
237 | (cond |
238 | ((eq? method 'git) | |
8c620a60 | 239 | (latest-repository-commit store url #:ref ref)) |
b005c240 RW |
240 | ((eq? method 'hg) |
241 | (call-with-temporary-directory | |
242 | (lambda (dir) | |
243 | (unless (zero? (system* "hg" "clone" url dir)) | |
244 | (leave (G_ "~A: hg download failed~%") url)) | |
245 | (with-directory-excursion dir | |
246 | (let* ((port (open-pipe* OPEN_READ "hg" "id" "--id")) | |
247 | (changeset (string-trim-right (read-string port)))) | |
248 | (close-pipe port) | |
249 | (for-each delete-file-recursively | |
250 | (find-files dir "^\\.hg$" #:directories? #t)) | |
251 | (let ((store-directory | |
252 | (add-to-store store (basename url) #t "sha256" dir))) | |
253 | (values store-directory changeset))))))) | |
450e1dd5 LC |
254 | (else |
255 | (match url | |
256 | ((? string?) | |
257 | (download-to-store store url)) | |
258 | ((urls ...) | |
259 | ;; Try all the URLs. A use case where this is useful is when one | |
260 | ;; of the URLs is the /Archive CRAN URL. | |
261 | (any (cut download-to-store store <>) urls))))))))) | |
262 | ||
263 | (define (fetch-description-from-tarball url) | |
264 | "Fetch the tarball at URL, extra its 'DESCRIPTION' file, parse it, and | |
265 | return the resulting alist." | |
266 | (match (download url) | |
267 | (#f #f) | |
268 | (tarball | |
269 | (call-with-temporary-directory | |
270 | (lambda (dir) | |
271 | (parameterize ((current-error-port (%make-void-port "rw+")) | |
272 | (current-output-port (%make-void-port "rw+"))) | |
273 | (and (zero? (system* "tar" "--wildcards" "-x" | |
274 | "--strip-components=1" | |
275 | "-C" dir | |
276 | "-f" tarball "*/DESCRIPTION")) | |
277 | (description->alist | |
278 | (call-with-input-file (string-append dir "/DESCRIPTION") | |
279 | read-string))))))))) | |
280 | ||
281 | (define* (fetch-description repository name #:optional version) | |
0f6b9e98 | 282 | "Return an alist of the contents of the DESCRIPTION file for the R package |
450e1dd5 | 283 | NAME at VERSION in the given REPOSITORY, or #f in case of failure. NAME is |
7c9fcb08 | 284 | case-sensitive." |
27baf509 RW |
285 | (case repository |
286 | ((cran) | |
450e1dd5 LC |
287 | (guard (c ((http-get-error? c) |
288 | (warning (G_ "failed to retrieve package information \ | |
219cf509 | 289 | from ~a: ~a (~a)~%") |
450e1dd5 LC |
290 | (uri->string (http-get-error-uri c)) |
291 | (http-get-error-code c) | |
292 | (http-get-error-reason c)) | |
293 | #f)) | |
294 | ;; When VERSION is true, we have to download the tarball to get at its | |
295 | ;; 'DESCRIPTION' file; only the latest one is directly accessible over | |
296 | ;; HTTP. | |
297 | (if version | |
298 | (let ((urls (list (string-append "mirror://cran/src/contrib/" | |
299 | name "_" version ".tar.gz") | |
300 | (string-append "mirror://cran/src/contrib/Archive/" | |
301 | name "/" | |
302 | name "_" version ".tar.gz")))) | |
303 | (fetch-description-from-tarball urls)) | |
304 | (let* ((url (string-append %cran-url name "/DESCRIPTION")) | |
305 | (port (http-fetch url)) | |
306 | (result (description->alist (read-string port)))) | |
307 | (close-port port) | |
308 | result)))) | |
27baf509 RW |
309 | ((bioconductor) |
310 | ;; Currently, the bioconductor project does not offer a way to access a | |
311 | ;; package's DESCRIPTION file over HTTP, so we determine the version, | |
312 | ;; download the source tarball, and then extract the DESCRIPTION file. | |
5063deab RW |
313 | (and-let* ((type (or |
314 | (and (latest-bioconductor-package-version name) #t) | |
315 | (and (latest-bioconductor-package-version name 'annotation) 'annotation) | |
316 | (and (latest-bioconductor-package-version name 'experiment) 'experiment))) | |
450e1dd5 | 317 | ;; TODO: Honor VERSION. |
5063deab RW |
318 | (version (latest-bioconductor-package-version name type)) |
319 | (url (car (bioconductor-uri name version type))) | |
450e1dd5 LC |
320 | (meta (fetch-description-from-tarball url))) |
321 | (if (boolean? type) | |
322 | meta | |
323 | (cons `(bioconductor-type . ,type) meta)))) | |
ad553ec4 | 324 | ((git) |
8786fec4 RW |
325 | (and (string-prefix? "http" name) |
326 | ;; Download the git repository at "NAME" | |
327 | (call-with-values | |
b005c240 | 328 | (lambda () (download name #:method 'git)) |
8786fec4 RW |
329 | (lambda (dir commit) |
330 | (and=> (description->alist (with-input-from-file | |
331 | (string-append dir "/DESCRIPTION") read-string)) | |
332 | (lambda (meta) | |
333 | (cons* `(git . ,name) | |
334 | `(git-commit . ,commit) | |
b005c240 RW |
335 | meta))))))) |
336 | ((hg) | |
337 | (and (string-prefix? "http" name) | |
338 | ;; Download the mercurial repository at "NAME" | |
339 | (call-with-values | |
340 | (lambda () (download name #:method 'hg)) | |
341 | (lambda (dir changeset) | |
342 | (and=> (description->alist (with-input-from-file | |
343 | (string-append dir "/DESCRIPTION") read-string)) | |
344 | (lambda (meta) | |
345 | (cons* `(hg . ,name) | |
346 | `(hg-changeset . ,changeset) | |
8786fec4 | 347 | meta))))))))) |
0f6b9e98 RW |
348 | |
349 | (define (listify meta field) | |
350 | "Look up FIELD in the alist META. If FIELD contains a comma-separated | |
351 | string, turn it into a list and strip off parenthetic expressions. Return the | |
352 | empty list when the FIELD cannot be found." | |
353 | (let ((value (assoc-ref meta field))) | |
354 | (if (not value) | |
355 | '() | |
356 | ;; Strip off parentheses | |
357 | (let ((items (string-split (regexp-substitute/global | |
358 | #f "( *\\([^\\)]+\\)) *" | |
359 | value 'pre 'post) | |
360 | #\,))) | |
be036757 RW |
361 | (remove (lambda (item) |
362 | (or (string-null? item) | |
363 | ;; When there is whitespace inside of items it is | |
364 | ;; probably because this was not an actual list to | |
365 | ;; begin with. | |
366 | (string-any char-set:whitespace item))) | |
0f6b9e98 RW |
367 | (map string-trim-both items)))))) |
368 | ||
cfd1ed84 LC |
369 | ;; Trick Guile 3 so that it keeps the 'listify' binding accessible *and* |
370 | ;; private even though this module is declarative. | |
371 | (set! listify listify) | |
372 | ||
b26abe4f | 373 | (define default-r-packages |
aeb64f3c | 374 | (list "base" |
b26abe4f | 375 | "compiler" |
daf9fa94 | 376 | "datasets" |
b26abe4f RW |
377 | "grDevices" |
378 | "graphics" | |
379 | "grid" | |
b26abe4f | 380 | "methods" |
b26abe4f | 381 | "parallel" |
b26abe4f RW |
382 | "splines" |
383 | "stats" | |
384 | "stats4" | |
b26abe4f RW |
385 | "tcltk" |
386 | "tools" | |
387 | "translations" | |
388 | "utils")) | |
389 | ||
e96619ba RW |
390 | ;; The field for system dependencies is often abused to specify non-package |
391 | ;; dependencies (such as c++11). This list is used to ignore them. | |
392 | (define invalid-packages | |
e8a968f8 RW |
393 | (list "c++11" |
394 | "c++14" | |
e8a968f8 | 395 | "getopt::long" |
9d86052c RW |
396 | "linux" |
397 | "none" | |
398 | "windows" | |
399 | "xcode" | |
e8a968f8 | 400 | "xquartz")) |
e96619ba | 401 | |
e761ed73 RW |
402 | (define (transform-sysname sysname) |
403 | "Return a Guix package name for the common package name SYSNAME." | |
404 | (match sysname | |
405 | ("java" "openjdk") | |
406 | ("fftw3" "fftw") | |
407 | ("tcl/tk" "tcl") | |
408 | (_ sysname))) | |
409 | ||
ae9e5d66 | 410 | (define cran-guix-name (cut guix-name "r-" <>)) |
bfa0c752 | 411 | |
ad553ec4 | 412 | (define (tarball-needs-fortran? tarball) |
2dca8b2d RW |
413 | "Check if the TARBALL contains Fortran source files." |
414 | (define (check pattern) | |
415 | (parameterize ((current-error-port (%make-void-port "rw+")) | |
416 | (current-output-port (%make-void-port "rw+"))) | |
417 | (zero? (system* "tar" "--wildcards" "--list" pattern "-f" tarball)))) | |
418 | (or (check "*.f90") | |
419 | (check "*.f95") | |
420 | (check "*.f"))) | |
421 | ||
ad553ec4 RW |
422 | (define (directory-needs-fortran? dir) |
423 | "Check if the directory DIR contains Fortran source files." | |
35814292 | 424 | (match (find-files dir "\\.f(90|95)$") |
ad553ec4 RW |
425 | (() #f) |
426 | (_ #t))) | |
427 | ||
428 | (define (needs-fortran? thing tarball?) | |
429 | "Check if the THING contains Fortran source files." | |
430 | (if tarball? | |
431 | (tarball-needs-fortran? thing) | |
432 | (directory-needs-fortran? thing))) | |
433 | ||
434 | (define (files-match-pattern? directory regexp . file-patterns) | |
435 | "Return #T if any of the files matching FILE-PATTERNS in the DIRECTORY match | |
436 | the given REGEXP." | |
437 | (let ((pattern (make-regexp regexp))) | |
438 | (any (lambda (file) | |
439 | (call-with-input-file file | |
440 | (lambda (port) | |
441 | (let loop () | |
442 | (let ((line (read-line port))) | |
443 | (cond | |
444 | ((eof-object? line) #f) | |
445 | ((regexp-exec pattern line) #t) | |
446 | (else (loop)))))))) | |
447 | (apply find-files directory file-patterns)))) | |
448 | ||
a0f43208 RW |
449 | (define (tarball-files-match-pattern? tarball regexp . file-patterns) |
450 | "Return #T if any of the files represented by FILE-PATTERNS in the TARBALL | |
451 | match the given REGEXP." | |
2dca8b2d RW |
452 | (call-with-temporary-directory |
453 | (lambda (dir) | |
ad553ec4 RW |
454 | (parameterize ((current-error-port (%make-void-port "rw+"))) |
455 | (apply system* "tar" | |
456 | "xf" tarball "-C" dir | |
457 | `("--wildcards" ,@file-patterns))) | |
458 | (files-match-pattern? dir regexp)))) | |
459 | ||
460 | (define (directory-needs-zlib? dir) | |
461 | "Return #T if any of the Makevars files in the src directory DIR contain a | |
462 | zlib linker flag." | |
463 | (files-match-pattern? dir "-lz" "(Makevars.*|configure.*)")) | |
464 | ||
465 | (define (tarball-needs-zlib? tarball) | |
a0f43208 RW |
466 | "Return #T if any of the Makevars files in the src directory of the TARBALL |
467 | contain a zlib linker flag." | |
468 | (tarball-files-match-pattern? | |
469 | tarball "-lz" | |
470 | "*/src/Makevars*" "*/src/configure*" "*/configure*")) | |
471 | ||
ad553ec4 RW |
472 | (define (needs-zlib? thing tarball?) |
473 | "Check if the THING contains files indicating a dependency on zlib." | |
474 | (if tarball? | |
475 | (tarball-needs-zlib? thing) | |
476 | (directory-needs-zlib? thing))) | |
477 | ||
478 | (define (directory-needs-pkg-config? dir) | |
479 | "Return #T if any of the Makevars files in the src directory DIR reference | |
480 | the pkg-config tool." | |
481 | (files-match-pattern? dir "pkg-config" | |
482 | "(Makevars.*|configure.*)")) | |
483 | ||
484 | (define (tarball-needs-pkg-config? tarball) | |
17a69cf6 RW |
485 | "Return #T if any of the Makevars files in the src directory of the TARBALL |
486 | reference the pkg-config tool." | |
487 | (tarball-files-match-pattern? | |
488 | tarball "pkg-config" | |
489 | "*/src/Makevars*" "*/src/configure*" "*/configure*")) | |
490 | ||
ad553ec4 RW |
491 | (define (needs-pkg-config? thing tarball?) |
492 | "Check if the THING contains files indicating a dependency on pkg-config." | |
493 | (if tarball? | |
494 | (tarball-needs-pkg-config? thing) | |
495 | (directory-needs-pkg-config? thing))) | |
496 | ||
c363722e RW |
497 | (define (needs-knitr? meta) |
498 | (member "knitr" (listify meta "VignetteBuilder"))) | |
499 | ||
d0bd632f RW |
500 | (define (description->package repository meta) |
501 | "Return the `package' s-expression for an R package published on REPOSITORY | |
502 | from the alist META, which was derived from the R package's DESCRIPTION file." | |
d0bd632f RW |
503 | (let* ((base-url (case repository |
504 | ((cran) %cran-url) | |
ad553ec4 | 505 | ((bioconductor) %bioconductor-url) |
b005c240 RW |
506 | ((git) #f) |
507 | ((hg) #f))) | |
f14bb29d LDB |
508 | (canonical-url-base (case repository |
509 | ((cran) %cran-canonical-url) | |
510 | ((bioconductor) %bioconductor-url) | |
511 | ((git) #f))) | |
d0bd632f RW |
512 | (uri-helper (case repository |
513 | ((cran) cran-uri) | |
ad553ec4 | 514 | ((bioconductor) bioconductor-uri) |
b005c240 RW |
515 | ((git) #f) |
516 | ((hg) #f))) | |
d0bd632f | 517 | (name (assoc-ref meta "Package")) |
0f6b9e98 RW |
518 | (synopsis (assoc-ref meta "Title")) |
519 | (version (assoc-ref meta "Version")) | |
afcc6d63 | 520 | (license (string->licenses (assoc-ref meta "License"))) |
0f6b9e98 | 521 | ;; Some packages have multiple home pages. Some have none. |
ad553ec4 RW |
522 | (home-page (case repository |
523 | ((git) (assoc-ref meta 'git)) | |
b005c240 | 524 | ((hg) (assoc-ref meta 'hg)) |
ad553ec4 RW |
525 | (else (match (listify meta "URL") |
526 | ((url rest ...) url) | |
f14bb29d | 527 | (_ (string-append canonical-url-base name)))))) |
ad553ec4 RW |
528 | (source-url (case repository |
529 | ((git) (assoc-ref meta 'git)) | |
b005c240 | 530 | ((hg) (assoc-ref meta 'hg)) |
ad553ec4 RW |
531 | (else |
532 | (match (apply uri-helper name version | |
533 | (case repository | |
534 | ((bioconductor) | |
535 | (list (assoc-ref meta 'bioconductor-type))) | |
536 | (else '()))) | |
450e1dd5 | 537 | ((urls ...) urls) |
ad553ec4 RW |
538 | ((? string? url) url) |
539 | (_ #f))))) | |
4ceece45 RW |
540 | (git? (if (assoc-ref meta 'git) #true #false)) |
541 | (hg? (if (assoc-ref meta 'hg) #true #false)) | |
b005c240 RW |
542 | (source (download source-url #:method (cond |
543 | (git? 'git) | |
544 | (hg? 'hg) | |
545 | (else #f)))) | |
2dca8b2d | 546 | (sysdepends (append |
b005c240 | 547 | (if (needs-zlib? source (not (or git? hg?))) '("zlib") '()) |
531940d3 RW |
548 | (filter (lambda (name) |
549 | (not (member name invalid-packages))) | |
550 | (map string-downcase (listify meta "SystemRequirements"))))) | |
b26abe4f | 551 | (propagate (filter (lambda (name) |
e96619ba RW |
552 | (not (member name (append default-r-packages |
553 | invalid-packages)))) | |
b26abe4f RW |
554 | (lset-union equal? |
555 | (listify meta "Imports") | |
556 | (listify meta "LinkingTo") | |
557 | (delete "R" | |
ad553ec4 RW |
558 | (listify meta "Depends"))))) |
559 | (package | |
560 | `(package | |
561 | (name ,(cran-guix-name name)) | |
ec92bcaa RW |
562 | (version ,(cond |
563 | (git? | |
564 | `(git-version ,version revision commit)) | |
565 | (hg? | |
566 | `(string-append ,version "-" revision "." changeset)) | |
567 | (else version))) | |
ad553ec4 | 568 | (source (origin |
b005c240 RW |
569 | (method ,(cond |
570 | (git? 'git-fetch) | |
571 | (hg? 'hg-fetch) | |
572 | (else 'url-fetch))) | |
ec92bcaa RW |
573 | (uri ,(cond |
574 | (git? | |
575 | `(git-reference | |
576 | (url ,(assoc-ref meta 'git)) | |
577 | (commit commit))) | |
578 | (hg? | |
579 | `(hg-reference | |
580 | (url ,(assoc-ref meta 'hg)) | |
581 | (changeset changeset))) | |
582 | (else | |
583 | `(,(procedure-name uri-helper) ,name version | |
584 | ,@(or (and=> (assoc-ref meta 'bioconductor-type) | |
585 | (lambda (type) | |
586 | (list (list 'quote type)))) | |
587 | '()))))) | |
b005c240 RW |
588 | ,@(cond |
589 | (git? | |
590 | '((file-name (git-file-name name version)))) | |
591 | (hg? | |
592 | '((file-name (string-append name "-" version "-checkout")))) | |
593 | (else '())) | |
ad553ec4 RW |
594 | (sha256 |
595 | (base32 | |
596 | ,(bytevector->nix-base32-string | |
b4c677c2 | 597 | (file-hash* source #:recursive? (or git? hg?))))))) |
b005c240 | 598 | ,@(if (not (and git? hg? |
ad553ec4 RW |
599 | (equal? (string-append "r-" name) |
600 | (cran-guix-name name)))) | |
601 | `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) | |
602 | '()) | |
603 | (build-system r-build-system) | |
e761ed73 | 604 | ,@(maybe-inputs (map transform-sysname sysdepends)) |
ad553ec4 RW |
605 | ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) |
606 | ,@(maybe-inputs | |
b005c240 | 607 | `(,@(if (needs-fortran? source (not (or git? hg?))) |
ad553ec4 | 608 | '("gfortran") '()) |
b005c240 | 609 | ,@(if (needs-pkg-config? source (not (or git? hg?))) |
c363722e RW |
610 | '("pkg-config") '()) |
611 | ,@(if (needs-knitr? meta) | |
612 | '("r-knitr") '())) | |
ad553ec4 RW |
613 | 'native-inputs) |
614 | (home-page ,(if (string-null? home-page) | |
615 | (string-append base-url name) | |
616 | home-page)) | |
19ea75aa | 617 | (synopsis ,(beautify-synopsis synopsis)) |
ad553ec4 RW |
618 | (description ,(beautify-description (or (assoc-ref meta "Description") |
619 | ""))) | |
620 | (license ,license)))) | |
ad68f7fa | 621 | (values |
ec92bcaa RW |
622 | (cond |
623 | (git? | |
624 | `(let ((commit ,(assoc-ref meta 'git-commit)) | |
625 | (revision "1")) | |
626 | ,package)) | |
627 | (hg? | |
628 | `(let ((changeset ,(assoc-ref meta 'hg-changeset)) | |
629 | (revision "1")) | |
630 | ,package)) | |
631 | (else package)) | |
ad68f7fa | 632 | propagate))) |
e1248602 | 633 | |
94e907b9 RW |
634 | (define cran->guix-package |
635 | (memoize | |
bea3b177 | 636 | (lambda* (package-name #:key (repo 'cran) version) |
94e907b9 | 637 | "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' |
d0bd632f | 638 | s-expression corresponding to that package, or #f on failure." |
450e1dd5 | 639 | (let ((description (fetch-description repo package-name version))) |
c7358ac4 RW |
640 | (if description |
641 | (description->package repo description) | |
642 | (case repo | |
643 | ((git) | |
644 | ;; Retry import from Bioconductor | |
a689c85a | 645 | (cran->guix-package package-name #:repo 'bioconductor)) |
b005c240 RW |
646 | ((hg) |
647 | ;; Retry import from Bioconductor | |
a689c85a | 648 | (cran->guix-package package-name #:repo 'bioconductor)) |
c7358ac4 RW |
649 | ((bioconductor) |
650 | ;; Retry import from CRAN | |
a689c85a | 651 | (cran->guix-package package-name #:repo 'cran)) |
482b8ae2 | 652 | (else |
7229b0e8 | 653 | (values #f '())))))))) |
94e907b9 | 654 | |
450e1dd5 | 655 | (define* (cran-recursive-import package-name #:key (repo 'cran) version) |
bea3b177 | 656 | (recursive-import package-name |
450e1dd5 | 657 | #:version version |
bea3b177 | 658 | #:repo repo |
ae9e5d66 OP |
659 | #:repo->guix-package cran->guix-package |
660 | #:guix-name cran-guix-name)) | |
d882c235 LC |
661 | |
662 | \f | |
663 | ;;; | |
664 | ;;; Updater. | |
665 | ;;; | |
666 | ||
d1c11608 RW |
667 | (define (package->upstream-name package) |
668 | "Return the upstream name of the PACKAGE." | |
669 | (let* ((properties (package-properties package)) | |
670 | (upstream-name (and=> properties | |
671 | (cut assoc-ref <> 'upstream-name)))) | |
672 | (if upstream-name | |
673 | upstream-name | |
674 | (match (package-source package) | |
675 | ((? origin? origin) | |
676 | (match (origin-uri origin) | |
b98293eb | 677 | ((or (? string? url) (url _ ...)) |
d1c11608 RW |
678 | (let ((end (string-rindex url #\_)) |
679 | (start (string-rindex url #\/))) | |
680 | ;; The URL ends on | |
681 | ;; (string-append "/" name "_" version ".tar.gz") | |
db427602 | 682 | (and start end (substring url (+ start 1) end)))) |
d1c11608 RW |
683 | (_ #f))) |
684 | (_ #f))))) | |
685 | ||
91e05559 RW |
686 | (define (latest-cran-release pkg) |
687 | "Return an <upstream-source> for the latest release of the package PKG." | |
0f6b9e98 | 688 | |
d1c11608 | 689 | (define upstream-name |
91e05559 | 690 | (package->upstream-name pkg)) |
0f6b9e98 RW |
691 | |
692 | (define meta | |
7c9fcb08 | 693 | (fetch-description 'cran upstream-name)) |
0f6b9e98 RW |
694 | |
695 | (and meta | |
696 | (let ((version (assoc-ref meta "Version"))) | |
697 | ;; CRAN does not provide signatures. | |
698 | (upstream-source | |
91e05559 | 699 | (package (package-name pkg)) |
0f6b9e98 | 700 | (version version) |
91e05559 RW |
701 | (urls (cran-uri upstream-name version)) |
702 | (input-changes | |
703 | (changed-inputs pkg | |
704 | (description->package 'cran meta))))))) | |
d882c235 | 705 | |
91e05559 RW |
706 | (define (latest-bioconductor-release pkg) |
707 | "Return an <upstream-source> for the latest release of the package PKG." | |
d0bd632f RW |
708 | |
709 | (define upstream-name | |
91e05559 | 710 | (package->upstream-name pkg)) |
d0bd632f | 711 | |
27baf509 RW |
712 | (define version |
713 | (latest-bioconductor-package-version upstream-name)) | |
d0bd632f | 714 | |
27baf509 RW |
715 | (and version |
716 | ;; Bioconductor does not provide signatures. | |
717 | (upstream-source | |
91e05559 | 718 | (package (package-name pkg)) |
27baf509 | 719 | (version version) |
91e05559 RW |
720 | (urls (bioconductor-uri upstream-name version)) |
721 | (input-changes | |
722 | (changed-inputs | |
723 | pkg | |
a689c85a | 724 | (cran->guix-package upstream-name #:repo 'bioconductor)))))) |
d0bd632f | 725 | |
d882c235 LC |
726 | (define (cran-package? package) |
727 | "Return true if PACKAGE is an R package from CRAN." | |
d0bd632f | 728 | (and (string-prefix? "r-" (package-name package)) |
db427602 MO |
729 | ;; Check if the upstream name can be extracted from package uri. |
730 | (package->upstream-name package) | |
731 | ;; Check if package uri(s) are prefixed by "mirror://cran". | |
00290e73 | 732 | ((url-predicate (cut string-prefix? "mirror://cran" <>)) package))) |
d0bd632f RW |
733 | |
734 | (define (bioconductor-package? package) | |
735 | "Return true if PACKAGE is an R package from Bioconductor." | |
5ae63362 | 736 | (let ((predicate (lambda (uri) |
5713bbf1 | 737 | (and (string-prefix? "https://bioconductor.org" uri) |
7c9fcb08 RW |
738 | ;; Data packages are neither listed in SVN nor on |
739 | ;; the Github mirror, so we have to exclude them | |
740 | ;; from the set of bioconductor packages that can be | |
741 | ;; updated automatically. | |
c9ffa91f RW |
742 | (not (string-contains uri "/data/annotation/")) |
743 | ;; Experiment packages are in a separate repository. | |
744 | (not (string-contains uri "/data/experiment/")))))) | |
5ae63362 | 745 | (and (string-prefix? "r-" (package-name package)) |
00290e73 | 746 | ((url-predicate predicate) package)))) |
5ae63362 RW |
747 | |
748 | (define (bioconductor-data-package? package) | |
749 | "Return true if PACKAGE is an R data package from Bioconductor." | |
750 | (let ((predicate (lambda (uri) | |
5713bbf1 | 751 | (and (string-prefix? "https://bioconductor.org" uri) |
5ae63362 RW |
752 | (string-contains uri "/data/annotation/"))))) |
753 | (and (string-prefix? "r-" (package-name package)) | |
00290e73 | 754 | ((url-predicate predicate) package)))) |
d882c235 | 755 | |
daaa270e RW |
756 | (define (bioconductor-experiment-package? package) |
757 | "Return true if PACKAGE is an R experiment package from Bioconductor." | |
758 | (let ((predicate (lambda (uri) | |
5713bbf1 | 759 | (and (string-prefix? "https://bioconductor.org" uri) |
daaa270e RW |
760 | (string-contains uri "/data/experiment/"))))) |
761 | (and (string-prefix? "r-" (package-name package)) | |
00290e73 | 762 | ((url-predicate predicate) package)))) |
daaa270e | 763 | |
d882c235 | 764 | (define %cran-updater |
7e6b490d AK |
765 | (upstream-updater |
766 | (name 'cran) | |
767 | (description "Updater for CRAN packages") | |
768 | (pred cran-package?) | |
d0bd632f RW |
769 | (latest latest-cran-release))) |
770 | ||
771 | (define %bioconductor-updater | |
772 | (upstream-updater | |
773 | (name 'bioconductor) | |
774 | (description "Updater for Bioconductor packages") | |
775 | (pred bioconductor-package?) | |
776 | (latest latest-bioconductor-release))) | |
d882c235 LC |
777 | |
778 | ;;; cran.scm ends here |