diff options
author | Ludovic Courtès <ludo@gnu.org> | 2015-09-13 21:28:01 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2015-09-13 21:28:01 +0200 |
commit | 75710da66710cef1d32053cd8f350d13057d02a7 (patch) | |
tree | abef6a326c741b1eb18db866b2f2bacee3e5fc51 /guix | |
parent | ab20c2cc33063ce783515d8ae7899ec7e2ca6f96 (diff) | |
parent | 610075f7c94c80b8321887b7ccf8bb1a7edd2b8e (diff) |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/r.scm | 134 | ||||
-rw-r--r-- | guix/build/download.scm | 79 | ||||
-rw-r--r-- | guix/build/emacs-build-system.scm | 2 | ||||
-rw-r--r-- | guix/build/r-build-system.scm | 112 | ||||
-rw-r--r-- | guix/build/ruby-build-system.scm | 16 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 24 | ||||
-rw-r--r-- | guix/download.scm | 29 | ||||
-rw-r--r-- | guix/git-download.scm | 4 | ||||
-rw-r--r-- | guix/http-client.scm | 7 | ||||
-rw-r--r-- | guix/import/cran.scm | 188 | ||||
-rw-r--r-- | guix/import/gem.scm | 3 | ||||
-rw-r--r-- | guix/licenses.scm | 20 | ||||
-rw-r--r-- | guix/monads.scm | 8 | ||||
-rw-r--r-- | guix/packages.scm | 15 | ||||
-rw-r--r-- | guix/scripts/build.scm | 49 | ||||
-rw-r--r-- | guix/scripts/graph.scm | 27 | ||||
-rw-r--r-- | guix/scripts/import.scm | 2 | ||||
-rw-r--r-- | guix/scripts/import/cran.scm | 92 | ||||
-rw-r--r-- | guix/scripts/lint.scm | 28 | ||||
-rw-r--r-- | guix/scripts/publish.scm | 23 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 2 | ||||
-rw-r--r-- | guix/scripts/refresh.scm | 2 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 2 | ||||
-rw-r--r-- | guix/ui.scm | 111 |
24 files changed, 866 insertions, 113 deletions
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm new file mode 100644 index 0000000000..4daec5eb66 --- /dev/null +++ b/guix/build-system/r.scm @@ -0,0 +1,134 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; 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 build-system r) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (%r-build-system-modules + r-build + r-build-system)) + +;; Commentary: +;; +;; Standard build procedure for R packages. +;; +;; Code: + +(define %r-build-system-modules + ;; Build-side modules imported by default. + `((guix build r-build-system) + ,@%gnu-build-system-modules)) + +(define (default-r) + "Return the default R package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((r-mod (resolve-interface '(gnu packages statistics)))) + (module-ref r-mod 'r))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (r (default-r)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("r" ,r) + ,@native-inputs)) + (outputs outputs) + (build r-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (r-build store name inputs + #:key + (tests? #t) + (test-target "tests") + (configure-flags ''()) + (phases '(@ (guix build r-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %r-build-system-modules) + (modules '((guix build r-build-system) + (guix build utils)))) + "Build SOURCE with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (r-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:configure-flags ,configure-flags + #:system ,system + #:tests? ,tests? + #:test-target ,test-target + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define r-build-system + (build-system + (name 'r) + (description "The standard R build system") + (lower lower))) + +;;; r.scm ends here diff --git a/guix/build/download.scm b/guix/build/download.scm index ae59b0109c..6e85174bc9 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -54,17 +55,46 @@ object, as an inexact number." (+ (time-second duration) (/ (time-nanosecond duration) 1e9))) -(define (throughput->string throughput) - "Given THROUGHPUT, measured in bytes per second, return a string -representing it in a human-readable way." - (if (> throughput 3e6) - (format #f "~,2f MiB/s" (/ throughput (expt 2. 20))) - (format #f "~,0f KiB/s" (/ throughput 1024.0)))) +(define (seconds->string duration) + "Given DURATION in seconds, return a string representing it in 'hh:mm:ss' +format." + (if (not (number? duration)) + "00:00:00" + (let* ((total-seconds (inexact->exact (round duration))) + (extra-seconds (modulo total-seconds 3600)) + (hours (quotient total-seconds 3600)) + (mins (quotient extra-seconds 60)) + (secs (modulo extra-seconds 60))) + (format #f "~2,'0d:~2,'0d:~2,'0d" hours mins secs)))) + +(define (byte-count->string size) + "Given SIZE in bytes, return a string representing it in a human-readable +way." + (let ((KiB 1024.) + (MiB (expt 1024. 2)) + (GiB (expt 1024. 3)) + (TiB (expt 1024. 4))) + (cond + ((< size KiB) (format #f "~dB" (inexact->exact size))) + ((< size MiB) (format #f "~dKiB" (inexact->exact (round (/ size KiB))))) + ((< size GiB) (format #f "~,1fMiB" (/ size MiB))) + ((< size TiB) (format #f "~,2fGiB" (/ size GiB))) + (else (format #f "~,3fTiB" (/ size TiB)))))) + +(define* (progress-bar % #:optional (bar-width 20)) + "Return % as a string representing an ASCII-art progress bar. The total +width of the bar is BAR-WIDTH." + (let* ((fraction (/ % 100)) + (filled (inexact->exact (floor (* fraction bar-width)))) + (empty (- bar-width filled))) + (format #f "[~a~a]" + (make-string filled #\#) + (make-string empty #\space)))) (define* (progress-proc file size #:optional (log-port (current-output-port))) - "Return a procedure to show the progress of FILE's download, which is -SIZE byte long. The returned procedure is suitable for use as an -argument to `dump-port'. The progress report is written to LOG-PORT." + "Return a procedure to show the progress of FILE's download, which is SIZE +bytes long. The returned procedure is suitable for use as an argument to +`dump-port'. The progress report is written to LOG-PORT." ;; XXX: Because of <http://bugs.gnu.org/19939> this procedure is often not ;; called as frequently as we'd like too; this is especially bad with Nginx ;; on hydra.gnu.org, which returns whole nars as a single chunk. @@ -83,14 +113,24 @@ argument to `dump-port'. The progress report is written to LOG-PORT." (if (number? size) (lambda (transferred cont) (with-elapsed-time elapsed - (let ((% (* 100.0 (/ transferred size))) - (throughput (if elapsed - (/ transferred elapsed) - 0))) + (let* ((% (* 100.0 (/ transferred size))) + (throughput (if elapsed + (/ transferred elapsed) + 0)) + (left (format #f " ~a ~a" + (basename file) + (byte-count->string size))) + (right (format #f "~a/s ~a ~a~6,1f%" + (byte-count->string throughput) + (seconds->string elapsed) + (progress-bar %) %)) + ;; TODO: Make this adapt to the actual terminal width. + (cols 80) + (num-spaces (max 1 (- cols (+ (string-length left) + (string-length right))))) + (gap (make-string num-spaces #\space))) + (format log-port "~a~a~a" left gap right) (display #\cr log-port) - (format log-port "~a\t~5,1f% of ~,1f KiB (~a)" - file % (/ size 1024.0) - (throughput->string throughput)) (flush-output-port log-port) (cont)))) (lambda (transferred cont) @@ -99,9 +139,10 @@ argument to `dump-port'. The progress report is written to LOG-PORT." (/ transferred elapsed) 0))) (display #\cr log-port) - (format log-port "~a\t~6,1f KiB transferred (~a)" - file (/ transferred 1024.0) - (throughput->string throughput)) + (format log-port "~a\t~a transferred (~a/s)" + file + (byte-count->string transferred) + (byte-count->string throughput)) (flush-output-port log-port) (cont)))))))) diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index aacb5a4186..cb5bde3191 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -84,7 +84,7 @@ store in '.el' files." (elpa-name-ver (store-directory->elpa-name-version out)) (el-dir (string-append out %install-suffix "/" elpa-name-ver)) (name-ver (strip-store-file-name out)) - (info-dir (string-append out "/share/info/" name-ver)) + (info-dir (string-append out "/share/info/")) (info-files (find-files el-dir "\\.info$"))) (unless (null? info-files) (mkdir-p info-dir) diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm new file mode 100644 index 0000000000..3fc13eb835 --- /dev/null +++ b/guix/build/r-build-system.scm @@ -0,0 +1,112 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; 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 build r-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (ice-9 popen) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + r-build)) + +;; Commentary: +;; +;; Builder-side code of the standard build procedure for R packages. +;; +;; Code: + +(define (invoke-r command params) + (zero? (apply system* "R" "CMD" command params))) + +(define (pipe-to-r command params) + (let ((port (apply open-pipe* OPEN_WRITE "R" params))) + (display command port) + (zero? (status:exit-val (close-pipe port))))) + +(define (generate-site-path inputs) + (string-join (map (match-lambda + ((_ . path) + (string-append path "/site-library"))) + ;; Restrict to inputs beginning with "r-". + (filter (match-lambda + ((name . _) + (string-prefix? "r-" name))) + inputs)) + ":")) + +(define* (check #:key test-target inputs outputs tests? #:allow-other-keys) + "Run the test suite of a given R package." + (let* ((libdir (string-append (assoc-ref outputs "out") "/site-library/")) + + ;; R package names are case-sensitive and cannot be derived from the + ;; Guix package name. The exact package name is required as an + ;; argument to ‘tools::testInstalledPackage’, which runs the tests + ;; for a package given its name and the path to the “library” (a + ;; location for a collection of R packages) containing it. + + ;; Since there can only be one R package in any collection (= + ;; “library”), the name of the only directory in the collection path + ;; is the original name of the R package. + (pkg-name (car (scandir libdir (negate (cut member <> '("." "..")))))) + (testdir (string-append libdir pkg-name "/" test-target)) + (site-path (string-append libdir ":" (generate-site-path inputs)))) + (if (and tests? (file-exists? testdir)) + (begin + (setenv "R_LIBS_SITE" site-path) + (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", " + "lib.loc = \"" libdir "\")") + '("--no-save" "--slave"))) + #t))) + +(define* (install #:key outputs inputs (configure-flags '()) + #:allow-other-keys) + "Install a given R package." + (let* ((out (assoc-ref outputs "out")) + (site-library (string-append out "/site-library/")) + (params (append configure-flags + (list "--install-tests" + (string-append "--library=" site-library) + "."))) + (site-path (string-append site-library ":" + (generate-site-path inputs)))) + ;; If dependencies cannot be found at install time, R will refuse to + ;; install the package. + (setenv "R_LIBS_SITE" site-path) + ;; Some R packages contain a configure script for which the CONFIG_SHELL + ;; variable should be set. + (setenv "CONFIG_SHELL" (which "bash")) + (mkdir-p site-library) + (invoke-r "INSTALL" params))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (delete 'configure) + (delete 'build) + (delete 'check) ; tests must be run after installation + (replace 'install install) + (add-after 'install 'check check))) + +(define* (r-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given R package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; r-build-system.scm ends here diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 90fab92f6a..4184ccc9ac 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -44,12 +44,16 @@ directory." (define* (unpack #:key source #:allow-other-keys) "Unpack the gem SOURCE and enter the resulting directory." (and (zero? (system* "gem" "unpack" source)) - (begin - ;; The unpacked gem directory is named the same as the archive, sans - ;; the ".gem" extension. - (chdir (match:substring (string-match "^(.*)\\.gem$" - (basename source)) - 1)) + ;; The unpacked gem directory is named the same as the archive, sans + ;; the ".gem" extension. It is renamed to simply "gem" in an effort to + ;; keep file names shorter to avoid UNIX-domain socket file names and + ;; shebangs that exceed the system's fixed maximum length when running + ;; test suites. + (let ((dir (match:substring (string-match "^(.*)\\.gem$" + (basename source)) + 1))) + (rename-file dir "gem") + (chdir "gem") #t))) (define* (build #:key source #:allow-other-keys) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index fc801a5e9d..2c2fbde0a3 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -50,6 +50,8 @@ mkdtemp! pivot-root + CLONE_CHILD_CLEARTID + CLONE_CHILD_SETTID CLONE_NEWNS CLONE_NEWUTS CLONE_NEWIPC @@ -303,12 +305,14 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." (pointer->string result))))) ;; Linux clone flags, from linux/sched.h -(define CLONE_NEWNS #x00020000) -(define CLONE_NEWUTS #x04000000) -(define CLONE_NEWIPC #x08000000) -(define CLONE_NEWUSER #x10000000) -(define CLONE_NEWPID #x20000000) -(define CLONE_NEWNET #x40000000) +(define CLONE_CHILD_CLEARTID #x00200000) +(define CLONE_CHILD_SETTID #x01000000) +(define CLONE_NEWNS #x00020000) +(define CLONE_NEWUTS #x04000000) +(define CLONE_NEWIPC #x08000000) +(define CLONE_NEWUSER #x10000000) +(define CLONE_NEWPID #x20000000) +(define CLONE_NEWNET #x40000000) ;; The libc interface to sys_clone is not useful for Scheme programs, so the ;; low-level system call is wrapped instead. @@ -325,7 +329,13 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." "Create a new child process by duplicating the current parent process. Unlike the fork system call, clone accepts FLAGS that specify which resources are shared between the parent and child processes." - (proc syscall-id flags %null-pointer)))) + (let ((ret (proc syscall-id flags %null-pointer)) + (err (errno))) + (if (= ret -1) + (throw 'system-error "clone" "~d: ~A" + (list flags (strerror err)) + (list err)) + ret))))) (define setns ;; Some systems may be using an old (pre-2.14) version of glibc where there diff --git a/guix/download.scm b/guix/download.scm index 6e91607196..42956772f5 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -202,6 +202,12 @@ "http://ftp.fr.debian.org/debian/" "http://ftp.debian.org/debian/")))) +(define %mirror-file + ;; Copy of the list of mirrors to a file. This allows us to keep a single + ;; copy in the store, and computing it here avoids repeated calls to + ;; 'object->string'. + (plain-file "mirrors" (object->string %mirrors))) + (define (gnutls-package) "Return the default GnuTLS package." (let ((module (resolve-interface '(gnu packages tls)))) @@ -210,16 +216,14 @@ (define* (url-fetch url hash-algo hash #:optional name #:key (system (%current-system)) - (guile (default-guile)) - (mirrors %mirrors)) + (guile (default-guile))) "Return a fixed-output derivation that fetches URL (a string, or a list of strings denoting alternate URLs), which is expected to have hash HASH of type HASH-ALGO (a symbol). By default, the file name is the base name of URL; optionally, NAME can specify a different file name. When one of the URL starts with mirror://, then its host part is -interpreted as the name of a mirror scheme, taken from MIRRORS; MIRRORS -must be a list of symbol/URL-list pairs. +interpreted as the name of a mirror scheme, taken from %MIRROR-FILE. Alternately, when URL starts with file://, return the corresponding file name in the store." @@ -239,10 +243,6 @@ in the store." ((url ...) (any https? url))))) - (define mirror-file - ;; Copy the list of mirrors to a file to keep a single copy in the store. - (plain-file "mirrors" (object->string mirrors))) - (define builder #~(begin #+(if need-gnutls? @@ -261,7 +261,7 @@ in the store." (url-fetch (call-with-input-string (getenv "guix download url") read) #$output - #:mirrors (call-with-input-file #$mirror-file read)))) + #:mirrors (call-with-input-file #$%mirror-file read)))) (let ((uri (and (string? url) (string->uri url)))) (if (or (and (string? url) (not uri)) @@ -288,12 +288,11 @@ in the store." ;; Honor the user's proxy settings. #:leaked-env-vars '("http_proxy" "https_proxy") - ;; In general, offloading downloads is not a good idea. - ;;#:local-build? #t - ;; FIXME: The above would also disable use of - ;; substitutes on old daemons, so comment it out; - ;; see <https://bugs.gnu.org/18747>. - ))))) + ;; In general, offloading downloads is not a good + ;; idea. Daemons before 0.8.3 would also + ;; interpret this as "do not substitute" (see + ;; <https://bugs.gnu.org/18747>.) + #:local-build? #t))))) (define* (download-to-store store url #:optional (name (basename url)) #:key (log (current-error-port)) recursive?) diff --git a/guix/git-download.scm b/guix/git-download.scm index 0f2218c13e..1e5c845e34 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -89,9 +89,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build #:system system - ;; FIXME: See <https://bugs.gnu.org/18747>. - ;; Uncomment when fixed daemons are widely deployed. - ;;#:local-build? #t + #:local-build? #t ;don't offload repo cloning #:hash-algo hash-algo #:hash hash #:recursive? #t diff --git a/guix/http-client.scm b/guix/http-client.scm index dc8d3298fc..5cfe05f2e0 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -19,7 +19,6 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix http-client) - #:use-module (guix utils) #:use-module (web uri) #:use-module ((web client) #:hide (open-socket-for-uri)) #:use-module (web response) @@ -167,13 +166,15 @@ closes PORT, unless KEEP-ALIVE? is true." (define close (and (not keep-alive?) (lambda () - (close port)))) + (close-port port)))) (make-custom-binary-input-port "delimited input port" read! #f #f close)) - (unless (guile-version>? "2.0.9") + (unless (guile-version>? "2.0.11") ;; Guile <= 2.0.9 had a bug whereby 'response-body-port' would read more ;; than what 'content-length' says. See Guile commit 802a25b. + ;; Guile <= 2.0.12 had a bug whereby the 'close' method of the response + ;; body port would fail with wrong-arg-num. See Guile commit 5a10e41. (module-set! (resolve-module '(web response)) 'make-delimited-input-port make-delimited-input-port))) diff --git a/guix/import/cran.scm b/guix/import/cran.scm new file mode 100644 index 0000000000..8ed5e5407f --- /dev/null +++ b/guix/import/cran.scm @@ -0,0 +1,188 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; 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 cran) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (sxml simple) + #:use-module (sxml match) + #:use-module (sxml xpath) + #:use-module (guix http-client) + #:use-module (guix hash) + #:use-module (guix store) + #:use-module (guix base32) + #:use-module ((guix download) #:select (download-to-store)) + #:use-module (guix import utils) + #:export (cran->guix-package)) + +;;; Commentary: +;;; +;;; Generate a package declaration template for the latest version of an R +;;; package on CRAN, using the HTML description downloaded from +;;; cran.r-project.org. +;;; +;;; Code: + +(define string->license + (match-lambda + ("AGPL-3" 'agpl3+) + ("Artistic-2.0" 'artistic2.0) + ("Apache License 2.0" 'asl2.0) + ("BSD_2_clause" 'bsd-2) + ("BSD_3_clause" 'bsd-3) + ("GPL-2" 'gpl2+) + ("GPL-3" 'gpl3+) + ("LGPL-2" 'lgpl2.0+) + ("LGPL-2.1" 'lgpl2.1+) + ("LGPL-3" 'lgpl3+) + ("MIT" 'x11) + ((x) (string->license x)) + ((lst ...) `(list ,@(map string->license lst))) + (_ #f))) + +(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)))) + (sort names string-ci<?))) + +(define* (maybe-inputs package-inputs #:optional (type 'inputs)) + "Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a +package definition." + (match package-inputs + (() + '()) + ((package-inputs ...) + `((,type (,'quasiquote ,(format-inputs package-inputs))))))) + +(define (table-datum tree label) + "Extract the datum node following a LABEL in the sxml table TREE. Only the +first cell of a table row is considered a label cell." + ((node-pos 1) + ((sxpath `(xhtml:tr + (xhtml:td 1) ; only first cell can contain label + (equal? ,label) + ,(node-parent tree) ; go up to label cell + ,(node-parent tree) ; go up to matching row + (xhtml:td 2))) ; select second cell + tree))) + +(define %cran-url "http://cran.r-project.org/web/packages/") + +(define (cran-fetch name) + "Return an sxml representation of the CRAN page for the R package NAME, +or #f on failure. NAME is case-sensitive." + ;; This API always returns the latest release of the module. + (let ((cran-url (string-append %cran-url name))) + (false-if-exception + (xml->sxml (http-fetch cran-url) + #:trim-whitespace? #t + #:namespaces '((xhtml . "http://www.w3.org/1999/xhtml")) + #:default-entity-handler + (lambda (port name) + (case name + ((nbsp) " ") + ((ge) ">=") + ((gt) ">") + ((lt) "<") + (else + (format (current-warning-port) + "~a:~a:~a: undefined entitity: ~a\n" + cran-url (port-line port) (port-column port) + name) + (symbol->string name)))))))) + +(define (cran-sxml->sexp sxml) + "Return the `package' s-expression for a CRAN package from the SXML +representation of the package page." + (define (nodes->text nodeset) + (string-join ((sxpath '(// *text*)) nodeset) " ")) + + (define (guix-name name) + (if (string-prefix? "r-" name) + (string-downcase name) + (string-append "r-" (string-downcase name)))) + + (sxml-match-let* + (((*TOP* (xhtml:html + ,head + (xhtml:body + (xhtml:h2 ,name-and-synopsis) + (xhtml:p ,description) + ,summary + (xhtml:h4 "Downloads:") ,downloads + . ,rest))) + sxml)) + (let* ((name (match:prefix (string-match ": " name-and-synopsis))) + (synopsis (match:suffix (string-match ": " name-and-synopsis))) + (version (nodes->text (table-datum summary "Version:"))) + (license ((compose string->license nodes->text) + (table-datum summary "License:"))) + (home-page (nodes->text ((sxpath '((xhtml:a 1))) + (table-datum summary "URL:")))) + (source-url (string-append "mirror://cran/" + ;; Remove double dots, because we want an + ;; absolute path. + (regexp-substitute/global + #f "\\.\\./" + (string-join + ((sxpath '((xhtml:a 1) @ href *text*)) + (table-datum downloads + " Package source: "))) + 'pre 'post))) + (tarball (with-store store (download-to-store store source-url))) + (sysdepends (map match:substring + (list-matches + "[^ ]+" + ;; Strip off comma and parenthetical + ;; expressions. + (regexp-substitute/global + #f "(,|\\([^\\)]+\\))" + (nodes->text (table-datum summary + "SystemRequirements:")) + 'pre 'post)))) + (imports (map guix-name + ((sxpath '(// xhtml:a *text*)) + (table-datum summary "Imports:"))))) + `(package + (name ,(guix-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (string-append ,@(factorize-uri source-url version))) + (sha256 + (base32 + ,(bytevector->nix-base32-string (file-sha256 tarball)))))) + (build-system r-build-system) + ,@(maybe-inputs sysdepends) + ,@(maybe-inputs imports 'propagated-inputs) + (home-page ,(if (string-null? home-page) + (string-append %cran-url name) + home-page)) + (synopsis ,synopsis) + ;; Use double spacing + (description ,(regexp-substitute/global #f "\\. \\b" description + 'pre ". " 'post)) + (license ,license))))) + +(define (cran->guix-package package-name) + "Fetch the metadata for PACKAGE-NAME from cran.r-project.org, and return the +`package' s-expression corresponding to that package, or #f on failure." + (let ((module-meta (cran-fetch package-name))) + (and=> module-meta cran-sxml->sexp))) diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 3c28d1d9fd..c64c4e9374 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -105,8 +105,9 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES." (description ,description) (home-page ,home-page) (license ,(match licenses + (() #f) ((license) (license->symbol license)) - (_ (map license->symbol licenses)))))) + (_ `(list ,@(map license->symbol licenses))))))) (define* (gem->guix-package package-name #:optional version) "Fetch the metadata for PACKAGE-NAME from rubygems.org, and return the diff --git a/guix/licenses.scm b/guix/licenses.scm index dae0e3d386..c3b76af9b9 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +30,7 @@ non-copyleft bsd-style ;deprecated! cc0 + cc-by-sa4.0 cc-by3.0 cddl1.0 cecill-c artistic2.0 clarified-artistic @@ -38,6 +40,7 @@ expat freetype gpl1 gpl1+ gpl2 gpl2+ gpl3 gpl3+ + gfl1.0 fdl1.3+ opl1.0+ isc @@ -135,6 +138,16 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:CC0" "http://www.gnu.org/licenses/license-list.html#CC0")) +(define cc-by-sa4.0 + (license "CC-BY-SA 4.0" + "http://creativecommons.org/licenses/by-sa/4.0/" + "Creative Commons Attribution-ShareAlike 4.0 International")) + +(define cc-by3.0 + (license "CC-BY 3.0" + "http://creativecommons.org/licenses/by/3.0/" + "Creative Commons Attribution 3.0 Unported")) + (define cddl1.0 (license "CDDL 1.0" "http://directory.fsf.org/wiki/License:CDDLv1.0" @@ -211,6 +224,13 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.gnu.org/licenses/gpl.html" "https://www.gnu.org/licenses/license-list#GNUGPLv3")) +;; The “GUST font license” is legally equivalent to LPPL v1.3c as it only +;; extends the LPPL with an optional request. +(define gfl1.0 + (license "GUST font license 1.0" + "http://www.gust.org.pl/projects/e-foundry/licenses/GUST-FONT-LICENSE.txt" + "https://www.gnu.org/licenses/license-list#LPPL-1.3a")) + (define fdl1.3+ (license "FDL 1.3+" "https://www.gnu.org/licenses/fdl.html" diff --git a/guix/monads.scm b/guix/monads.scm index 61cd533bf4..0b0ad239de 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -239,10 +239,10 @@ CONDITION is true, return *unspecified* in the current monad." (identifier? #'id) ;; Slow path: Return a closure-returning procedure (we don't ;; guarantee (eq? LIFTN LIFTN), but that's fine.) - (lambda (liftn proc monad) - (lambda (args ...) - (with-monad monad - (return (proc args ...)))))))))))) + #'(lambda (proc monad) + (lambda (args ...) + (with-monad monad + (return (proc args ...)))))))))))) (define-lift lift0 ()) (define-lift lift1 (a)) diff --git a/guix/packages.scm b/guix/packages.scm index da4940981d..49c6b44884 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -93,6 +94,8 @@ package-output package-grafts + transitive-input-references + %supported-systems %hurd-systems %hydra-supported-systems @@ -604,6 +607,18 @@ for the host system (\"native inputs\"), and not target inputs." recursively." (transitive-inputs (package-propagated-inputs package))) +(define (transitive-input-references alist inputs) + "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _) +in INPUTS and their transitive propagated inputs." + (define label + (match-lambda + ((label . _) + label))) + + (map (lambda (input) + `(assoc-ref ,alist ,(label input))) + (transitive-inputs inputs))) + (define-syntax define-memoized/v (lambda (form) "Define a memoized single-valued unary procedure with docstring. diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index d593b5a8a7..ab2a39b1f8 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -25,6 +25,7 @@ #:use-module (guix utils) #:use-module (guix monads) #:use-module (guix gexp) + #:autoload (guix http-client) (http-fetch http-get-error?) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 vlist) @@ -42,6 +43,45 @@ guix-build)) +(define %default-log-urls + ;; Default base URLs for build logs. + '("http://hydra.gnu.org/log")) + +;; XXX: The following procedure cannot be in (guix store) because of the +;; dependency on (guix derivations). +(define* (log-url store file #:key (base-urls %default-log-urls)) + "Return a URL under one of the BASE-URLS where a build log for FILE can be +found. Return #f if no build log was found." + (define (valid-url? url) + ;; Probe URL and return #t if it is accessible. + (guard (c ((http-get-error? c) #f)) + (close-port (http-fetch url #:buffered? #f)) + #t)) + + (define (find-url file) + (let ((base (basename file))) + (any (lambda (base-url) + (let ((url (string-append base-url "/" base))) + (and (valid-url? url) url))) + base-urls))) + + (cond ((derivation-path? file) + (catch 'system-error + (lambda () + ;; Usually we'll have more luck with the output file name since + ;; the deriver that was used by the server could be different, so + ;; try one of the output file names. + (let ((drv (call-with-input-file file read-derivation))) + (or (find-url (derivation->output-path drv)) + (find-url file)))) + (lambda args + ;; As a last resort, try the .drv. + (if (= ENOENT (system-error-errno args)) + (find-url file) + (apply throw args))))) + (else + (find-url file)))) + (define (register-root store paths root) "Register ROOT as an indirect GC root for all of PATHS." (let* ((root (string-append (canonicalize-path (dirname root)) @@ -457,6 +497,11 @@ arguments with packages that use the specified source." (list %default-options))) (store (open-connection)) (drv (options->derivations store opts)) + (urls (map (cut string-append <> "/log") + (if (assoc-ref opts 'substitutes?) + (or (assoc-ref opts 'substitute-urls) + %default-substitute-urls) + '()))) (roots (filter-map (match-lambda (('gc-root . root) root) (_ #f)) @@ -470,7 +515,9 @@ arguments with packages that use the specified source." (cond ((assoc-ref opts 'log-file?) (for-each (lambda (file) - (let ((log (log-file store file))) + (let ((log (or (log-file store file) + (log-url store file + #:base-urls urls)))) (if log (format #t "~a~%" log) (leave (_ "no build log for '~a'~%") diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 475f054571..2b671be131 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -39,6 +39,16 @@ %bag-emerged-node-type %derivation-node-type %reference-node-type + %node-types + + node-type + node-type? + node-type-identifier + node-type-label + node-type-edges + node-type-convert + node-type-name + node-type-description %graphviz-backend graph-backend? @@ -370,6 +380,9 @@ given BACKEND. Use NODE-TYPE to traverse the DAG." (lambda (opt name arg result) (list-node-types) (exit 0))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) (option '(#\h "help") #f #f (lambda args (show-help) @@ -387,6 +400,8 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) -t, --type=TYPE represent nodes of the given TYPE")) (display (_ " --list-types list the available graph types")) + (display (_ " + -e, --expression=EXPR consider the package EXPR evaluates to")) (newline) (display (_ " -h, --help display this help and exit")) @@ -407,12 +422,14 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (with-error-handling (let* ((opts (parse-command-line args %options (list %default-options))) - (specs (filter-map (match-lambda - (('argument . spec) spec) - (_ #f)) - opts)) (type (assoc-ref opts 'node-type)) - (packages (map specification->package specs))) + (packages (filter-map (match-lambda + (('argument . spec) + (specification->package spec)) + (('expression . exp) + (read/eval-package-expression exp)) + (_ #f)) + opts))) (with-store store (run-with-store store (mlet %store-monad ((nodes (mapm %store-monad diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 6cd762a537..7b29794e8f 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -73,7 +73,7 @@ rather than \\n." ;;; Entry point. ;;; -(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem")) +(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem" "cran")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm new file mode 100644 index 0000000000..f11fa1004f --- /dev/null +++ b/guix/scripts/import/cran.scm @@ -0,0 +1,92 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; 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 scripts import cran) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix import cran) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-cran)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import cran PACKAGE-NAME +Import and convert the CRAN package for PACKAGE-NAME.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import cran"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-cran . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((package-name) + (let ((sexp (cran->guix-package package-name))) + (unless sexp + (leave (_ "failed to download description for package '~a'~%") + package-name)) + sexp)) + (() + (leave (_ "too few arguments~%"))) + ((many ...) + (leave (_ "too many arguments~%")))))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 14ac8cba81..2a618c9451 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -24,6 +24,7 @@ #:use-module (guix download) #:use-module (guix ftp-client) #:use-module (guix packages) + #:use-module (guix licenses) #:use-module (guix records) #:use-module (guix ui) #:use-module (guix utils) @@ -56,7 +57,15 @@ check-derivation check-home-page check-source - check-formatting)) + check-license + check-formatting + + %checkers + lint-checker + lint-checker? + lint-checker-name + lint-checker-description + lint-checker-check)) ;;; @@ -511,6 +520,16 @@ descriptions maintained upstream." (format #f (_ "failed to create derivation: ~s~%") args))))) +(define (check-license package) + "Warn about type errors of the 'license' field of PACKAGE." + (match (package-license package) + ((or (? license?) + ((? license?) ...)) + #t) + (x + (emit-warning package (_ "invalid license field") + 'license)))) + ;;; ;;; Source code formatting. @@ -613,6 +632,13 @@ them for PACKAGE." (description "Validate home-page URLs") (check check-home-page)) (lint-checker + (name 'license) + ;; TRANSLATORS: <license> is the name of a data type and must not be + ;; translated. + (description "Make sure the 'license' field is a <license> \ +or a list thereof") + (check check-license)) + (lint-checker (name 'source) (description "Validate source URLs") (check check-source)) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index e3bcac8047..cc96355947 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -151,7 +151,7 @@ PATH-INFO. The narinfo is signed with KEY." (references (string-join (map basename (path-info-references path-info)) " ")) - (deriver (path-info-deriver path-info)) + (deriver (path-info-deriver path-info)) (base-info (format #f "StorePath: ~a URL: ~a @@ -162,12 +162,21 @@ References: ~a~%" store-path url hash size references)) ;; Do not render a "Deriver" or "System" line if we are rendering ;; info for a derivation. - (info (if (string-null? deriver) - base-info - (let ((drv (load-derivation deriver))) - (format #f "~aSystem: ~a~%Deriver: ~a~%" - base-info (derivation-system drv) - (basename deriver))))) + (info (if (string-null? deriver) + base-info + (catch 'system-error + (lambda () + (let ((drv (load-derivation deriver))) + (format #f "~aSystem: ~a~%Deriver: ~a~%" + base-info (derivation-system drv) + (basename deriver)))) + (lambda args + ;; DERIVER might be missing, but that's fine: + ;; it's only used for <substitutable> where it's + ;; optional. 'System' is currently unused. + (if (= ENOENT (system-error-errno args)) + base-info + (apply throw args)))))) (signature (base64-encode-string (canonical-sexp->string (signed-string info))))) (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index e6ed8d23eb..e8459e5ffb 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -43,7 +43,7 @@ (define %snapshot-url ;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download" - "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz" + "http://git.savannah.gnu.org/cgit/guix.git/snapshot/master.tar.gz" ) (define-syntax-rule (with-environment-variable variable value body ...) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 28519d78e2..e7980a97b0 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -149,7 +149,7 @@ values: 'interactive' (default), 'always', and 'never'." port-sha256))) (update-package-source package version hash))) (warning (_ "~a: version ~a could not be \ -downloaded and authenticated; not updating") +downloaded and authenticated; not updating~%") (package-name package) version))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 95aae2a372..e908bc997e 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -703,7 +703,7 @@ Internal tool to substitute a pre-built binary to a local build.\n")) ;;; (define (display-narinfo-data narinfo) - "Write to the current output port the contents of NARINFO is the format + "Write to the current output port the contents of NARINFO in the format expected by the daemon." (format #t "~a\n~a\n~a\n" (narinfo-path narinfo) diff --git a/guix/ui.scm b/guix/ui.scm index a6d4fd10cf..ca5b844a43 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -2,7 +2,8 @@ ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> -;;; Copyright © 2014 Alex Kost <alezost@gmail.com> +;;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> +;;; Copyright © 2015 Mathieu Lirzin <mthl@openmailbox.org> ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -45,6 +46,9 @@ #:use-module (ice-9 regex) #:autoload (system repl repl) (start-repl) #:autoload (system repl debug) (make-debug stack->vector) + #:use-module (texinfo) + #:use-module (texinfo plain-text) + #:use-module (texinfo string-utils) #:export (_ N_ P_ @@ -69,6 +73,7 @@ switch-symlinks config-directory fill-paragraph + package-description-string string->recutils package->recutils package-specification->name+version+output @@ -77,6 +82,7 @@ args-fold* parse-command-line run-guix-command + run-guix program-name guix-warning-port warning @@ -98,7 +104,15 @@ (define _ (cut gettext <> %gettext-domain)) (define N_ (cut ngettext <> <> <> %gettext-domain)) -(define P_ (cut gettext <> %package-text-domain)) + +(define (P_ msgid) + "Return the translation of the package description or synopsis MSGID." + ;; Descriptions/synopses might occasionally be empty strings, even if that + ;; is something we try to avoid. Since (gettext "") can return a non-empty + ;; string, explicitly check for that case. + (if (string-null? msgid) + msgid + (gettext msgid %package-text-domain))) (define-syntax-rule (define-diagnostic name prefix) "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all @@ -766,6 +780,28 @@ converted to a space; sequences of more than one line break are preserved." ;;; Packages. ;;; +(define %text-width + (make-parameter (or (and=> (getenv "WIDTH") string->number) + 80))) + +(set! (@@ (texinfo plain-text) wrap*) + ;; XXX: Monkey patch this private procedure to let 'package->recutils' + ;; parameterize the fill of description field correctly. + (lambda strings + (let ((indent (fluid-ref (@@ (texinfo plain-text) *indent*)))) + (fill-string (string-concatenate strings) + #:line-width (%text-width) #:initial-indent indent + #:subsequent-indent indent)))) + +(define (texi->plain-text str) + "Return a plain-text representation of texinfo fragment STR." + (stexi->plain-text (texi-fragment->stexi str))) + +(define (package-description-string package) + "Return a plain-text representation of PACKAGE description field." + (and=> (package-description package) + (compose texi->plain-text P_))) + (define (string->recutils str) "Return a version of STR where newlines have been replaced by newlines followed by \"+ \", which makes for a valid multi-line field value in the @@ -778,18 +814,9 @@ followed by \"+ \", which makes for a valid multi-line field value in the '() str))) -(define* (package->recutils p port - #:optional (width (or (and=> (getenv "WIDTH") - string->number) - 80))) +(define* (package->recutils p port #:optional (width (%text-width))) "Write to PORT a `recutils' record of package P, arranging to fit within WIDTH columns." - (define (description->recutils str) - (let ((str (P_ str))) - (string->recutils - (fill-paragraph str width - (string-length "description: "))))) - (define (dependencies->recutils packages) (let ((list (string-join (map package-full-name (sort packages package<?)) " "))) @@ -833,9 +860,15 @@ WIDTH columns." (chr chr)) (or (and=> (package-synopsis p) P_) ""))) - (format port "description: ~a~%" - (and=> (package-description p) description->recutils)) - (newline port)) + (format port "~a~2%" + (string->recutils + (string-trim-right + (parameterize ((%text-width width)) + (texi->plain-text + (string-append "description: " + (or (and=> (package-description p) P_) + "")))) + #\newline)))) (define (string->generations str) "Return the list of generations matching a pattern in STR. This function @@ -1032,31 +1065,37 @@ found." (parameterize ((program-name command)) (apply command-main args)))) +(define (run-guix . args) + "Run the 'guix' command defined by command line ARGS. +Unlike 'guix-main', this procedure assumes that locale, i18n support, +and signal handling has already been set up." + (define option? (cut string-prefix? "-" <>)) + + (match args + (() + (format (current-error-port) + (_ "guix: missing command name~%")) + (show-guix-usage)) + ((or ("-h") ("--help")) + (show-guix-help)) + (("--version") + (show-version-and-exit "guix")) + (((? option? o) args ...) + (format (current-error-port) + (_ "guix: unrecognized option '~a'~%") o) + (show-guix-usage)) + (("help" args ...) + (show-guix-help)) + ((command args ...) + (apply run-guix-command + (string->symbol command) + args)))) + (define guix-warning-port (make-parameter (current-warning-port))) (define (guix-main arg0 . args) (initialize-guix) - (let () - (define (option? str) (string-prefix? "-" str)) - (match args - (() - (format (current-error-port) - (_ "guix: missing command name~%")) - (show-guix-usage)) - ((or ("-h") ("--help")) - (show-guix-help)) - (("--version") - (show-version-and-exit "guix")) - (((? option? o) args ...) - (format (current-error-port) - (_ "guix: unrecognized option '~a'~%") o) - (show-guix-usage)) - (("help" args ...) - (show-guix-help)) - ((command args ...) - (apply run-guix-command - (string->symbol command) - args))))) + (apply run-guix args)) ;;; ui.scm ends here |