aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/import/print.scm50
-rw-r--r--tests/print.scm23
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")