From 38a12f0f22841b76050a0cf5163cdc65b7f92193 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 18 Feb 2022 23:06:57 +0000 Subject: [PATCH] channels: Allow disabling grafts when computing derivations. --- build-aux/build-self.scm | 23 +++++++++++++++-------- guix/channels.scm | 19 +++++++++++-------- 2 files changed, 26 insertions(+), 16 deletions(-) diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index 02822a2ee8..0e7fc2907d 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -241,7 +241,8 @@ (define guile-gcrypt (define* (build-program source version #:optional (guile-version (effective-version)) - #:key (pull-version 0) (channel-metadata #f)) + #:key (pull-version 0) (channel-metadata #f) + (graft? #t)) "Return a program that computes the derivation to build Guix from SOURCE." (define select? ;; Select every module but (guix config) and non-Guix modules. @@ -316,6 +317,8 @@ (define fake-git (read-disable 'positions)) (use-modules (guix store) + (guix grafts) + (guix monads) (guix self) (guix derivations) (srfi srfi-1)) @@ -348,12 +351,14 @@ (define fake-git (%make-void-port "w")) (current-build-output-port sock)) (run-with-store store - (guix-derivation source version - #$guile-version - #:channel-metadata - '#$channel-metadata - #:pull-version - #$pull-version) + (mbegin %store-monad + (set-grafting #$graft?) + (guix-derivation source version + #$guile-version + #:channel-metadata + '#$channel-metadata + #:pull-version + #$pull-version)) #:system system)) derivation-file-name)))))) #:module-path (list source)))) @@ -398,6 +403,7 @@ (define* (build source #:key verbose? (version (date-version-string)) channel-metadata system + (graft? #t) (pull-version 0) ;; For the standalone Guix, default to Guile 3.0. For old @@ -415,7 +421,8 @@ (define* (build source ;; SOURCE. (mlet %store-monad ((build (build-program source version guile-version #:channel-metadata channel-metadata - #:pull-version pull-version)) + #:pull-version pull-version + #:graft? graft?)) (system (if system (return system) (current-system))) (home -> (getenv "HOME")) diff --git a/guix/channels.scm b/guix/channels.scm index 5f47834c10..3aba677534 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -658,7 +658,7 @@ (define (with-trivial-build-handler mvalue) store)))) (define* (build-from-source instance - #:key core verbose? (dependencies '()) system) + #:key core verbose? (dependencies '()) system graft?) "Return a derivation to build Guix from INSTANCE, using the self-build script contained therein. When CORE is true, build package modules under SOURCE using CORE, an instance of Guix. By default, build for the current @@ -703,13 +703,14 @@ (define script (build source #:verbose? verbose? #:version commit #:system system + #:graft? graft? #:channel-metadata (channel-instance->sexp instance) #:pull-version %pull-version)))) ;; Build a set of modules that extend Guix using the standard method. (standard-module-derivation name source core dependencies))) -(define* (build-channel-instance instance system +(define* (build-channel-instance instance system graft? #:optional core (dependencies '())) "Return, as a monadic value, the derivation for INSTANCE, a channel instance, for SYSTEM. DEPENDENCIES is a list of extensions providing Guile @@ -717,7 +718,8 @@ (define* (build-channel-instance instance system (build-from-source instance #:core core #:dependencies dependencies - #:system system)) + #:system system + #:graft? graft?)) (define (resolve-dependencies instances) "Return a procedure that, given one of the elements of INSTANCES, returns @@ -747,7 +749,7 @@ (define edges (lambda (instance) (vhash-foldq* cons '() instance edges))) -(define* (channel-instance-derivations instances #:key system) +(define* (channel-instance-derivations instances #:key system graft?) "Return the list of derivations to build INSTANCES, in the same order as INSTANCES. Build for the current system by default, or SYSTEM if specified." (define core-instance @@ -763,11 +765,11 @@ (define edges (define (instance->derivation instance) (mlet %store-monad ((system (if system (return system) (current-system)))) (mcached (if (eq? instance core-instance) - (build-channel-instance instance system) + (build-channel-instance instance system graft?) (mlet %store-monad ((core (instance->derivation core-instance)) (deps (mapm %store-monad instance->derivation (edges instance)))) - (build-channel-instance instance system core deps))) + (build-channel-instance instance system graft? core deps))) instance system))) @@ -869,7 +871,7 @@ (define (channel-instance->sexp instance) intro)))))) '())))) -(define* (channel-instances->manifest instances #:key system) +(define* (channel-instances->manifest instances #:key system (graft? #t)) "Return a profile manifest with entries for all of INSTANCES, a list of channel instances. By default, build for the current system, or SYSTEM if specified." @@ -889,7 +891,8 @@ (define (instance->entry instance drv) `((source ,(channel-instance->sexp instance))))))) (mlet* %store-monad ((derivations (channel-instance-derivations instances - #:system system)) + #:system system + #:graft? graft?)) (entries -> (map instance->entry instances derivations))) (return (manifest entries)))) -- 2.34.0