03/20: packages: Define this-package-input and this-package-native-input.

[guix-commits]

mothacehe pushed a commit to branch wip-meson
in repository guix.

commit 9464d98d7f0f09adc3bc7b2fea47b19b99c649f4
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sun Jul 11 13:47:06 2021 +0200

    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 dfb4c68..d383c8c 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -118,6 +118,9 @@
             replace                               ;syntactic keyword
             modify-inputs
 
+            this-package-input
+            this-package-native-input
+
             package-direct-sources
             package-transitive-sources
             package-direct-inputs
@@ -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 9ec4dd1..2e1ca10 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: