From aaf9aa4824a8c30e5efc869d0e7dc34754892934 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Wed, 14 Jul 2021 13:12:50 +0200
Subject: packages: Define this-package-input and this-package-native-input.

These macros are intended to be used in build phases.
More precisely, (assoc-ref %build-inputs "input") can be
replaced by #$(this-package-input "input") or #+(this-package-native-input
"native-input") as appropriate.

* guix/packages.scm
  (package-input, package-native-input): New (unexported) procedures.
  (this-package-input, this-package-native-input): New macros.

Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
---
 guix/packages.scm  | 29 +++++++++++++++++++++++++++++
 tests/packages.scm | 34 ++++++++++++++++++++++++++++++++++
 2 files changed, 63 insertions(+)

diff --git a/guix/packages.scm b/guix/packages.scm
index dfb4c680be..d3fa72fd09 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -109,6 +109,9 @@
             deprecated-package
             package-field-location
 
+            this-package-input
+            this-package-native-input
+
             lookup-package-input
             lookup-package-native-input
             lookup-package-propagated-input
@@ -547,6 +550,32 @@ object."
         #f)))
     (_ #f)))
 
+(define (package-input package name)
+  "Return the package input NAME of PACKAGE--i.e., an input
+from the ‘inputs’ or ‘propagated-inputs’ field.  Native inputs are not
+considered.  If this input does not exist, return #f instead."
+  (and=> (or (assoc-ref (package-inputs package) name)
+             (assoc-ref (package-propagated-inputs package) name))
+         car))
+
+(define (package-native-input package name)
+  "Return the native package input NAME of PACKAGE--i.e., an input
+from the ‘native-inputs’ field. If this native input does not exist,
+return #f instead."
+  (and=> (assoc-ref (package-native-inputs package) name)
+         car))
+
+(define-syntax-rule (this-package-input name)
+  "Return the input NAME of the package being defined--i.e., an input
+from the ‘inputs’ or ‘propagated-inputs’ field.  Native inputs are not
+considered.  If this input does not exist, return #f instead."
+  (package-input this-package name))
+
+(define-syntax-rule (this-package-native-input name)
+  "Return the native package input NAME of the package being defined--i.e.,
+an input from the ‘native-inputs’ field.  If this native input does not
+exist, return #f instead."
+  (package-native-input this-package name))
 
 ;; Error conditions.
 
diff --git a/tests/packages.scm b/tests/packages.scm
index 9ec4dd1928..2e1ca10dc4 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1864,6 +1865,39 @@
   (package-location (specification->package "guile@2"))
   (specification->location "guile@2"))
 
+(test-eq "this-package-input, exists"
+  hello
+  (package-arguments
+   (dummy-package "a"
+     (inputs `(("hello" ,hello)))
+     (arguments (this-package-input "hello")))))
+
+(test-eq "this-package-input, exists in propagated-inputs"
+  hello
+  (package-arguments
+   (dummy-package "a"
+     (propagated-inputs `(("hello" ,hello)))
+     (arguments (this-package-input "hello")))))
+
+(test-eq "this-package-input, does not exist"
+  #f
+  (package-arguments
+   (dummy-package "a"
+     (arguments (this-package-input "hello")))))
+
+(test-eq "this-package-native-input, exists"
+  hello
+  (package-arguments
+   (dummy-package "a"
+     (native-inputs `(("hello" ,hello)))
+     (arguments (this-package-native-input "hello")))))
+
+(test-eq "this-package-native-input, does not exists"
+  #f
+  (package-arguments
+   (dummy-package "a"
+     (arguments (this-package-native-input "hello")))))
+
 (test-end "packages")
 
 ;;; Local Variables:
-- 
cgit v1.2.3