summaryrefslogtreecommitdiff
path: root/guix/import/print.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2021-11-17 23:24:42 +0100
committerLudovic Courtès <ludo@gnu.org>2021-11-17 23:43:14 +0100
commit3a317f7476f8c6012e166ff9f340f861938721c9 (patch)
tree946e398c37912cfc03be7306951ae87bfeb130fa /guix/import/print.scm
parente55547bf70384691712047912c793c517debd2ec (diff)
parent62e707d67caf1dab2af411a69ff8cec4b2dc686e (diff)
Merge branch 'master' into core-updates-frozen
Diffstat (limited to 'guix/import/print.scm')
-rw-r--r--guix/import/print.scm85
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)))))