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.master
parent
aa6921634b
commit
ff992fcfaf
|
@ -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))))
|
||||||
|
|
|
@ -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.")
|
||||||
|
|
Reference in New Issue