From 7ca87354db53fd1e1a7a3dfeddb9a598ea064bbe Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Sep 2016 23:41:53 +0200 Subject: Add (guix modules). * guix/modules.scm, tests/modules.scm: New files. * Makefile.am (MODULES, SCM_TESTS): Add them. * doc/guix.texi (G-Expressions): Add an example of 'source-module-closure'. --- tests/modules.scm | 45 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) create mode 100644 tests/modules.scm (limited to 'tests') diff --git a/tests/modules.scm b/tests/modules.scm new file mode 100644 index 0000000000..04945e531b --- /dev/null +++ b/tests/modules.scm @@ -0,0 +1,45 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès +;;; +;;; 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 . + +(define-module (test-modules) + #:use-module (guix modules) + #:use-module ((guix build-system gnu) #:select (%gnu-build-system-modules)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(test-begin "modules") + +(test-assert "closure of (guix build gnu-build-system)" + (lset= equal? + (live-module-closure '((guix build gnu-build-system))) + (source-module-closure '((guix build gnu-build-system))) + %gnu-build-system-modules + (source-module-closure %gnu-build-system-modules) + (live-module-closure %gnu-build-system-modules))) + +(test-assert "closure of (gnu build install)" + (lset= equal? + (live-module-closure '((gnu build install))) + (source-module-closure '((gnu build install))))) + +(test-assert "closure of (gnu build vm)" + (lset= equal? + (live-module-closure '((gnu build vm))) + (source-module-closure '((gnu build vm))))) + +(test-end) -- cgit v1.2.3 From c8c25704aeb2e5fa4feb6a86235f9565738eea99 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Sep 2016 20:19:21 +0200 Subject: profiles: Add manifest-transaction helper procedures. * guix/profiles.scm (manifest-transaction-install-entry) (manifest-transaction-remove-pattern) (manifest-transaction-null?): New procedures. * tests/profiles.scm ("manifest-transaction-null?"): New test. --- guix/profiles.scm | 27 ++++++++++++++++++++++++++- tests/profiles.scm | 3 +++ 2 files changed, 29 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/profiles.scm b/guix/profiles.scm index cd448e3f25..ac2fa051b2 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -78,6 +78,9 @@ (define-module (guix profiles) manifest-transaction? manifest-transaction-install manifest-transaction-remove + manifest-transaction-install-entry + manifest-transaction-remove-pattern + manifest-transaction-null? manifest-perform-transaction manifest-transaction-effects @@ -383,6 +386,28 @@ (define-record-type* manifest-transaction (remove manifest-transaction-remove ; list of (default '()))) +(define (manifest-transaction-install-entry entry transaction) + "Augment TRANSACTION's set of installed packages with ENTRY, a +." + (manifest-transaction + (inherit transaction) + (install + (cons entry (manifest-transaction-install transaction))))) + +(define (manifest-transaction-remove-pattern pattern transaction) + "Add PATTERN to TRANSACTION's list of packages to remove." + (manifest-transaction + (inherit transaction) + (remove + (cons pattern (manifest-transaction-remove transaction))))) + +(define (manifest-transaction-null? transaction) + "Return true if TRANSACTION has no effect---i.e., it neither installs nor +remove software." + (match transaction + (($ () ()) #t) + (($ _ _) #f))) + (define (manifest-transaction-effects manifest transaction) "Compute the effect of applying TRANSACTION to MANIFEST. Return 4 values: the list of packages that would be removed, installed, upgraded, or downgraded @@ -424,7 +449,7 @@ (define (manifest-entry->pattern entry) downgrade))))))) (define (manifest-perform-transaction manifest transaction) - "Perform TRANSACTION on MANIFEST and return new manifest." + "Perform TRANSACTION on MANIFEST and return the new manifest." (let ((install (manifest-transaction-install transaction)) (remove (manifest-transaction-remove transaction))) (manifest-add (manifest-remove manifest remove) diff --git a/tests/profiles.scm b/tests/profiles.scm index 028d7b6fb4..f9c2f5499e 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -187,6 +187,9 @@ (define glibc (and (null? remove) (null? install) (null? downgrade) (equal? (list (cons guile-2.0.9 guile-2.0.9)) upgrade))))) +(test-assert "manifest-transaction-null?" + (manifest-transaction-null? (manifest-transaction))) + (test-assertm "profile-derivation" (mlet* %store-monad ((entry -> (package->manifest-entry %bootstrap-guile)) -- cgit v1.2.3 From 5239f3d90841de767c86d0f3a7975b8d799d583d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Sep 2016 22:28:12 +0200 Subject: guix package: Build up the transaction incrementally. * guix/scripts/package.scm (upgraded-manifest-entry): Rename to... (transaction-upgrade-entry): ... this. Add 'transaction' parameter and return a transaction. (options->installable): Likewise. [to-upgrade]: Rename to... [upgraded]: ... this, and change to be a transaction. Return a transaction. (options->removable): Likewise. (process-actions): Adjust accordingly. * tests/packages.scm ("transaction-upgrade-entry, zero upgrades") ("transaction-upgrade-entry, one upgrade"): New tests. --- guix/scripts/package.scm | 100 +++++++++++++++++++++++++++-------------------- tests/packages.scm | 29 ++++++++++++++ 2 files changed, 87 insertions(+), 42 deletions(-) (limited to 'tests') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 14a0895b43..dc5fcba922 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -261,25 +261,30 @@ (define (matches-one? str) ((<) #t) (else #f))))) -(define (upgraded-manifest-entry entry) - "Return either a corresponding to an upgrade of ENTRY, or -#f if no upgrade was found." +(define (transaction-upgrade-entry entry transaction) + "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a +." (match entry (($ name version output (? string? path)) (match (vhash-assoc name (find-newest-available-packages)) ((_ candidate-version pkg . rest) (case (version-compare candidate-version version) ((>) - (package->manifest-entry pkg output)) + (manifest-transaction-install-entry + (package->manifest-entry pkg output) + transaction)) ((<) - #f) + transaction) ((=) (let ((candidate-path (derivation->output-path (package-derivation (%store) pkg)))) - (and (not (string=? path candidate-path)) - (package->manifest-entry pkg output)))))) + (if (string=? path candidate-path) + transaction + (manifest-transaction-install-entry + (package->manifest-entry pkg output) + transaction)))))) (#f - #f))))) + transaction))))) ;;; @@ -559,17 +564,20 @@ (define (store-item->manifest-entry item) (output #f) (item item)))) -(define (options->installable opts manifest) +(define (options->installable opts manifest transaction) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', -return the new list of manifest entries." +return an variant of TRANSACTION that accounts for the specified installations +and upgrades." (define upgrade? (options->upgrade-predicate opts)) - (define to-upgrade - (filter-map (lambda (entry) - (and (upgrade? (manifest-entry-name entry)) - (upgraded-manifest-entry entry))) - (manifest-entries manifest))) + (define upgraded + (fold (lambda (entry transaction) + (if (upgrade? (manifest-entry-name entry)) + (transaction-upgrade-entry entry transaction) + transaction)) + transaction + (manifest-entries manifest))) (define to-install (filter-map (match-lambda @@ -586,23 +594,29 @@ (define to-install (_ #f)) opts)) - (append to-upgrade to-install)) - -(define (options->removable options manifest) - "Given options, return the list of manifest patterns of packages to be -removed from MANIFEST." - (filter-map (match-lambda - (('remove . spec) - (call-with-values - (lambda () - (package-specification->name+version+output spec)) - (lambda (name version output) - (manifest-pattern - (name name) - (version version) - (output output))))) - (_ #f)) - options)) + (fold manifest-transaction-install-entry + upgraded + to-install)) + +(define (options->removable options manifest transaction) + "Given options, return a variant of TRANSACTION augmented with the list of +patterns of packages to remove." + (fold (lambda (opt transaction) + (match opt + (('remove . spec) + (call-with-values + (lambda () + (package-specification->name+version+output spec)) + (lambda (name version output) + (manifest-transaction-remove-pattern + (manifest-pattern + (name name) + (version version) + (output output)) + transaction)))) + (_ transaction))) + transaction + options)) (define (register-gc-root store profile) "Register PROFILE, a profile generation symlink, as a GC root, unless it @@ -813,16 +827,18 @@ (define (transform-entry entry) opts) ;; Then, process normal package installation/removal/upgrade. - (let* ((manifest (profile-manifest profile)) - (install (options->installable opts manifest)) - (remove (options->removable opts manifest)) - (transaction (manifest-transaction - (install (map transform-entry install)) - (remove remove))) - (new (manifest-perform-transaction manifest transaction))) - - (unless (and (null? install) (null? remove)) - (show-manifest-transaction store manifest transaction + (let* ((manifest (profile-manifest profile)) + (step1 (options->installable opts manifest + (manifest-transaction))) + (step2 (options->removable opts manifest step1)) + (step3 (manifest-transaction + (inherit step2) + (install (map transform-entry + (manifest-transaction-install step2))))) + (new (manifest-perform-transaction manifest step3))) + + (unless (manifest-transaction-null? step3) + (show-manifest-transaction store manifest step3 #:dry-run? dry-run?) (build-and-use-profile store profile new #:bootstrap? bootstrap? diff --git a/tests/packages.scm b/tests/packages.scm index daceea5d62..456e691962 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -49,6 +49,7 @@ (define-module (test-packages) #:use-module (srfi srfi-35) #:use-module (srfi srfi-64) #:use-module (rnrs io ports) + #:use-module (ice-9 vlist) #:use-module (ice-9 regex) #:use-module (ice-9 match)) @@ -83,6 +84,34 @@ (define %store (and (hidden-package? (hidden-package (dummy-package "foo"))) (not (hidden-package? (dummy-package "foo"))))) +(test-assert "transaction-upgrade-entry, zero upgrades" + (let* ((old (dummy-package "foo" (version "1"))) + (tx (mock ((gnu packages) find-newest-available-packages + (const vlist-null)) + ((@@ (guix scripts package) transaction-upgrade-entry) + (manifest-entry + (inherit (package->manifest-entry old)) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction))))) + (manifest-transaction-null? tx))) + +(test-assert "transaction-upgrade-entry, one upgrade" + (let* ((old (dummy-package "foo" (version "1"))) + (new (dummy-package "foo" (version "2"))) + (tx (mock ((gnu packages) find-newest-available-packages + (const (vhash-cons "foo" (list "2" new) vlist-null))) + ((@@ (guix scripts package) transaction-upgrade-entry) + (manifest-entry + (inherit (package->manifest-entry old)) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction))))) + (and (match (manifest-transaction-install tx) + ((($ "foo" "2" "out" item)) + (eq? item new))) + (null? (manifest-transaction-remove tx))))) + (test-assert "package-field-location" (let () (define (goto port line column) -- cgit v1.2.3 From 01afdab89c6a91f4cd05d3c4f4ff95a0402703eb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Sep 2016 23:14:07 +0200 Subject: packages: Add 'package-superseded' and associated support. This provides a way to mark a package as superseded by another one. Upgrades replace superseded packages with their replacement. * guix/packages.scm (package-superseded, deprecated-package): New procedures. * gnu/packages.scm (%find-package): Check for 'package-superseded'. * guix/scripts/package.scm (transaction-upgrade-entry)[supersede]: New procedure. Call it when 'package-superseded' is true. * tests/guix-build.sh: Add test for a superseded package. * tests/packages.scm ("package-superseded") ("transaction-upgrade-entry, superseded package"): New tests. --- gnu/packages.scm | 9 ++++++++- guix/packages.scm | 14 ++++++++++++++ guix/scripts/package.scm | 46 +++++++++++++++++++++++++++++++--------------- tests/guix-build.sh | 6 ++++++ tests/packages.scm | 30 ++++++++++++++++++++++++++++++ 5 files changed, 89 insertions(+), 16 deletions(-) (limited to 'tests') diff --git a/gnu/packages.scm b/gnu/packages.scm index 68a9eef2ad..5d60423a3a 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -305,7 +305,14 @@ (define* (%find-package spec name version #:key fallback?) (when fallback? (warning (_ "deprecated NAME-VERSION syntax; \ use NAME@VERSION instead~%"))) - pkg) + + (match (package-superseded pkg) + ((? package? new) + (info (_ "package '~a' has been superseded by '~a'~%") + (package-name pkg) (package-name new)) + new) + (#f + pkg))) (_ (if version (leave (_ "~A: package not found for version ~a~%") name version) diff --git a/guix/packages.scm b/guix/packages.scm index d544c34cf8..afbafc70a7 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -83,6 +83,8 @@ (define-module (guix packages) package-location hidden-package hidden-package? + package-superseded + deprecated-package package-field-location package-direct-sources @@ -306,6 +308,18 @@ (define (hidden-package? p) interfaces." (assoc-ref (package-properties p) 'hidden?)) +(define (package-superseded p) + "Return the package the supersedes P, or #f if P is still current." + (assoc-ref (package-properties p) 'superseded)) + +(define (deprecated-package old-name p) + "Return a package called OLD-NAME and marked as superseded by P, a package +object." + (package + (inherit p) + (name old-name) + (properties `((superseded . ,p))))) + (define (package-field-location package field) "Return the source code location of the definition of FIELD for PACKAGE, or #f if it could not be determined." diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index dc5fcba922..b87aee0be9 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -264,25 +264,41 @@ (define (matches-one? str) (define (transaction-upgrade-entry entry transaction) "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a ." + (define (supersede old new) + (info (_ "package '~a' has been superseded by '~a'~%") + (manifest-entry-name old) (package-name new)) + (manifest-transaction-install-entry + (package->manifest-entry new (manifest-entry-output old)) + (manifest-transaction-remove-pattern + (manifest-pattern + (name (manifest-entry-name old)) + (version (manifest-entry-version old)) + (output (manifest-entry-output old))) + transaction))) + (match entry (($ name version output (? string? path)) (match (vhash-assoc name (find-newest-available-packages)) ((_ candidate-version pkg . rest) - (case (version-compare candidate-version version) - ((>) - (manifest-transaction-install-entry - (package->manifest-entry pkg output) - transaction)) - ((<) - transaction) - ((=) - (let ((candidate-path (derivation->output-path - (package-derivation (%store) pkg)))) - (if (string=? path candidate-path) - transaction - (manifest-transaction-install-entry - (package->manifest-entry pkg output) - transaction)))))) + (match (package-superseded pkg) + ((? package? new) + (supersede entry new)) + (#f + (case (version-compare candidate-version version) + ((>) + (manifest-transaction-install-entry + (package->manifest-entry pkg output) + transaction)) + ((<) + transaction) + ((=) + (let ((candidate-path (derivation->output-path + (package-derivation (%store) pkg)))) + (if (string=? path candidate-path) + transaction + (manifest-transaction-install-entry + (package->manifest-entry pkg output) + transaction)))))))) (#f transaction))))) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 6d4f97019a..9e9788bca0 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -93,6 +93,9 @@ cat > "$module_dir/foo.scm"<package "foo") + (and (eq? new (specification->package "foo")) + (eq? new (specification->package+output "foo"))))))) + (test-assert "transaction-upgrade-entry, zero upgrades" (let* ((old (dummy-package "foo" (version "1"))) (tx (mock ((gnu packages) find-newest-available-packages @@ -112,6 +121,27 @@ (define %store (eq? item new))) (null? (manifest-transaction-remove tx))))) +(test-assert "transaction-upgrade-entry, superseded package" + (let* ((old (dummy-package "foo" (version "1"))) + (new (dummy-package "bar" (version "2"))) + (dep (deprecated-package "foo" new)) + (tx (mock ((gnu packages) find-newest-available-packages + (const (vhash-cons "foo" (list "2" dep) vlist-null))) + ((@@ (guix scripts package) transaction-upgrade-entry) + (manifest-entry + (inherit (package->manifest-entry old)) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction))))) + (and (match (manifest-transaction-install tx) + ((($ "bar" "2" "out" item)) + (eq? item new))) + (match (manifest-transaction-remove tx) + (((? manifest-pattern? pattern)) + (and (string=? (manifest-pattern-name pattern) "foo") + (string=? (manifest-pattern-version pattern) "1") + (string=? (manifest-pattern-output pattern) "out"))))))) + (test-assert "package-field-location" (let () (define (goto port line column) -- cgit v1.2.3 From 392a4e122350367c4b4ac331db5ec28360c7f38c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 6 Sep 2016 08:28:33 +0200 Subject: guix hash: Add --exclude-vcs option. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/hash.scm (show-help): Add help text for --exclude-vcs option. (%options): Add --exclude-vcs option. (guix-hash): Handle exclude-vcs option. * doc/guix.texi ("Invoking guix hash"): Update doc. * tests/guix-hash.sh: Add test. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 10 +++++++--- guix/scripts/hash.scm | 25 ++++++++++++++++++++----- tests/guix-hash.sh | 16 ++++++++++++++++ 3 files changed, 43 insertions(+), 8 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 59bc5d8ee0..655dcfa277 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4678,7 +4678,7 @@ The general syntax is: guix hash @var{option} @var{file} @end example -@command{guix hash} has the following option: +@command{guix hash} has the following options: @table @code @@ -4706,6 +4706,11 @@ hash (@pxref{Invoking guix archive}). @c FIXME: Replace xref above with xref to an ``Archive'' section when @c it exists. +@item --exclude-vcs +@itemx -x +When combined with @option{--recursive}, exclude version control system +directories (@file{.bzr}, @file{.git}, @file{.hg}, etc.) + @vindex git-fetch As an example, here is how you would compute the hash of a Git checkout, which is useful when using the @code{git-fetch} method (@pxref{origin @@ -4714,8 +4719,7 @@ Reference}): @example $ git clone http://example.org/foo.git $ cd foo -$ rm -rf .git -$ guix hash -r . +$ guix hash -rx . @end example @end table diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index d44095377b..a57602ab51 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2016 Jan Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. ;;; @@ -48,6 +49,8 @@ (define (show-help) Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) + (format #t (_ " + -x, --exclude-vcs exclude version control directories")) (format #t (_ " -f, --format=FMT write the hash in the given format")) (format #t (_ " @@ -62,7 +65,10 @@ (define (show-help) (define %options ;; Specification of the command-line options. - (list (option '(#\f "format") #t #f + (list (option '(#\x "exclude-vcs") #f #f + (lambda (opt name arg result) + (alist-cons 'exclude-vcs? #t result))) + (option '(#\f "format") #t #f (lambda (opt name arg result) (define fmt-proc (match arg @@ -81,7 +87,6 @@ (define fmt-proc (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'recursive? #t result))) - (option '(#\h "help") #f #f (lambda args (show-help) @@ -107,13 +112,23 @@ (define (parse-options) (alist-cons 'argument arg result)) %default-options)) + (define (vcs-file? file stat) + (case (stat:type stat) + ((directory) + (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) + (else + #f))) + (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) value) (_ #f)) (reverse opts))) - (fmt (assq-ref opts 'format))) + (fmt (assq-ref opts 'format)) + (select? (if (assq-ref opts 'exclude-vcs?) + (negate vcs-file?) + (const #t)))) (define (file-hash file) ;; Compute the hash of FILE. @@ -121,7 +136,7 @@ (define (file-hash file) (with-error-handling (if (assoc-ref opts 'recursive?) (let-values (((port get-hash) (open-sha256-port))) - (write-file file port) + (write-file file port #:select? select?) (flush-output-port port) (get-hash)) (call-with-input-file file port-sha256)))) diff --git a/tests/guix-hash.sh b/tests/guix-hash.sh index 23df01d417..44213d51af 100644 --- a/tests/guix-hash.sh +++ b/tests/guix-hash.sh @@ -1,5 +1,6 @@ # GNU Guix --- Functional package management for GNU # Copyright © 2013, 2014 Ludovic Courtès +# Copyright © 2016 Jan Nieuwenhuizen # # This file is part of GNU Guix. # @@ -46,3 +47,18 @@ then false; else true; fi # the archive format doesn't support. if guix hash -r /dev/null then false; else true; fi + +# Adding a .git directory +mkdir "$tmpdir/.git" +touch "$tmpdir/.git/foo" + +# ...changes the hash +test `guix hash -r $tmpdir` = 0a50z04zyzf7pidwxv0nwbj82pgzbrhdy9562kncnvkcfvb48m59 + +# ...but remains the same when using `-x' +test `guix hash -r $tmpdir -x` = 10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p + +# Without '-r', this should fail. +if guix hash "$tmpdir" +then false; else true; fi + -- cgit v1.2.3 From a9e5e92f940381e3a4ee828c6d8ff22a73067e17 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 9 Sep 2016 22:46:36 +0200 Subject: gexp: Add 'file-append'. * guix/gexp.scm (): New record type. (file-append): New procedure. (file-append-compiler): New gexp compiler. * tests/gexp.scm ("file-append", "file-append, output") ("file-append, nested", "gexp->file + file-append"): New tests. * doc/guix.texi (G-Expressions): Use it in 'nscd' and 'list-files' examples. Document 'file-append'. --- doc/guix.texi | 35 +++++++++++++++++++++++++++++++---- guix/gexp.scm | 29 +++++++++++++++++++++++++++++ tests/gexp.scm | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 113 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 3923627c79..6d3361878b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3985,7 +3985,7 @@ The @code{local-file}, @code{plain-file}, @code{computed-file}, these objects lead to a file in the store. Consider this G-expression: @example -#~(system* (string-append #$glibc "/sbin/nscd") "-f" +#~(system* #$(file-append glibc "/sbin/nscd") "-f" #$(local-file "/tmp/my-nscd.conf")) @end example @@ -4044,7 +4044,7 @@ command: (use-modules (guix gexp) (gnu packages base)) (gexp->script "list-files" - #~(execl (string-append #$coreutils "/bin/ls") + #~(execl #$(file-append coreutils "/bin/ls") "ls")) @end example @@ -4055,8 +4055,7 @@ executable file @file{/gnu/store/@dots{}-list-files} along these lines: @example #!/gnu/store/@dots{}-guile-2.0.11/bin/guile -ds !# -(execl (string-append "/gnu/store/@dots{}-coreutils-8.22"/bin/ls") - "ls") +(execl "/gnu/store/@dots{}-coreutils-8.22"/bin/ls" "ls") @end example @end deffn @@ -4126,6 +4125,34 @@ as in: This is the declarative counterpart of @code{text-file*}. @end deffn +@deffn {Scheme Procedure} file-append @var{obj} @var{suffix} @dots{} +Return a file-like object that expands to the concatenation of @var{obj} +and @var{suffix}, where @var{obj} is a lowerable object and each +@var{suffix} is a string. + +As an example, consider this gexp: + +@example +(gexp->script "run-uname" + #~(system* #$(file-append coreutils + "/bin/uname"))) +@end example + +The same effect could be achieved with: + +@example +(gexp->script "run-uname" + #~(system* (string-append #$coreutils + "/bin/uname"))) +@end example + +There is one difference though: in the @code{file-append} case, the +resulting script contains the absolute file name as a string, whereas in +the second case, the resulting script contains a @code{(string-append +@dots{})} expression to construct the file name @emph{at run time}. +@end deffn + + Of course, in addition to gexps embedded in ``host'' code, there are also modules containing build tools. To make it clear that they are meant to be used in the build stratum, these modules are kept in the diff --git a/guix/gexp.scm b/guix/gexp.scm index 8d380ec95b..7e2ecf6c33 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -63,6 +63,11 @@ (define-module (guix gexp) scheme-file-name scheme-file-gexp + file-append + file-append? + file-append-base + file-append-suffix + gexp->derivation gexp->file gexp->script @@ -368,6 +373,30 @@ (define-gexp-compiler (scheme-file-compiler (file scheme-file?) (($ name gexp) (gexp->file name gexp)))) +;; Appending SUFFIX to BASE's output file name. +(define-record-type + (%file-append base suffix) + file-append? + (base file-append-base) ; | | ... + (suffix file-append-suffix)) ;list of strings + +(define (file-append base . suffix) + "Return a object that expands to the concatenation of BASE and +SUFFIX." + (%file-append base suffix)) + +(define-gexp-compiler file-append-compiler file-append? + compiler => (lambda (obj system target) + (match obj + (($ base _) + (lower-object base system #:target target)))) + expander => (lambda (obj lowered output) + (match obj + (($ base suffix) + (let* ((expand (lookup-expander base)) + (base (expand base lowered output))) + (string-append base (string-concatenate suffix))))))) + ;;; ;;; Inputs & outputs. diff --git a/tests/gexp.scm b/tests/gexp.scm index 03a64fa6bb..214e7a5302 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -207,6 +207,47 @@ (define (match-input thing) (e3 `(display ,txt))) (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp)))))) +(test-assert "file-append" + (let* ((drv (package-derivation %store %bootstrap-guile)) + (fa (file-append %bootstrap-guile "/bin/guile")) + (exp #~(here we go #$fa))) + (and (match (gexp->sexp* exp) + (('here 'we 'go (? string? result)) + (string=? result + (string-append (derivation->output-path drv) + "/bin/guile")))) + (match (gexp-inputs exp) + (((thing "out")) + (eq? thing fa)))))) + +(test-assert "file-append, output" + (let* ((drv (package-derivation %store glibc)) + (fa (file-append glibc "/lib" "/debug")) + (exp #~(foo #$fa:debug))) + (and (match (gexp->sexp* exp) + (('foo (? string? result)) + (string=? result + (string-append (derivation->output-path drv "debug") + "/lib/debug")))) + (match (gexp-inputs exp) + (((thing "debug")) + (eq? thing fa)))))) + +(test-assert "file-append, nested" + (let* ((drv (package-derivation %store glibc)) + (dir (file-append glibc "/bin")) + (slash (file-append dir "/")) + (file (file-append slash "getent")) + (exp #~(foo #$file))) + (and (match (gexp->sexp* exp) + (('foo (? string? result)) + (string=? result + (string-append (derivation->output-path drv) + "/bin/getent")))) + (match (gexp-inputs exp) + (((thing "out")) + (eq? thing file)))))) + (test-assert "ungexp + ungexp-native" (let* ((exp (gexp (list (ungexp-native %bootstrap-guile) (ungexp coreutils) @@ -338,6 +379,18 @@ (define (match-input thing) (return (and (equal? sexp (call-with-input-file out read)) (equal? (list guile) refs))))) +(test-assertm "gexp->file + file-append" + (mlet* %store-monad ((exp -> #~#$(file-append %bootstrap-guile + "/bin/guile")) + (guile (package-file %bootstrap-guile)) + (drv (gexp->file "foo" exp)) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv))) + (refs ((store-lift references) out))) + (return (and (equal? (string-append guile "/bin/guile") + (call-with-input-file out read)) + (equal? (list guile) refs))))) + (test-assertm "gexp->derivation" (mlet* %store-monad ((file (text-file "foo" "Hello, world!")) (exp -> (gexp -- cgit v1.2.3 From 11e296ef3092de1e5b659822d4dad4465abad34f Mon Sep 17 00:00:00 2001 From: David Craven Date: Thu, 22 Sep 2016 11:35:13 +0200 Subject: import: utils: Refactor license->symbol. * guix/import/utils.scm (license->symbol): Work for all licenses. * tests/import-utils.scm (license->symbol): Add test. --- guix/import/utils.scm | 14 +++++--------- tests/import-utils.scm | 5 +++++ 2 files changed, 10 insertions(+), 9 deletions(-) (limited to 'tests') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index ce0ba99fc0..e4059ca114 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Ludovic Courtès ;;; Copyright © 2016 Jelle Licht +;;; Copyright © 2016 David Craven ;;; ;;; This file is part of GNU Guix. ;;; @@ -185,15 +186,10 @@ (define (spdx-string->license str) (define (license->symbol license) "Convert license to a symbol representing the variable the object is bound to in the (guix licenses) module, or #f if there is no such known license." - ;; TODO: Traverse list public variables in (guix licenses) instead so we - ;; don't have to maintain a list manualy. - (assoc-ref `((,license:lgpl2.0 . license:lgpl2.0) - (,license:gpl3 . license:gpl3) - (,license:bsd-3 . license:bsd-3) - (,license:expat . license:expat) - (,license:public-domain . license:public-domain) - (,license:asl2.0 . license:asl2.0)) - license)) + (define licenses + (module-map (lambda (sym var) `(,(variable-ref var) . ,sym)) + (resolve-interface '(guix licenses) #:prefix 'license:))) + (assoc-ref licenses license)) (define (snake-case str) "Return a downcased version of the string STR where underscores are replaced diff --git a/tests/import-utils.scm b/tests/import-utils.scm index 3b11875c4a..8d44b9e0e2 100644 --- a/tests/import-utils.scm +++ b/tests/import-utils.scm @@ -20,6 +20,7 @@ (define-module (test-import-utils) #:use-module (guix tests) #:use-module (guix import utils) + #:use-module ((guix licenses) #:prefix license:) #:use-module (srfi srfi-64)) (test-begin "import-utils") @@ -33,4 +34,8 @@ (define-module (test-import-utils) "This package provides a function to establish world peace" (beautify-description "A function to establish world peace")) +(test-equal "license->symbol" + 'license:lgpl2.0 + (license->symbol license:lgpl2.0)) + (test-end "import-utils") -- cgit v1.2.3