[PATCH v3 1/1] packages: Support for full Guix specification

[Olivier Dion <olivier.dion@polymtl.ca>]

Guix package specifications match:

  PACKAGE [@VERSION] [:OUTPUT]

thus the following are all valid package specifications:

  - "guile"
  - "guile@3.0.8"
  - "guile:debug"
  - "guile@3.0.8:debug"

This is not currently supported by gwl.  To do so, packages and their output are
wrapped in a <package-wrapper> record.  The record can be unwrapped with
PACKAGE-UNWRAP to access the underlying Guix's package.  Patterns matching is
used for dispatching of procedure such as PACKAGE-NATIVE-INPUTS or PACKAGE-NAME.
---
 gwl/packages.scm        | 96 +++++++++++++++++++++++++++++++++--------
 gwl/processes.scm       |  6 +--
 gwl/workflows/graph.scm |  2 +-
 3 files changed, 81 insertions(+), 23 deletions(-)

diff --git a/gwl/packages.scm b/gwl/packages.scm
index 6fe82d4..8016bd4 100644
--- a/gwl/packages.scm
+++ b/gwl/packages.scm
@@ -21,7 +21,9 @@
   #:use-module ((guix store)
                 #:select (open-connection close-connection))
   #:use-module ((guix packages)
-                #:select (package? package-full-name))
+                #:select (package?
+                          package-full-name
+                          (package-native-inputs . guix:package-native-inputs)))
   #:use-module ((guix inferior)
                 #:select (open-inferior
                           inferior?
@@ -31,9 +33,13 @@
                           inferior-package-version
                           inferior-package-native-inputs
                           inferior-package-derivation))
+  #:use-module ((guix ui)
+                #:select (package-specification->name+version+output))
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -43,11 +49,56 @@
             lookup-package
             valid-package?
             package-name
+            package-unwrap
+            package->package+output
 
             bash-minimal
             build-time-guix
             default-guile
-            default-guile-derivation))
+            default-guile-derivation
+            guile-gcrypt))
+
+(define-record-type <package-wrapper>
+  (make-package-wrapper package output)
+  package-wrapper?
+  (package package-wrapper-package)
+  (output package-wrapper-output))
+
+(define package-native-inputs
+  (match-lambda
+    ((? package? pkg)
+     (package-native-inputs pkg))
+    ((? inferior-package? pkg)
+     (inferior-package-native-inputs pkg))
+    ((? package-wrapper? pkg)
+     (package-native-inputs (package-wrapper-package pkg)))))
+
+(define package-name
+  (match-lambda
+    ((? package? pkg)
+     (package-full-name pkg))
+    ((? inferior-package? pkg)
+     (inferior-package-full-name pkg))
+    ((? package-wrapper? pkg)
+     (package-name (package-wrapper-package pkg)))))
+
+(define package-unwrap
+  (match-lambda
+    ((or (? package? pkg)
+         (? inferior-package? pkg))
+     pkg)
+    ((? package-wrapper? pkg)
+     (package-wrapper-package pkg))))
+
+(define package->package+output
+  (match-lambda
+    ((or (? package? pkg)
+         (? inferior-package? pkg))
+     (list pkg "out"))
+    ((? package-wrapper? pkg)
+     (list
+      (package-wrapper-package pkg)
+      (package-wrapper-output pkg)))))
 
 (define current-guix
   (let ((current-guix-inferior #false))
@@ -73,15 +124,25 @@
 
 (define (lookup-package specification)
   (log-event 'guix (G_ "Looking up package `~a'~%") specification)
-  (match (lookup-inferior-packages (current-guix) specification)
-    ((first . rest) first)
-    (_ (raise (condition
-               (&gwl-package-error
-                (package-spec specification)))))))
+  (let-values (((name version output)
+                (package-specification->name+version+output
+                 specification)))
+    (let* ((inferior-package
+            (lookup-inferior-packages (current-guix)
+                                      name version))
+           (package (match inferior-package
+                      ((first . rest) first)
+                      (_ (raise (condition
+                                 (&gwl-package-error
+                                  (package-spec specification))))))))
+      (make-package-wrapper package output))))
 
 (define (valid-package? val)
-  (or (package? val)
-      (inferior-package? val)))
+  (match val
+    ((or (? package?)
+         (? inferior-package?)
+         (? package-wrapper?)) #t)
+    (_ #f)))
 
 ;; Just like package-full-name from (guix packages) but for inferior
 ;; packages.
@@ -93,27 +154,24 @@ the version.  By default, DELIMITER is \"@\"."
                  delimiter
                  (inferior-package-version inferior-package)))
 
-(define package-name
-  (match-lambda
-    ((? package? pkg)
-     (package-full-name pkg))
-    ((? inferior-package? pkg)
-     (inferior-package-full-name pkg))))
-
 (define bash-minimal
   (mlambda ()
-    (lookup-package "bash-minimal")))
+    (package-unwrap (lookup-package "bash-minimal"))))
+
+(define guile-gcrypt
+  (mlambda ()
+    (package-unwrap (lookup-package "guile-gcrypt"))))
 
 (define build-time-guix
   (mlambda ()
-    (lookup-package "guix")))
+    (package-unwrap (lookup-package "guix"))))
 
 (define default-guile
   (mlambda ()
     "Return the variant of Guile that was used to build the \"guix\"
 package, which provides all library features used by the GWL.  We use
 this Guile to run scripts."
-    (and=> (assoc-ref (inferior-package-native-inputs (build-time-guix))
+    (and=> (assoc-ref (package-native-inputs (build-time-guix))
                       "guile") first)))
 
 (define (default-guile-derivation)
diff --git a/gwl/processes.scm b/gwl/processes.scm
index ce40d12..dd5ed02 100644
--- a/gwl/processes.scm
+++ b/gwl/processes.scm
@@ -611,7 +611,7 @@ tags if WITH-TAGS? is #FALSE or missing."
   "Return a file that contains the list of references of ITEM."
   (if (struct? item)                              ;lowerable object
       (computed-file name
-                     (with-extensions (list (lookup-package "guile-gcrypt")) ;for store-copy
+                     (with-extensions (list (guile-gcrypt)) ;for store-copy
                        (with-imported-modules (source-module-closure
                                                '((guix build store-copy)))
                          #~(begin
@@ -643,7 +643,7 @@ PROCESS."
   (let* ((name         (process-full-name process))
          (packages     (cons (bash-minimal)
                              (process-packages process)))
-         (manifest     (packages->manifest packages))
+         (manifest     (packages->manifest (map package->package+output packages)))
          (profile      (profile (content manifest)))
          (search-paths (delete-duplicates
                         (map search-path-specification->sexp
@@ -657,7 +657,7 @@ PROCESS."
                          (set-search-paths (map sexp->search-path-specification
                                                 ',search-paths)
                                            (cons ,profile
-                                                 ',packages))))
+                                                 ',(map package-unwrap packages)))))
                 #$(if out `(setenv "out" ,out) "")
                 (setenv "_GWL_PROFILE" #$profile)
                 (use-modules (ice-9 match))
diff --git a/gwl/workflows/graph.scm b/gwl/workflows/graph.scm
index ea3fec9..c435644 100644
--- a/gwl/workflows/graph.scm
+++ b/gwl/workflows/graph.scm
@@ -43,7 +43,7 @@ label=<<FONT POINT-SIZE=\"14\">~a</FONT><BR/>\
             (take-color)
             (string-upcase pretty-name)
             (process-synopsis process)
-            (match (process-packages process)
+            (match (map package-unwrap (process-packages process))
               (() "")
               (inputs (format #f "<BR/>Uses: ~{~a~^, ~}."
                               (map package-name inputs)))))))
-- 
2.35.1