From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:470:142:3::10]:59604) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jAAcG-0005SQ-9F for guix-patches@gnu.org; Fri, 06 Mar 2020 05:54:05 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1jAAcE-0004rE-Pm for guix-patches@gnu.org; Fri, 06 Mar 2020 05:54:04 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:38168) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1jAAcE-0004qy-MT for guix-patches@gnu.org; Fri, 06 Mar 2020 05:54:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1jAAcE-0007jM-LV for guix-patches@gnu.org; Fri, 06 Mar 2020 05:54:02 -0500 Subject: [bug#39945] [PATCH 1/1] gexp: Add 'with-parameters'. References: <20200306104108.19503-1-ludo@gnu.org> In-Reply-To: <20200306104108.19503-1-ludo@gnu.org> Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Fri, 6 Mar 2020 11:53:45 +0100 Message-Id: <20200306105345.19782-1-ludo@gnu.org> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 39945@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= * guix/gexp.scm (): 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 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 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 + 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))))))))) + ;;; ;;; 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