[bug#39945] [PATCH 0/1] Introducing 'with-parameters' for gexp dynamic binding

[bug#39945] [PATCH 0/1] Introducing 'with-parameters' for gexp dynamic binding

[Ludovic Courtès]

Hello Guix!

This patch adds a new ‘with-parameters’ form.  It is like ‘parameterize’
except that it takes effect when a file-like object is lowered, as in:

  ;; Return coreutils for i686.
  (with-parameters ((%current-system "i686-linux"))
    coreutils)

‘with-parameters’ is necessary because if you would use ‘parameterize’
in the example above, it wouldn’t have any effect at all: the dynamic
binding would be installed at the wrong time.

It works for any SRFI-39 parameter, though ‘%current-system’ is my main
use case.  It makes it possible to have gexps or manifests that include
things explicitly targeting a given system.  (For instance, I’d like to
have a manifest for release-critical things that explicitly pins the
targeted systems.)

Note that ‘with-parameters’ applies to file-like objects; it is _not_ a
property of the gexp itself.  So one cannot, for example, write:

  (with-parameters ((%current-system "i686-linux"))
    #~(a b c d))

I feel like it’s better this way, though it could be confusing.

Thoughts?

Besides, ‘with-parameters’ is the dual of what was discussed at
<https://issues.guix.gnu.org/issue/29296>.

Thanks,
Ludo’.

Ludovic Courtès (1):
  gexp: Add 'with-parameters'.

 .dir-locals.el |  1 +
 doc/guix.texi  | 19 ++++++++++++++++
 guix/gexp.scm  | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++
 tests/gexp.scm | 28 ++++++++++++++++++++++++
 4 files changed, 107 insertions(+)

-- 
2.25.1

[bug#39945] [PATCH 1/1] gexp: Add 'with-parameters'.

[Ludovic Courtès]

* guix/gexp.scm (<parameterized>): New record type.
(with-parameters): New macro.
(compile-parameterized): New gexp compiler.
* tests/gexp.scm ("with-parameters for %current-system")
("with-parameters + file-append"): New tests.
* doc/guix.texi (G-Expressions): Document it.
---
 .dir-locals.el |  1 +
 doc/guix.texi  | 19 ++++++++++++++++
 guix/gexp.scm  | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++
 tests/gexp.scm | 28 ++++++++++++++++++++++++
 4 files changed, 107 insertions(+)

diff --git a/.dir-locals.el b/.dir-locals.el
index 5ce3fbc9a5..1976f7e60d 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -83,6 +83,7 @@
    (eval . (put 'wrap-program 'scheme-indent-function 1))
    (eval . (put 'with-imported-modules 'scheme-indent-function 1))
    (eval . (put 'with-extensions 'scheme-indent-function 1))
+   (eval . (put 'with-parameters 'scheme-indent-function 1))
 
    (eval . (put 'with-database 'scheme-indent-function 2))
    (eval . (put 'call-with-transaction 'scheme-indent-function 2))
diff --git a/doc/guix.texi b/doc/guix.texi
index fab9159530..9ad6db7fc0 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -8021,6 +8021,25 @@ the second case, the resulting script contains a @code{(string-append
 @dots{})} expression to construct the file name @emph{at run time}.
 @end deffn
 
+@deffn {Scheme Syntax} with-parameters ((@var{parameter} @var{value}) @dots{}) @var{exp}
+This macro is similar to the @code{parameterize} form for
+dynamically-bound @dfn{parameters} (@pxref{Parameters,,, guile, GNU
+Guile Reference Manual}).  The key difference is that it takes effect
+when the file-like object returned by @var{exp} is lowered to a
+derivation or store item.
+
+A typical use of @code{with-parameters} is to force the system in effect
+for a given object:
+
+@lisp
+(with-parameters ((%current-system "i686-linux"))
+  coreutils)
+@end lisp
+
+The example above returns an object that corresponds to the i686 build
+of Coreutils, regardless of the current value of @code{%current-system}.
+@end deffn
+
 
 Of course, in addition to gexps embedded in ``host'' code, there are
 also modules containing build tools.  To make it clear that they are
diff --git a/guix/gexp.scm b/guix/gexp.scm
index c4f4e80209..d3e1b34dac 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -82,6 +82,9 @@
             raw-derivation-file
             raw-derivation-file?
 
+            with-parameters
+            parameterized?
+
             load-path-expression
             gexp-modules
 
@@ -520,6 +523,62 @@ SUFFIX."
                           (base   (expand base lowered output)))
                      (string-append base (string-concatenate suffix)))))))
 
+;; Representation of SRFI-39 parameter settings in the dynamic scope of an
+;; object lowering.
+(define-record-type <parameterized>
+  (parameterized bindings thunk)
+  parameterized?
+  (bindings parameterized-bindings)             ;list of parameter/value pairs
+  (thunk    parameterized-thunk))               ;thunk
+
+(define-syntax-rule (with-parameters ((param value) ...) body ...)
+  "Bind each PARAM to the corresponding VALUE for the extent during which BODY
+is lowered.  Consider this example:
+
+  (with-parameters ((%current-system \"x86_64-linux\"))
+    coreutils)
+
+It returns a <parameterized> object that ensures %CURRENT-SYSTEM is set to
+x86_64-linux when COREUTILS is lowered."
+  (parameterized (list (list param (lambda () value)) ...)
+                 (lambda ()
+                   body ...)))
+
+(define-gexp-compiler compile-parameterized <parameterized>
+  compiler =>
+  (lambda (parameterized system target)
+    (match (parameterized-bindings parameterized)
+      (((parameters values) ...)
+       (let ((fluids (map parameter-fluid parameters))
+             (thunk  (parameterized-thunk parameterized)))
+         ;; Install the PARAMETERS for the dynamic extent of THUNK.
+         (with-fluids* fluids
+           (map (lambda (thunk) (thunk)) values)
+           (lambda ()
+             ;; Special-case '%current-system' and '%current-target-system' to
+             ;; make sure we get the desired effect.
+             (let ((system (if (memq %current-system parameters)
+                               (%current-system)
+                               system))
+                   (target (if (memq %current-target-system parameters)
+                               (%current-target-system)
+                               target)))
+               (lower-object (thunk) system #:target target))))))))
+
+  expander => (lambda (parameterized lowered output)
+                (match (parameterized-bindings parameterized)
+                  (((parameters values) ...)
+                   (let ((fluids (map parameter-fluid parameters))
+                         (thunk  (parameterized-thunk parameterized)))
+                     ;; Install the PARAMETERS for the dynamic extent of THUNK.
+                     (with-fluids* fluids
+                       (map (lambda (thunk) (thunk)) values)
+                       (lambda ()
+                         ;; Delegate to the expander of the wrapped object.
+                         (let* ((base   (thunk))
+                                (expand (lookup-expander base)))
+                           (expand base lowered output)))))))))
+
 \f
 ;;;
 ;;; Inputs & outputs.
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 7c8985d846..904b1a687a 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -284,6 +284,34 @@
            (((thing "out"))
             (eq? thing file))))))
 
+(test-assertm "with-parameters for %current-system"
+  (mlet* %store-monad ((system -> (match (%current-system)
+                                    ("aarch64-linux" "x86_64-linux")
+                                    (_               "aarch64-linux")))
+                       (drv    (package->derivation coreutils system))
+                       (obj -> (with-parameters ((%current-system system))
+                                 coreutils))
+                       (result (lower-object obj)))
+    (return (string=? (derivation-file-name drv)
+                      (derivation-file-name result)))))
+
+(test-assert "with-parameters + file-append"
+  (let* ((system (match (%current-system)
+                   ("aarch64-linux" "x86_64-linux")
+                   (_               "aarch64-linux")))
+         (drv    (package-derivation %store coreutils system))
+         (param  (make-parameter 7))
+         (exp    #~(here we go #$(with-parameters ((%current-system system)
+                                                   (param 42))
+                                   (if (= (param) 42)
+                                       (file-append coreutils "/bin/touch")
+                                       %bootstrap-guile)))))
+    (match (gexp->sexp* exp)
+      (('here 'we 'go (? string? result))
+       (string=? result
+                 (string-append (derivation->output-path drv)
+                                "/bin/touch"))))))
+
 (test-assert "ungexp + ungexp-native"
   (let* ((exp    (gexp (list (ungexp-native %bootstrap-guile)
                              (ungexp coreutils)
-- 
2.25.1

[bug#39945] [PATCH 0/1] Introducing 'with-parameters' for gexp dynamic binding

[Mathieu Othacehe]

Hey!

> Thoughts?
>
> Besides, ‘with-parameters’ is the dual of what was discussed at
> <https://issues.guix.gnu.org/issue/29296>.

Super nice! Maybe you could add a test-case involving
%current-target-system but otherwise this LGTM.

Do you think we could use this to get around this issue we discussed
there:
https://lists.gnu.org/archive/html/guix-devel/2019-12/msg00099.html.

Thanks,

Mathieu

bug#39945: [PATCH 0/1] Introducing 'with-parameters' for gexp dynamic binding

[Ludovic Courtès]

Hi Mathieu,

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

>> Thoughts?
>>
>> Besides, ‘with-parameters’ is the dual of what was discussed at
>> <https://issues.guix.gnu.org/issue/29296>.
>
> Super nice! Maybe you could add a test-case involving
> %current-target-system but otherwise this LGTM.

Done and pushed as cf2ac04f13d9266c7c8a2ebd2e85ef593231ac9d.

> Do you think we could use this to get around this issue we discussed
> there:
> https://lists.gnu.org/archive/html/guix-devel/2019-12/msg00099.html.

It could be use to achieve the same result as the <native-qemu> package
you proposed:

  #~(… #+(with-parameters ((%current-system %system)) qemu) …)

However, the issue I mentioned before with this approach remain:

  […] now the result of:

    guix system build -s armhf-linux -d …

  would be dependent on the actual system type.  In other words, the
  result would be different if you run it on armhf-linux, if you run it on
  x86_64-linux, or if you run it on i686-linux.  Not great.

Thanks for your feedback!

Ludo’.