06/09: import: print: Replace packages and origins in 'arguments'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 3756ce32674139376bcf11dac96bc562582088f7
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Nov 11 00:10:44 2021 +0100

    import: print: Replace packages and origins in 'arguments'.
    
    * guix/import/print.scm (package->code)[variable-reference]
    [object->code]: New procedures.
    [package-lists->code]: Rewrite in terms of 'object->code'.
    Pass the 'arguments' field through 'object->code'.
    * tests/print.scm (pkg-with-arguments, pkg-with-arguments-source): New
    variables.
    ("package with arguments"): New test.
---
 guix/import/print.scm | 50 ++++++++++++++++++++++++++++++--------------------
 tests/print.scm       | 23 +++++++++++++++++++++++
 2 files changed, 53 insertions(+), 20 deletions(-)

diff --git a/guix/import/print.scm b/guix/import/print.scm
index e04a664..767b052 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 ff0db46..1527251 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")