From patchwork Mon Jun 10 21:41:27 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 14282 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id CE1F717064; Mon, 10 Jun 2019 22:42:30 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 3C44D1704B for ; Mon, 10 Jun 2019 22:42:30 +0100 (BST) Received: from localhost ([::1]:49910 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1haS3g-0003jP-MP for patchwork@mira.cbaines.net; Mon, 10 Jun 2019 17:42:29 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:35131) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1haS3I-0003QC-4l for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1haS3F-0001Jd-RG for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:44039) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1haS3F-0001JX-NI for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:01 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1haS3F-0006Jf-KY for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36162] [PATCH 1/4] gexp: Add 'lower-gexp' and express 'gexp->derivation' in terms of it. References: <20190610210853.5709-1-ludo@gnu.org> In-Reply-To: <20190610210853.5709-1-ludo@gnu.org> Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Mon, 10 Jun 2019 21:42:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36162 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 36162@debbugs.gnu.org Received: via spool by 36162-submit@debbugs.gnu.org id=B36162.156020291124237 (code B ref 36162); Mon, 10 Jun 2019 21:42:01 +0000 Received: (at 36162) by debbugs.gnu.org; 10 Jun 2019 21:41:51 +0000 Received: from localhost ([127.0.0.1]:57575 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1haS34-0006Ih-GH for submit@debbugs.gnu.org; Mon, 10 Jun 2019 17:41:51 -0400 Received: from eggs.gnu.org ([209.51.188.92]:54430) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1haS2z-0006IN-Ua for 36162@debbugs.gnu.org; Mon, 10 Jun 2019 17:41:46 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:60151) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1haS2u-00015F-Kn; Mon, 10 Jun 2019 17:41:40 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=33892 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1haS2s-0001fJ-5h; Mon, 10 Jun 2019 17:41:40 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Mon, 10 Jun 2019 23:41:27 +0200 Message-Id: <20190610214130.19378-1-ludo@gnu.org> X-Mailer: git-send-email 2.21.0 MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/gexp.scm (gexp-input-thing, gexp-input-output) (gexp-input-native?): Export. (lower-inputs): Return records instead of tuples. (lower-reference-graphs): Adjust accordingly. (): New record type. (lower-gexp, gexp-input->tuple): New procedure. (gexp->derivation)[%modules]: Remove. [requested-graft?]: New variable. [add-modules]: New procedure. Rewrite in terms of 'lower-gexp'. (gexp-inputs): Add TODO comment. * tests/gexp.scm ("lower-gexp"): New test. --- guix/gexp.scm | 238 +++++++++++++++++++++++++++++++++++++------------ tests/gexp.scm | 37 ++++++++ 2 files changed, 216 insertions(+), 59 deletions(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index 4f2adba90a..38f64db7f1 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -39,6 +39,9 @@ gexp-input gexp-input? + gexp-input-thing + gexp-input-output + gexp-input-native? local-file local-file? @@ -78,6 +81,14 @@ load-path-expression gexp-modules + lower-gexp + lowered-gexp? + lowered-gexp-sexp + lowered-gexp-inputs + lowered-gexp-guile + lowered-gexp-load-path + lowered-gexp-load-compiled-path + gexp->derivation gexp->file gexp->script @@ -566,15 +577,20 @@ list." "Turn any package from INPUTS into a derivation for SYSTEM; return the corresponding input list as a monadic value. When TARGET is true, use it as the cross-compilation target triplet." + (define (store-item? obj) + (and (string? obj) (store-path? obj))) + (with-monad %store-monad (mapm %store-monad (match-lambda (((? struct? thing) sub-drv ...) (mlet %store-monad ((drv (lower-object thing system #:target target))) - (return `(,drv ,@sub-drv)))) + (return (apply gexp-input drv sub-drv)))) + (((? store-item? item)) + (return (gexp-input item))) (input - (return input))) + (return (gexp-input input)))) inputs))) (define* (lower-reference-graphs graphs #:key system target) @@ -586,7 +602,9 @@ corresponding derivation." (mlet %store-monad ((inputs (lower-inputs inputs #:system system #:target target))) - (return (map cons file-names inputs)))))) + (return (map (lambda (file input) + (cons file (gexp-input->tuple input))) + file-names inputs)))))) (define* (lower-references lst #:key system target) "Based on LST, a list of output names and packages, return a list of output @@ -618,6 +636,128 @@ names and file names suitable for the #:allowed-references argument to (lambda (system) ((force proc) system)))) +;; Representation of a gexp instantiated for a given target and system. +(define-record-type + (lowered-gexp sexp inputs guile load-path load-compiled-path) + lowered-gexp? + (sexp lowered-gexp-sexp) ;sexp + (inputs lowered-gexp-inputs) ;list of + (guile lowered-gexp-guile) ; | #f + (load-path lowered-gexp-load-path) ;list of store items + (load-compiled-path lowered-gexp-load-compiled-path)) ;list of store items + +(define* (lower-gexp exp + #:key + (module-path %load-path) + (system (%current-system)) + (target 'current) + (graft? (%graft?)) + (guile-for-build (%guile-for-build)) + (effective-version "2.2") + + deprecation-warnings + (pre-load-modules? #t)) ;transitional + "Lower EXP, a gexp, instantiating it for SYSTEM and TARGET. Return a + ready to be used. + +Lowered gexps are an intermediate representation that's useful for +applications that deal with gexps outside in a way that is disconnected from +derivations--e.g., code evaluated for its side effects." + (define %modules + (delete-duplicates (gexp-modules exp))) + + (define (search-path modules extensions suffix) + (append (match modules + ((? derivation? drv) + (list (derivation->output-path drv))) + (#f + '()) + ((? store-path? item) + (list item))) + (map (lambda (extension) + (string-append (match extension + ((? derivation? drv) + (derivation->output-path drv)) + ((? store-path? item) + item)) + suffix)) + extensions))) + + (mlet* %store-monad ( ;; The following binding forces '%current-system' and + ;; '%current-target-system' to be looked up at >>= + ;; time. + (graft? (set-grafting graft?)) + + (system -> (or system (%current-system))) + (target -> (if (eq? target 'current) + (%current-target-system) + target)) + (guile (if guile-for-build + (return guile-for-build) + (default-guile-derivation system))) + (normals (lower-inputs (gexp-inputs exp) + #:system system + #:target target)) + (natives (lower-inputs (gexp-native-inputs exp) + #:system system + #:target #f)) + (inputs -> (append normals natives)) + (sexp (gexp->sexp exp + #:system system + #:target target)) + (extensions -> (gexp-extensions exp)) + (exts (mapm %store-monad + (lambda (obj) + (lower-object obj system)) + extensions)) + (modules (if (pair? %modules) + (imported-modules %modules + #:system system + #:module-path module-path) + (return #f))) + (compiled (if (pair? %modules) + (compiled-modules %modules + #:system system + #:module-path module-path + #:extensions extensions + #:guile guile-for-build + #:pre-load-modules? + pre-load-modules? + #:deprecation-warnings + deprecation-warnings) + (return #f)))) + (define load-path + (search-path modules exts + (string-append "/share/guile/site/" effective-version))) + + (define load-compiled-path + (search-path compiled exts + (string-append "/lib/guile/" effective-version + "/site-ccache"))) + + (mbegin %store-monad + (set-grafting graft?) ;restore the initial setting + (return (lowered-gexp sexp + `(,@(if modules + (list (gexp-input modules)) + '()) + ,@(if compiled + (list (gexp-input compiled)) + '()) + ,@(map gexp-input exts) + ,@inputs) + guile-for-build + load-path + load-compiled-path))))) + +(define (gexp-input->tuple input) + "Given INPUT, a record, return the corresponding input tuple +suitable for the 'derivation' procedure." + (match (gexp-input-output input) + ("out" `(,(gexp-input-thing input))) + (output `(,(gexp-input-thing input) + ,(gexp-input-output input))))) + (define* (gexp->derivation name exp #:key system (target 'current) @@ -682,10 +822,8 @@ DEPRECATION-WARNINGS determines whether to show deprecation warnings while compiling modules. It can be #f, #t, or 'detailed. The other arguments are as for 'derivation'." - (define %modules - (delete-duplicates - (append modules (gexp-modules exp)))) (define outputs (gexp-outputs exp)) + (define requested-graft? graft?) (define (graphs-file-names graphs) ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. @@ -699,11 +837,13 @@ The other arguments are as for 'derivation'." (cons file-name thing))) graphs)) - (define (extension-flags extension) - `("-L" ,(string-append (derivation->output-path extension) - "/share/guile/site/" effective-version) - "-C" ,(string-append (derivation->output-path extension) - "/lib/guile/" effective-version "/site-ccache"))) + (define (add-modules exp modules) + (if (null? modules) + exp + (make-gexp (gexp-references exp) + (append modules (gexp-self-modules exp)) + (gexp-self-extensions exp) + (gexp-proc exp)))) (mlet* %store-monad ( ;; The following binding forces '%current-system' and ;; '%current-target-system' to be looked up at >>= @@ -714,40 +854,21 @@ The other arguments are as for 'derivation'." (target -> (if (eq? target 'current) (%current-target-system) target)) - (normals (lower-inputs (gexp-inputs exp) - #:system system - #:target target)) - (natives (lower-inputs (gexp-native-inputs exp) - #:system system - #:target #f)) - (inputs -> (append normals natives)) - (sexp (gexp->sexp exp - #:system system - #:target target)) - (builder (text-file script-name - (object->string sexp))) - (extensions -> (gexp-extensions exp)) - (exts (mapm %store-monad - (lambda (obj) - (lower-object obj system)) - extensions)) - (modules (if (pair? %modules) - (imported-modules %modules - #:system system - #:module-path module-path - #:guile guile-for-build) - (return #f))) - (compiled (if (pair? %modules) - (compiled-modules %modules - #:system system - #:module-path module-path - #:extensions extensions - #:guile guile-for-build - #:pre-load-modules? - pre-load-modules? - #:deprecation-warnings - deprecation-warnings) - (return #f))) + (exp -> (add-modules exp modules)) + (lowered (lower-gexp exp + #:module-path module-path + #:system system + #:target target + #:graft? requested-graft? + #:guile-for-build + guile-for-build + #:effective-version + effective-version + #:deprecation-warnings + deprecation-warnings + #:pre-load-modules? + pre-load-modules?)) + (graphs (if references-graphs (lower-reference-graphs references-graphs #:system system @@ -763,32 +884,30 @@ The other arguments are as for 'derivation'." #:system system #:target target) (return #f))) - (guile (if guile-for-build - (return guile-for-build) - (default-guile-derivation system)))) + (guile -> (lowered-gexp-guile lowered)) + (builder (text-file script-name + (object->string + (lowered-gexp-sexp lowered))))) (mbegin %store-monad (set-grafting graft?) ;restore the initial setting (raw-derivation name (string-append (derivation->output-path guile) "/bin/guile") `("--no-auto-compile" - ,@(if (pair? %modules) - `("-L" ,(if (derivation? modules) - (derivation->output-path modules) - modules) - "-C" ,(derivation->output-path compiled)) - '()) - ,@(append-map extension-flags exts) + ,@(append-map (lambda (directory) + `("-L" ,directory)) + (lowered-gexp-load-path lowered)) + ,@(append-map (lambda (directory) + `("-C" ,directory)) + (lowered-gexp-load-compiled-path lowered)) ,builder) #:outputs outputs #:env-vars env-vars #:system system #:inputs `((,guile) (,builder) - ,@(if modules - `((,modules) (,compiled) ,@inputs) - inputs) - ,@(map list exts) + ,@(map gexp-input->tuple + (lowered-gexp-inputs lowered)) ,@(match graphs (((_ . inputs) ...) inputs) (_ '()))) @@ -804,6 +923,7 @@ The other arguments are as for 'derivation'." (define* (gexp-inputs exp #:key native?) "Return the input list for EXP. When NATIVE? is true, return only native references; otherwise, return only non-native references." + ;; TODO: Return records instead of tuples. (define (add-reference-inputs ref result) (match ref (($ (? gexp? exp) _ #t) diff --git a/tests/gexp.scm b/tests/gexp.scm index cee2c96610..23904fce2e 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -832,6 +832,43 @@ (built-derivations (list drv)) (return (equal? '(42 84) (call-with-input-file out read)))))) +(test-assertm "lower-gexp" + (mlet* %store-monad + ((extension -> %extension-package) + (extension-drv (package->derivation %extension-package)) + (coreutils-drv (package->derivation coreutils)) + (exp -> (with-extensions (list extension) + (with-imported-modules `((guix build utils)) + #~(begin + (use-modules (guix build utils) + (hg2g)) + #$coreutils:debug + mkdir-p + the-answer)))) + (lexp (lower-gexp exp + #:effective-version "2.0"))) + (define (matching-input drv output) + (lambda (input) + (and (eq? (gexp-input-thing input) drv) + (string=? (gexp-input-output input) output)))) + + (mbegin %store-monad + (return (and (find (matching-input extension-drv "out") + (lowered-gexp-inputs (pk 'lexp lexp))) + (find (matching-input coreutils-drv "debug") + (lowered-gexp-inputs lexp)) + (member (string-append + (derivation->output-path extension-drv) + "/share/guile/site/2.0") + (lowered-gexp-load-path lexp)) + (= 2 (length (lowered-gexp-load-path lexp))) + (member (string-append + (derivation->output-path extension-drv) + "/lib/guile/2.0/site-ccache") + (lowered-gexp-load-compiled-path lexp)) + (= 2 (length (lowered-gexp-load-compiled-path lexp))) + (eq? (lowered-gexp-guile lexp) (%guile-for-build))))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text)))