[bug#65062] [PATCH v2 core-updates 2/2] packages: Lookup inputs by specification.

[Hilton Chain via Guix-patches via <guix-patches@gnu.org>]

* guix/packages.scm (specification->inputs): New procedure.
(lookup-input,replace-input): Use it.
(delete-input): New procedure.
(modify-inputs)[delete]: Use it.
---
 guix/packages.scm | 72 +++++++++++++++++++++++++++++++++++++----------
 1 file changed, 57 insertions(+), 15 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index b004882cc6..45552bfb7f 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1173,15 +1173,49 @@ (define (transitive-inputs inputs)
       ((input rest ...)
        (loop rest (cons input result) propagated first? seen)))))
 
+(define (specification->inputs spec inputs)
+  "Lookup inputs specified by SPEC among INPUTS, an input list.  Return an input
+list consists of all matching inputs, or '().  SPEC may be a package name,
+optionally containing a version number or an output name, as in these examples:
+
+  guile
+  guile@2.0.9
+  guile:debug
+  guile@2.0.9:debug
+
+If SPEC does not specify a version number, all versions are matched; if SPEC
+does not specify an output, all outputs are matched.
+
+SPEC can be an input label as well."
+  (let ((name version sub-drv
+              (package-specification->name+version+output spec #f)))
+    (filter-map
+     (lambda (input)
+       (match input
+         (((? string? label) (? package? package) . outputs)
+          (and (or (and (string=? name (package-name package))
+                        (when version
+                          (string-prefix? version (package-version package)))
+                        (when sub-drv
+                          (and (not (null? outputs))
+                               (string=? sub-drv (first outputs)))))
+                   ;; fallback to input label
+                   (string=? label spec))
+               input))
+         ;; not a package
+         (((? string? label) _ . _)
+          (and (string=? label spec)
+               input))))
+     inputs)))
+
 (define (lookup-input inputs name)
   "Lookup NAME among INPUTS, an input list."
   ;; Note: Currently INPUTS is assumed to be an input list that contains input
   ;; labels.  In the future, input labels will be gone and this procedure will
   ;; check package names.
-  (match (assoc-ref inputs name)
-    ((obj) obj)
-    ((obj _) obj)
-    (#f #f)))
+  (let ((candidates (specification->inputs name inputs)))
+    (and (not (null? candidates))
+         (second (first candidates)))))
 
 (define (lookup-package-input package name)
   "Look up NAME among PACKAGE's inputs.  Return it if found, #f otherwise."
@@ -1202,17 +1236,25 @@ (define (lookup-package-direct-input package name)
 otherwise."
   (lookup-input (package-direct-inputs package) name))
 
+(define (delete-input name inputs)
+  "Delete input NAME within INPUTS."
+  (let ((to-delete (specification->inputs name inputs)))
+    (lset-difference equal? inputs to-delete)))
+
 (define (replace-input name replacement inputs)
   "Replace input NAME by REPLACEMENT within INPUTS."
-  (map (lambda (input)
-         (match input
-           (((? string? label) _ . outputs)
-            (if (string=? label name)
-                (match replacement        ;does REPLACEMENT specify an output?
-                  ((_ _) (cons label replacement))
-                  (_     (cons* label replacement outputs)))
-                input))))
-       inputs))
+  (let ((to-replace (specification->inputs name inputs)))
+    (append
+     (lset-difference equal? inputs to-replace)
+     (if (null? to-replace)
+         '()
+         (map (lambda (input)
+                (match input
+                  ((label _ . outputs)
+                   (match replacement   ;does REPLACEMENT specify an output?
+                     ((_ _) (cons label replacement))
+                     (_     (cons* label replacement outputs))))))
+              to-replace)))))
 
 (define-syntax prepend
   (lambda (s)
@@ -1244,10 +1286,10 @@ (define-syntax modify-inputs
     ;; 'package-inputs' & co., is actually an alist with labels.  Eventually,
     ;; it will operate on list of inputs without labels.
     ((_ inputs (delete name) clauses ...)
-     (modify-inputs (alist-delete name inputs)
+     (modify-inputs (delete-input name inputs)
                     clauses ...))
     ((_ inputs (delete names ...) clauses ...)
-     (modify-inputs (fold alist-delete inputs (list names ...))
+     (modify-inputs (fold delete-input inputs (list names ...))
                     clauses ...))
     ((_ inputs (prepend lst ...) clauses ...)
      (modify-inputs (append (map add-input-label (list lst ...)) inputs)
-- 
2.41.0