diff options
| -rw-r--r-- | guix/import/print.scm | 50 | ||||
| -rw-r--r-- | tests/print.scm | 23 |
2 files changed, 53 insertions, 20 deletions
diff --git a/guix/import/print.scm b/guix/import/print.scm index e04a6647b4..767b0528d5 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2020 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,9 +32,6 @@ #:use-module (ice-9 match) #:export (package->code)) -;; FIXME: the quasiquoted arguments field may contain embedded package -;; objects, e.g. in #:disallowed-references; they will just be printed with -;; their usual #<package ...> representation, not as variable names. (define (package->code package) "Return an S-expression representing the source code that produces PACKAGE when evaluated." @@ -124,23 +122,34 @@ when evaluated." (source->code origin #f))) patches))))))))) + (define (variable-reference module name) + ;; FIXME: using '@ certainly isn't pretty, but it avoids having to import + ;; the individual package modules. + (list '@ module name)) + + (define (object->code obj quoted?) + (match obj + ((? package? package) + (let* ((module (package-module-name package)) + (name (variable-name package module))) + (if quoted? + (list 'unquote (variable-reference module name)) + (variable-reference module name)))) + ((? origin? origin) + (let ((code (source->code origin #f))) + (if quoted? + (list 'unquote code) + code))) + ((lst ...) + (let ((lst (map (cut object->code <> #t) lst))) + (if quoted? + lst + (list 'quasiquote lst)))) + (obj + obj))) + (define (package-lists->code lsts) - (list 'quasiquote - (map (match-lambda - ((? symbol? s) - (list (symbol->string s) (list 'unquote s))) - ((label (? package? pkg) . out) - (let ((mod (package-module-name pkg))) - (cons* label - ;; FIXME: using '@ certainly isn't pretty, but it - ;; avoids having to import the individual package - ;; modules. - (list 'unquote - (list '@ mod (variable-name pkg mod))) - out))) - ((label (? origin? origin)) - (list label (list 'unquote (source->code origin #f))))) - lsts))) + (list 'quasiquote (object->code lsts #t))) (let ((name (package-name package)) (version (package-version package)) @@ -176,7 +185,8 @@ when evaluated." '-build-system))) ,@(match arguments (() '()) - (args `((arguments ,(list 'quasiquote args))))) + (_ `((arguments + ,(list 'quasiquote (object->code arguments #t)))))) ,@(match outputs (("out") '()) (outs `((outputs (list ,@outs))))) diff --git a/tests/print.scm b/tests/print.scm index ff0db469ab..1527251b01 100644 --- a/tests/print.scm +++ b/tests/print.scm @@ -120,6 +120,25 @@ (description "This is a dummy package.") (license license:gpl3+))) +(define-with-source pkg-with-arguments pkg-with-arguments-source + (package + (name "test") + (version "1.2.3") + (source (origin + (method url-fetch) + (uri (string-append "file:///tmp/test-" + version ".tar.gz")) + (sha256 + (base32 + "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah")))) + (build-system (@ (guix build-system gnu) gnu-build-system)) + (arguments + `(#:disallowed-references (,(@ (gnu packages base) coreutils)))) + (home-page "http://gnu.org") + (synopsis "Dummy") + (description "This is a dummy package.") + (license license:gpl3+))) + (test-equal "simple package" `(define-public test ,pkg-source) (package->code pkg)) @@ -136,4 +155,8 @@ `(define-public test ,pkg-with-origin-patch-source) (package->code pkg-with-origin-patch)) +(test-equal "package with arguments" + `(define-public test ,pkg-with-arguments-source) + (package->code pkg-with-arguments)) + (test-end "print") |