[bug#68315] [PATCH 01/48] guix: packages: Extend bag-build to support gexp.

[Nicolas Graves via Guix-patches via <guix-patches@gnu.org>]

* guix/build-system.scm: Update comment.
* guix/packages.scm
(bag->derivation): Rename function to bag-builder. Create new function.
(bag->cross-derivation): Rename to bag-cross-builder.

Change-Id: I56c5a9dab9954307f95b29eab5e02ee058271684
---
 guix/build-system.scm |  2 +-
 guix/packages.scm     | 53 +++++++++++++++++++++++++++++++++++--------
 2 files changed, 45 insertions(+), 10 deletions(-)

diff --git a/guix/build-system.scm b/guix/build-system.scm
index 76d670995c..a4dcdc52d8 100644
--- a/guix/build-system.scm
+++ b/guix/build-system.scm
@@ -79,7 +79,7 @@ (define-record-type* <bag> bag %make-bag
                  (default '("out")))
   (arguments     bag-arguments           ;list
                  (default '()))
-  (build         bag-build))             ;bag -> derivation
+  (build         bag-build))             ;bag -> gexp or derivation
 
 (define* (make-bag build-system name
                    #:key source (inputs '()) (native-inputs '())
diff --git a/guix/packages.scm b/guix/packages.scm
index 930b1a3b0e..8ff9ca60a9 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -10,6 +10,7 @@
 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
 ;;; Copyright © 2022 jgart <jgart@dismail.de>
 ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -50,6 +51,7 @@ (define-module (guix packages)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 optargs)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-26)
@@ -1889,12 +1891,12 @@ (define (input=? input1 input2)
                       (derivation=? obj1 obj2))
                  (equal? obj1 obj2))))))))
 
-(define* (bag->derivation bag #:optional context)
-  "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
-a package object describing the context in which the call occurs, for improved
-error reporting."
+(define* (bag-builder bag #:optional context)
+  "Return the gexp or derivation to build BAG for SYSTEM.  Optionally, CONTEXT
+can be a package object describing the context in which the call occurs, for
+improved error reporting."
   (if (bag-target bag)
-      (bag->cross-derivation bag)
+      (bag-cross-builder bag)
       (mlet* %store-monad ((system ->  (bag-system bag))
                            (inputs ->  (bag-transitive-inputs bag))
                            (input-drvs (mapm %store-monad
@@ -1916,10 +1918,10 @@ (define* (bag->derivation bag #:optional context)
                #:outputs (bag-outputs bag) #:system system
                (bag-arguments bag)))))
 
-(define* (bag->cross-derivation bag #:optional context)
-  "Return the derivation to build BAG, which is actually a cross build.
-Optionally, CONTEXT can be a package object denoting the context of the call.
-This is an internal procedure."
+(define* (bag-cross-builder bag #:optional context)
+  "Return the gexp or derivation to build BAG, which is actually a cross
+build. Optionally, CONTEXT can be a package object denoting the context of the
+call. This is an internal procedure."
   (mlet* %store-monad ((system ->   (bag-system bag))
                        (target ->   (bag-target bag))
                        (host ->     (bag-transitive-host-inputs bag))
@@ -1960,6 +1962,39 @@ (define* (bag->cross-derivation bag #:optional context)
            #:system system #:target target
            (bag-arguments bag))))
 
+(define* (bag->derivation bag #:optional context)
+  "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
+a package object describing the context in which the call occurs, for improved
+error reporting."
+  (mlet %store-monad ((builder (bag-builder bag context)))
+    (match builder
+      ((? derivation? drv)
+       (return drv))
+      ((? gexp gexp)
+       (let-keywords (bag-arguments bag) #t
+                     ((allowed-references    #f)
+                      (disallowed-references #f)
+                      (guile                 #f)
+                      (substitutable?        #t))
+         (mlet %store-monad
+             ((guile (package->derivation (or guile (default-guile))
+                                          (bag-system bag)
+                                          #:graft? #f)))
+           ;; Note: Always pass #:graft? #f.  Without it, ALLOWED-REFERENCES &
+           ;; co. would be interpreted as referring to grafted packages.
+           (gexp->derivation (bag-name bag) gexp
+                             #:system (bag-system bag)
+                             #:target (and (bag-target bag))
+                             #:graft? #f
+                             #:substitutable? substitutable?
+                             #:allowed-references allowed-references
+                             #:disallowed-references disallowed-references
+                             #:guile-for-build guile))))
+      ;; build-bag has to be drv or gexp, else raise.
+      (_
+       (raise (condition (&package-error
+                          (package context))))))))
+
 (define bag->derivation*
   (store-lower bag->derivation))
 
-- 
2.41.0