import: print: Emit new-style package inputs when possible.

* guix/import/print.scm (redundant-input-labels?): New procedure.
(package->code)[package-lists->code]: Rename to...
[inputs->code]: ... this.  When 'redundant-input-labels?' returns true,
emit label-less inputs.  Adjust callers to new name.
* tests/print.scm (pkg-with-inputs): Adjust accordingly.
This commit is contained in:
Ludovic Courtès 2021-06-30 16:00:37 +02:00
parent aa6921634b
commit ff992fcfaf
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 41 additions and 20 deletions

View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2017, 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -30,6 +31,14 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (package->code)) #:export (package->code))
(define (redundant-input-labels? inputs)
"Return #t if input labels in the INPUTS list are redundant."
(every (match-lambda
((label (? package? package) . _)
(string=? label (package-name package)))
(_ #f))
inputs))
;; FIXME: the quasiquoted arguments field may contain embedded package ;; FIXME: the quasiquoted arguments field may contain embedded package
;; objects, e.g. in #:disallowed-references; they will just be printed with ;; objects, e.g. in #:disallowed-references; they will just be printed with
;; their usual #<package ...> representation, not as variable names. ;; their usual #<package ...> representation, not as variable names.
@ -104,21 +113,33 @@ when evaluated."
,@(if (null? patches) '() ,@(if (null? patches) '()
`((patches (search-patches ,@(map basename patches)))))))) `((patches (search-patches ,@(map basename patches))))))))
(define (package-lists->code lsts) (define (inputs->code inputs)
(list 'quasiquote (if (redundant-input-labels? inputs)
(map (match-lambda `(list ,@(map (match-lambda ;no need for input labels ("new style")
((? symbol? s) ((_ package)
(list (symbol->string s) (list 'unquote s))) (let ((module (package-module-name package)))
((label pkg . out) `(@ ,module ,(variable-name package module))))
(let ((mod (package-module-name pkg))) ((_ package output)
(cons* label (let ((module (package-module-name package)))
;; FIXME: using '@ certainly isn't pretty, but it (list 'quasiquote
;; avoids having to import the individual package (list
;; modules. (list 'unquote
(list 'unquote `(@ ,module
(list '@ mod (variable-name pkg mod))) ,(variable-name package module)))
out)))) output)))))
lsts))) 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))))
(let ((name (package-name package)) (let ((name (package-name package))
(version (package-version package)) (version (package-version package))
@ -160,13 +181,13 @@ when evaluated."
(outs `((outputs (list ,@outs))))) (outs `((outputs (list ,@outs)))))
,@(match native-inputs ,@(match native-inputs
(() '()) (() '())
(pkgs `((native-inputs ,(package-lists->code pkgs))))) (pkgs `((native-inputs ,(inputs->code pkgs)))))
,@(match inputs ,@(match inputs
(() '()) (() '())
(pkgs `((inputs ,(package-lists->code pkgs))))) (pkgs `((inputs ,(inputs->code pkgs)))))
,@(match propagated-inputs ,@(match propagated-inputs
(() '()) (() '())
(pkgs `((propagated-inputs ,(package-lists->code pkgs))))) (pkgs `((propagated-inputs ,(inputs->code pkgs)))))
,@(if (lset= string=? supported-systems %supported-systems) ,@(if (lset= string=? supported-systems %supported-systems)
'() '()
`((supported-systems (list ,@supported-systems)))) `((supported-systems (list ,@supported-systems))))

View File

@ -60,8 +60,8 @@
(base32 (base32
"070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah")))) "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah"))))
(build-system (@ (guix build-system gnu) gnu-build-system)) (build-system (@ (guix build-system gnu) gnu-build-system))
(inputs `(("coreutils" ,(@ (gnu packages base) coreutils)) (inputs (list (@ (gnu packages base) coreutils)
("glibc" ,(@ (gnu packages base) glibc) "debug"))) `(,(@ (gnu packages base) glibc) "debug")))
(home-page "http://gnu.org") (home-page "http://gnu.org")
(synopsis "Dummy") (synopsis "Dummy")
(description "This is a dummy package.") (description "This is a dummy package.")