unofficial mirror of gwl-devel@gnu.org
 help / color / mirror / Atom feed
From: Olivier Dion <olivier.dion@polymtl.ca>
To: Olivier Dion <olivier.dion@polymtl.ca>,
	Olivier Dion via <gwl-devel@gnu.org>
Subject: [PATCH v3 1/1] packages: Support for full Guix specification
Date: Fri, 29 Apr 2022 14:02:47 -0400	[thread overview]
Message-ID: <20220429180247.17830-2-olivier.dion@polymtl.ca> (raw)
In-Reply-To: <20220429180247.17830-1-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



  reply	other threads:[~2022-04-29 18:03 UTC|newest]

Thread overview: 23+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2022-04-21 17:22 Packages specification does not work Olivier Dion via
2022-04-21 18:25 ` Olivier Dion via
2022-04-21 19:51 ` [PATCH v1 1/2] packages: Support for full Guix specification Olivier Dion
2022-04-21 19:51   ` [PATCH v1 2/2] pre-inst-env.in: Export GUIX_EXTENSIONS_PATH Olivier Dion
2022-04-29 11:42     ` Ricardo Wurmus
2022-04-21 20:10   ` [PATCH v1 1/2] packages: Support for full Guix specification Olivier Dion via
2022-04-22 18:43   ` [PATCH v2 0/2] Support full package specifications Olivier Dion
2022-04-22 18:43     ` [PATCH v2 1/2] packages: Support for full Guix specification Olivier Dion
2022-04-26 18:11       ` Ricardo Wurmus
2022-04-26 18:59         ` Olivier Dion via
2022-04-26 20:30           ` Ricardo Wurmus
2022-04-26 21:52             ` Olivier Dion via
2022-04-22 18:43     ` [PATCH v2 2/2] pre-inst-env.in: Export GUIX_EXTENSIONS_PATH Olivier Dion
2022-04-29  9:00       ` zimoun
2022-04-29 18:02     ` [PATCH v3 0/1] Support full package specifications Olivier Dion
2022-04-29 18:02       ` Olivier Dion [this message]
2022-05-22  6:43         ` [PATCH v3 1/1] packages: Support for full Guix specification Ricardo Wurmus
2022-05-22 12:33           ` Olivier Dion via
2022-05-17 20:40       ` [PATCH v3 0/1] Support full package specifications Olivier Dion via
2022-05-22 12:38       ` [PATCH v4] packages: Support for full Guix specification Olivier Dion
2022-05-23 21:02         ` Ricardo Wurmus
2022-05-23 21:45         ` [PATCH v5] " Olivier Dion
2022-06-01 13:07           ` Ricardo Wurmus

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://www.guixwl.org/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=20220429180247.17830-2-olivier.dion@polymtl.ca \
    --to=olivier.dion@polymtl.ca \
    --cc=gwl-devel@gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).