Merge branch 'master' into core-updates-frozen

1 files changed, 60 insertions, 25 deletions

diff --git a/guix/import/print.scm b/guix/import/print.scm
index c1739f35e3..66016145cb 100644
--- a/guix/import/print.scm
+++ b/guix/import/print.scm
@@ -26,6 +26,7 @@
   #:use-module (guix build-system)
   #:use-module (gnu packages)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (guix import utils)
   #:use-module (ice-9 control)
   #:use-module (ice-9 match)
@@ -39,9 +40,6 @@
            (_ #f))
          inputs))
 
-;; 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."
@@ -81,6 +79,11 @@ when evaluated."
       (file-type (quote ,(search-path-specification-file-type spec)))
       (file-pattern ,(search-path-specification-file-pattern spec))))
 
+  (define (factorized-uri-code uri version)
+    (match (factorize-uri uri version)
+      ((? string? uri) uri)
+      ((factorized ...) `(string-append ,@factorized))))
+
   (define (source->code source version)
     (let ((uri       (origin-uri source))
           (method    (origin-method source))
@@ -98,9 +101,14 @@ when evaluated."
                              (guix hg-download)
                              (guix svn-download)))
                       (procedure-name method)))
-         (uri (string-append ,@(match (factorize-uri uri version)
-                                 ((? string? uri) (list uri))
-                                 (factorized factorized))))
+         (uri ,(if version
+                   (match uri
+                     ((? string? uri)
+                      (factorized-uri-code uri version))
+                     ((lst ...)
+                      `(list
+                        ,@(map (cut factorized-uri-code <> version) uri))))
+                   uri))
          ,(if (equal? (content-hash-algorithm hash) 'sha256)
               `(sha256 (base32 ,(bytevector->nix-base32-string
                                  (content-hash-value hash))))
@@ -110,36 +118,62 @@ when evaluated."
          ;; FIXME: in order to be able to throw away the directory prefix,
          ;; we just assume that the patch files can be found with
          ;; "search-patches".
-         ,@(if (null? patches) '()
-               `((patches (search-patches ,@(map basename patches))))))))
+         ,@(cond ((null? patches)
+                  '())
+                 ((every string? patches)
+                  `((patches (search-patches ,@(map basename patches)))))
+                 (else
+                  `((patches (list ,@(map (match-lambda
+                                            ((? string? file)
+                                             `(search-patch ,file))
+                                            ((? origin? origin)
+                                             (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 (inputs->code inputs)
     (if (redundant-input-labels? inputs)
         `(list ,@(map (match-lambda    ;no need for input labels ("new style")
                         ((_ package)
-                         (let ((module (package-module-name package)))
-                           `(@ ,module ,(variable-name package module))))
+                         (let* ((module (package-module-name package))
+                                (name   (variable-name package module)))
+                           (variable-reference module name)))
                         ((_ package output)
-                         (let ((module (package-module-name package)))
+                         (let* ((module (package-module-name package))
+                                (name   (variable-name package module)))
                            (list 'quasiquote
                                  (list
                                   (list 'unquote
-                                        `(@ ,module
-                                            ,(variable-name package module)))
+                                        (variable-reference module name))
                                   output)))))
                       inputs))
         (list 'quasiquote                  ;preserve input labels (deprecated)
-              (map (match-lambda
-                     ((label 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))))
-                   inputs))))
+              (object->code inputs #t))))
 
   (let ((name                (package-name package))
         (version             (package-version package))
@@ -175,7 +209,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)))))