diff options
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/gnu.scm | 16 | ||||
-rw-r--r-- | guix/build-system/python.scm | 9 | ||||
-rw-r--r-- | guix/build/git.scm | 43 | ||||
-rw-r--r-- | guix/build/pull.scm | 149 | ||||
-rw-r--r-- | guix/build/ruby-build-system.scm | 19 | ||||
-rw-r--r-- | guix/http-client.scm | 26 | ||||
-rw-r--r-- | guix/import/cran.scm | 46 | ||||
-rw-r--r-- | guix/monad-repl.scm | 22 | ||||
-rw-r--r-- | guix/scripts/lint.scm | 13 | ||||
-rw-r--r-- | guix/scripts/package.scm | 33 | ||||
-rw-r--r-- | guix/ui.scm | 4 | ||||
-rw-r--r-- | guix/utils.scm | 42 |
12 files changed, 239 insertions, 183 deletions
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index c77348bd88..afd57668e2 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -96,10 +96,11 @@ builder, or the distro's final Guile when GUILE is #f." (package (inherit p) (location (if (pair? loc) (source-properties->location loc) loc)) (arguments - (let ((args (package-arguments p))) - `(#:guile ,guile - #:implicit-inputs? #f - ,@args))) + ;; 'ensure-keyword-arguments' guarantees that this procedure is + ;; idempotent. + (ensure-keyword-arguments (package-arguments p) + `(#:guile ,guile + #:implicit-inputs? #f))) (replacement (let ((replacement (package-replacement p))) (and replacement @@ -177,9 +178,10 @@ use `--strip-all' as the arguments to `strip'." flags))))) (replacement (and=> (package-replacement p) static-package)))) -(define* (dist-package p source) +(define* (dist-package p source #:key (phases '%dist-phases)) "Return a package that runs takes source files from the SOURCE directory, -runs `make distcheck' and whose result is one or more source tarballs." +runs `make distcheck' and whose result is one or more source tarballs. The +exact build phases are defined by PHASES." (let ((s source)) (package (inherit p) (name (string-append (package-name p) "-dist")) @@ -198,7 +200,7 @@ runs `make distcheck' and whose result is one or more source tarballs." `((guix build gnu-dist) ,@modules)) ((#:phases _) - '%dist-phases)))) + phases)))) (native-inputs ;; Add autotools & co. as inputs. (let ((ref (lambda (module var) diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 2532210a49..86efc1a715 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; @@ -41,12 +41,13 @@ ;; ;; Code: -(define (pypi-uri name version) +(define* (pypi-uri name version #:optional (extension ".tar.gz")) "Return a URI string for the Python package hosted on the Python Package -Index (PyPI) corresponding to NAME and VERSION." +Index (PyPI) corresponding to NAME and VERSION. EXTENSION is the file name +extension, such as '.tar.gz'." (string-append "https://pypi.python.org/packages/source/" (string-take name 1) "/" name "/" - name "-" version ".tar.gz")) + name "-" version extension)) (define %python-build-system-modules ;; Build-side modules imported by default. diff --git a/guix/build/git.scm b/guix/build/git.scm index 121f07a7fa..c1af545a76 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,23 +37,28 @@ recursively. Return #t on success, #f otherwise." ;; in advance anyway. (setenv "GIT_SSL_NO_VERIFY" "true") - (let ((args `("clone" ,@(if recursive? '("--recursive") '()) - ,url ,directory))) - (and (zero? (apply system* git-command args)) - (with-directory-excursion directory - (system* git-command "tag" "-l") - (and (zero? (system* git-command "checkout" commit)) - (begin - ;; The contents of '.git' vary as a function of the current - ;; status of the Git repo. Since we want a fixed output, this - ;; directory needs to be taken out. - (delete-file-recursively ".git") - - (when recursive? - ;; In sub-modules, '.git' is a flat file, not a directory, - ;; so we can use 'find-files' here. - (for-each delete-file-recursively - (find-files directory "^\\.git$"))) - #t)))))) + ;; We cannot use "git clone --recursive" since the following "git checkout" + ;; effectively removes sub-module checkouts as of Git 2.6.3. + (and (zero? (system* git-command "clone" url directory)) + (with-directory-excursion directory + (system* git-command "tag" "-l") + (and (zero? (system* git-command "checkout" commit)) + (begin + (when recursive? + ;; Now is the time to fetch sub-modules. + (unless (zero? (system* git-command "submodule" "update" + "--init" "--recursive")) + (error "failed to fetch sub-modules" url)) + + ;; In sub-modules, '.git' is a flat file, not a directory, + ;; so we can use 'find-files' here. + (for-each delete-file-recursively + (find-files directory "^\\.git$"))) + + ;; The contents of '.git' vary as a function of the current + ;; status of the Git repo. Since we want a fixed output, this + ;; directory needs to be taken out. + (delete-file-recursively ".git") + #t))))) ;;; git.scm ends here diff --git a/guix/build/pull.scm b/guix/build/pull.scm index 281be23aa8..4ddb12ac04 100644 --- a/guix/build/pull.scm +++ b/guix/build/pull.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +23,7 @@ #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 threads) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -33,75 +35,10 @@ ;;; ;;; Code: -(define (call-with-process thunk) - "Run THUNK in a separate process that will return 0 if THUNK terminates -normally, and 1 if an exception is raised." - (match (primitive-fork) - (0 - (catch #t - (lambda () - (thunk) - (primitive-exit 0)) - (lambda (key . args) - (print-exception (current-error-port) #f key args) - (primitive-exit 1)))) - (pid - #t))) - -(define* (report-build-progress total completed cont - #:optional (log-port (current-error-port))) - "Report that COMPLETED out of TOTAL files have been completed, and call -CONT." - (display #\cr log-port) - (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n - (* 100. (/ completed total)) total) - (force-output log-port) - (cont)) - -(define* (p-for-each proc lst - #:optional (max-processes (current-processor-count)) - #:key (progress report-build-progress)) - "Invoke PROC for each element of LST in a separate process, using up to -MAX-PROCESSES processes in parallel. Call PROGRESS at each step, passing it -the continuation. Raise an error if one of the processes exit with non-zero." - (define total - (length lst)) - - (define (wait-for-one-process) - (match (waitpid WAIT_ANY) - ((_ . status) - (unless (zero? (status:exit-val status)) - (error "process failed" proc status))))) - - (let loop ((lst lst) - (running 0) - (completed 0)) - (match lst - (() - (or (zero? running) - (let ((running (- running 1)) - (completed (+ completed 1))) - (wait-for-one-process) - (progress total completed - (lambda () - (loop lst running completed)))))) - ((head . tail) - (if (< running max-processes) - (let ((running (+ 1 running))) - (call-with-process (cut proc head)) - (progress total completed - (lambda () - (loop tail running completed)))) - (let ((running (- running 1)) - (completed (+ completed 1))) - (wait-for-one-process) - (progress total completed - (lambda () - (loop lst running completed))))))))) - (define* (build-guix out source #:key gcrypt - (debug-port (%make-void-port "w"))) + (debug-port (%make-void-port "w")) + (log-port (current-error-port))) "Build and install Guix in directory OUT using SOURCE, a directory containing the source code. Write any debugging output to DEBUG-PORT." (setvbuf (current-output-port) _IOLBF) @@ -130,33 +67,57 @@ containing the source code. Write any debugging output to DEBUG-PORT." (set! %load-path (cons out %load-path)) (set! %load-compiled-path (cons out %load-compiled-path)) - ;; Compile the .scm files. Do that in independent processes, à la - ;; 'make -j', to work around <http://bugs.gnu.org/15602> (FIXME). - ;; This ensures correctness, but is overly conservative and slow. - ;; The solution initially implemented (and described in the bug - ;; above) was slightly faster but consumed memory proportional to the - ;; number of modules, which quickly became unacceptable. - (p-for-each (lambda (file) - (let ((go (string-append (string-drop-right file 4) - ".go"))) - (format debug-port "~%compiling '~a'...~%" file) - (parameterize ((current-warning-port debug-port)) - (compile-file file - #:output-file go - #:opts - %auto-compilation-options)))) - - (filter (cut string-suffix? ".scm" <>) - - ;; Build guix/*.scm before gnu/*.scm to speed - ;; things up. - (sort (find-files out "\\.scm") - (let ((guix (string-append out "/guix")) - (gnu (string-append out "/gnu"))) - (lambda (a b) - (or (and (string-prefix? guix a) - (string-prefix? gnu b)) - (string<? a b)))))))) + ;; Compile the .scm files. Load all the files before compiling them to + ;; work around <http://bugs.gnu.org/15602> (FIXME). + (let* ((files + ;; Load guix/ modules before gnu/ modules to get somewhat steadier + ;; progress reporting. + (sort (filter (cut string-suffix? ".scm" <>) + (find-files out "\\.scm")) + (let ((guix (string-append out "/guix")) + (gnu (string-append out "/gnu"))) + (lambda (a b) + (or (and (string-prefix? guix a) + (string-prefix? gnu b)) + (string<? a b)))))) + (total (length files))) + (let loop ((files files) + (completed 0)) + (match files + (() *unspecified*) + ((file . files) + (display #\cr log-port) + (format log-port "loading...\t~5,1f% of ~d files" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output log-port) + (format debug-port "~%loading '~a'...~%" file) + ;; Turn "<out>/foo/bar.scm" into (foo bar). + (let* ((relative-file (string-drop file (+ (string-length out) 1))) + (module-path (string-drop-right relative-file 4)) + (module-name (map string->symbol + (string-split module-path #\/)))) + (parameterize ((current-warning-port debug-port)) + (resolve-interface module-name))) + (loop files (+ 1 completed))))) + (newline) + (let ((mutex (make-mutex)) + (completed 0)) + (par-for-each + (lambda (file) + (with-mutex mutex + (display #\cr log-port) + (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output log-port) + (format debug-port "~%compiling '~a'...~%" file)) + (let ((go (string-append (string-drop-right file 4) ".go"))) + (parameterize ((current-warning-port (%make-void-port "w"))) + (compile-file file + #:output-file go + #:opts %auto-compilation-options))) + (with-mutex mutex + (set! completed (+ 1 completed)))) + files)))) ;; Remove the "fake" (guix config). (delete-file (string-append out "/guix/config.scm")) diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 18da43866d..a4ac3b307c 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Pjotr Prins <pjotr.public01@thebird.nl> +;;; Copyright © 2015 Ben Woodcroft <donttrustben@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -116,15 +117,19 @@ GEM-FLAGS are passed to the 'gem' invokation, if present." (assoc-ref inputs "ruby")) 1)) (out (assoc-ref outputs "out")) - (gem-home (string-append out "/lib/ruby/gems/" ruby-version ".0"))) - + (gem-home (string-append out "/lib/ruby/gems/" ruby-version ".0")) + (gem-name (first-matching-file "\\.gem$"))) (setenv "GEM_HOME" gem-home) (mkdir-p gem-home) - (zero? (apply system* "gem" "install" (first-matching-file "\\.gem$") - "--local" "--ignore-dependencies" - ;; Executables should go into /bin, not /lib/ruby/gems. - "--bindir" (string-append out "/bin") - gem-flags)))) + (and (apply system* "gem" "install" gem-name + "--local" "--ignore-dependencies" + ;; Executables should go into /bin, not /lib/ruby/gems. + "--bindir" (string-append out "/bin") + gem-flags) + ;; Remove the cached gem file as this is unnecessary and contains + ;; timestamped files rendering builds not reproducible. + (begin (delete-file (string-append gem-home "/cache/" gem-name)) + #t)))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/http-client.scm b/guix/http-client.scm index c7cbc82aac..31b511eb1c 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; @@ -188,13 +188,33 @@ closes PORT, unless KEEP-ALIVE? is true." (make-custom-binary-input-port "delimited input port" read! #f #f close)) + (define (read-header-line port) + "Read an HTTP header line and return it without its final CRLF or LF. +Raise a 'bad-header' exception if the line does not end in CRLF or LF, +or if EOF is reached." + (match (%read-line port) + (((? string? line) . #\newline) + ;; '%read-line' does not consider #\return a delimiter; so if it's + ;; there, remove it. We are more tolerant than the RFC in that we + ;; tolerate LF-only endings. + (if (string-suffix? "\r" line) + (string-drop-right line 1) + line)) + ((line . _) ;EOF or missing delimiter + ((@@ (web http) bad-header) 'read-header-line line)))) + (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 + ;; Guile <= 2.0.11 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))) + 'make-delimited-input-port make-delimited-input-port) + + ;; Guile <= 2.0.11 was affected by <http://bugs.gnu.org/22273>. See Guile + ;; commit 4c7732c. + (when (module-variable %web-http 'read-line*) + (module-set! %web-http 'read-line* read-header-line)))) ;; XXX: Work around <http://bugs.gnu.org/13095>, present in Guile ;; up to 2.0.7. diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 45c679cbe2..fc2709020a 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -109,11 +109,11 @@ package definition." (define %cran-url "http://cran.r-project.org/web/packages/") -(define (cran-fetch name) +(define (fetch-description base-url name) "Return an alist of the contents of the DESCRIPTION file for the R package NAME, or #f on failure. NAME is case-sensitive." ;; This API always returns the latest release of the module. - (let ((url (string-append %cran-url name "/DESCRIPTION"))) + (let ((url (string-append base-url name "/DESCRIPTION"))) (description->alist (read-string (http-fetch url))))) (define (listify meta field) @@ -196,7 +196,7 @@ which was derived from the R package's DESCRIPTION file." (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))) + (let ((module-meta (fetch-description %cran-url package-name))) (and=> module-meta description->package))) @@ -204,27 +204,33 @@ which was derived from the R package's DESCRIPTION file." ;;; Updater. ;;; +(define (package->upstream-name package) + "Return the upstream name of the PACKAGE." + (let* ((properties (package-properties package)) + (upstream-name (and=> properties + (cut assoc-ref <> 'upstream-name)))) + (if upstream-name + upstream-name + (match (package-source package) + ((? origin? origin) + (match (origin-uri origin) + ((url rest ...) + (let ((end (string-rindex url #\_)) + (start (string-rindex url #\/))) + ;; The URL ends on + ;; (string-append "/" name "_" version ".tar.gz") + (substring url start end))) + (_ #f))) + (_ #f))))) + (define (latest-release package) "Return an <upstream-source> for the latest release of PACKAGE." - (define (package->cran-name package) - (match (package-source package) - ((? origin? origin) - (match (origin-uri origin) - ((url rest ...) - (let ((end (string-rindex url #\_)) - (start (string-rindex url #\/))) - ;; The URL ends on - ;; (string-append "/" name "_" version ".tar.gz") - (substring url start end))) - (_ #f))) - (_ #f))) - - (define cran-name - (package->cran-name (specification->package package))) + (define upstream-name + (package->upstream-name (specification->package package))) (define meta - (cran-fetch cran-name)) + (fetch-description %cran-url upstream-name)) (and meta (let ((version (assoc-ref meta "Version"))) @@ -232,7 +238,7 @@ which was derived from the R package's DESCRIPTION file." (upstream-source (package package) (version version) - (urls (cran-uri cran-name version)))))) + (urls (cran-uri upstream-name version)))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." diff --git a/guix/monad-repl.scm b/guix/monad-repl.scm index ebd9151065..aefabdeebb 100644 --- a/guix/monad-repl.scm +++ b/guix/monad-repl.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -60,11 +60,10 @@ "Return the derivation of the default " (package-derivation store (default-guile) system)) -(define (store-monad-language) - "Return a compiler language for the store monad." - (let* ((store (open-connection)) - (guile (or (%guile-for-build) - (default-guile-derivation store)))) +(define (store-monad-language store) + "Return a compiler language for the store monad using STORE." + (let ((guile (or (%guile-for-build) + (default-guile-derivation store)))) (monad-language %store-monad (cut run-with-store store <> #:guile-for-build guile) @@ -84,10 +83,11 @@ Run EXP through the store monad." (define-meta-command ((enter-store-monad guix) repl) "enter-store-monad Enter a REPL for values in the store monad." - (let ((new (make-repl (store-monad-language)))) - ;; Force interpretation so that our specially-crafted language evaluator - ;; is actually used. - (repl-option-set! new 'interp #t) - (run-repl new))) + (with-store store + (let ((new (make-repl (store-monad-language store)))) + ;; Force interpretation so that our specially-crafted language evaluator + ;; is actually used. + (repl-option-set! new 'interp #t) + (run-repl new)))) ;;; monad-repl.scm ends here diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index f296f8a00e..e2cc965951 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mathieu Lirzin <mthl@openmailbox.org> ;;; ;;; This file is part of GNU Guix. @@ -593,7 +593,16 @@ Common Platform Enumeration (CPE) name." (define package-vulnerabilities (let ((lookup (delay (vulnerabilities->lookup-proc - (current-vulnerabilities))))) + ;; Catch networking errors to allow network-less + ;; operation. + (catch 'getaddrinfo-error + (lambda () + (current-vulnerabilities)) + (lambda (key errcode) + (warn (_ "failed to lookup NIST host: ~a~%") + (gai-strerror errcode)) + (warn (_ "assuming no CVE vulnerabilities~%")) + '())))))) (lambda (package) "Return a list of vulnerabilities affecting PACKAGE." ((force lookup) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index d0b5abd0e2..02eb600c43 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> @@ -230,21 +230,24 @@ specified in MANIFEST, a manifest object." ;;; Package specifications. ;;; -(define (find-packages-by-description rx) - "Return the list of packages whose name, synopsis, or description matches -RX." +(define (find-packages-by-description regexps) + "Return the list of packages whose name matches one of REGEXPS, or whose +synopsis or description matches all of REGEXPS." (define version<? (negate version>=?)) + (define (matches-all? str) + (every (cut regexp-exec <> str) regexps)) + + (define (matches-one? str) + (find (cut regexp-exec <> str) regexps)) + (sort (fold-packages (lambda (package result) - (define matches? - (cut regexp-exec rx <>)) - - (if (or (matches? (package-name package)) + (if (or (matches-one? (package-name package)) (and=> (package-synopsis package) - (compose matches? P_)) + (compose matches-all? P_)) (and=> (package-description package) - (compose matches? P_))) + (compose matches-all? P_))) (cons package result) result)) '()) @@ -696,11 +699,15 @@ processed, #f otherwise." (package-name p2)))))) #t)) - (('search regexp) - (let ((regexp (make-regexp* regexp regexp/icase))) + (('search _) + (let* ((patterns (filter-map (match-lambda + (('query 'search rx) rx) + (_ #f)) + opts)) + (regexps (map (cut make-regexp* <> regexp/icase) patterns))) (leave-on-EPIPE (for-each (cute package->recutils <> (current-output-port)) - (find-packages-by-description regexp))) + (find-packages-by-description regexps))) #t)) (('show requested-name) diff --git a/guix/ui.scm b/guix/ui.scm index 35a6671a07..6fd16bb9cc 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> @@ -301,7 +301,7 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." "Display version information for COMMAND and `(exit 0)'." (simple-format #t "~a (~a) ~a~%" command %guix-package-name %guix-version) - (display (_ "Copyright (C) 2015 the Guix authors + (display (_ "Copyright (C) 2016 the Guix authors License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html> This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law. diff --git a/guix/utils.scm b/guix/utils.scm index 7b589e68a8..c61f105513 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net> @@ -52,6 +52,7 @@ strip-keyword-arguments default-keyword-arguments substitute-keyword-arguments + ensure-keyword-arguments <location> location @@ -453,6 +454,45 @@ previous value of the keyword argument." (() (reverse before))))))) +(define (delkw kw lst) + "Remove KW and its associated value from LST, a keyword/value list such +as '(#:foo 1 #:bar 2)." + (let loop ((lst lst) + (result '())) + (match lst + (() + (reverse result)) + ((kw? value rest ...) + (if (eq? kw? kw) + (append (reverse result) rest) + (loop rest (cons* value kw? result))))))) + +(define (ensure-keyword-arguments args kw/values) + "Force the keywords arguments KW/VALUES in the keyword argument list ARGS. +For instance: + + (ensure-keyword-arguments '(#:foo 2) '(#:foo 2)) + => (#:foo 2) + + (ensure-keyword-arguments '(#:foo 2) '(#:bar 3)) + => (#:foo 2 #:bar 3) + + (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42)) + => (#:foo 42 #:bar 3) +" + (let loop ((args args) + (kw/values kw/values) + (result '())) + (match args + (() + (append (reverse result) kw/values)) + ((kw value rest ...) + (match (memq kw kw/values) + ((_ value . _) + (loop rest (delkw kw kw/values) (cons* value kw result))) + (#f + (loop rest kw/values (cons* value kw result)))))))) + (define* (nix-system->gnu-triplet #:optional (system (%current-system)) (vendor "unknown")) "Return a guess of the GNU triplet corresponding to Nix system |