mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
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.
This commit is contained in:
parent
b2ed40c29f
commit
3756ce3267
2 changed files with 53 additions and 20 deletions
|
@ -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 @@ (define-module (guix import print)
|
|||
#: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 @@ (define (source->code source version)
|
|||
(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 @@ (define (package-lists->code lsts)
|
|||
'-build-system)))
|
||||
,@(match arguments
|
||||
(() '())
|
||||
(args `((arguments ,(list 'quasiquote args)))))
|
||||
(_ `((arguments
|
||||
,(list 'quasiquote (object->code arguments #t))))))
|
||||
,@(match outputs
|
||||
(("out") '())
|
||||
(outs `((outputs (list ,@outs)))))
|
||||
|
|
|
@ -120,6 +120,25 @@ (define-with-source pkg-with-origin-patch pkg-with-origin-patch-source
|
|||
(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-with-source pkg-with-origin-patch pkg-with-origin-patch-source
|
|||
`(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")
|
||||
|
|
Loading…
Reference in a new issue