diff options
author | Ludovic Courtès <ludo@gnu.org> | 2022-10-14 21:51:18 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2022-10-22 01:46:54 +0200 |
commit | 5f0febcd459d103e6078e688aa28d5d832d82a60 (patch) | |
tree | 890bb225ac10a325e593afe1161c0f12d8a3cc61 | |
parent | b544f460989a6189af111bb3ff6752cabdf23abc (diff) | |
download | guix-5f0febcd459d103e6078e688aa28d5d832d82a60.tar.gz |
grafts: Move '%graft?' and related bindings to (guix store).
The goal is to allow (guix grafts) to use (guix gexp) without introducing a cycle between these two modules. * guix/grafts.scm (%graft?, call-without-grafting, without-grafting) (set-grafting, grafting?): Move to... * guix/store.scm: ... here.
-rw-r--r-- | guix/grafts.scm | 41 | ||||
-rw-r--r-- | guix/store.scm | 36 |
2 files changed, 41 insertions, 36 deletions
diff --git a/guix/grafts.scm b/guix/grafts.scm index 0ffda8f9aa..252abfd8b3 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -39,12 +39,11 @@ graft-replacement-output graft-derivation - graft-derivation/shallow - - %graft? - without-grafting - set-grafting - grafting?)) + graft-derivation/shallow) + #:re-export (%graft? ;for backward compatibility + without-grafting + set-grafting + grafting?)) (define-record-type* <graft> graft make-graft graft? @@ -334,36 +333,6 @@ DRV, and graft DRV itself to refer to those grafted dependencies." (graft-replacement first) drv))))) - -;; The following might feel more at home in (guix packages) but since (guix -;; gexp), which is a lower level, needs them, we put them here. - -(define %graft? - ;; Whether to honor package grafts by default. - (make-parameter #t)) - -(define (call-without-grafting thunk) - (lambda (store) - (values (parameterize ((%graft? #f)) - (run-with-store store (thunk))) - store))) - -(define-syntax-rule (without-grafting mexp ...) - "Bind monadic expressions MEXP in a dynamic extent where '%graft?' is -false." - (call-without-grafting (lambda () (mbegin %store-monad mexp ...)))) - -(define-inlinable (set-grafting enable?) - ;; This monadic procedure enables grafting when ENABLE? is true, and - ;; disables it otherwise. It returns the previous setting. - (lambda (store) - (values (%graft? enable?) store))) - -(define-inlinable (grafting?) - ;; Return a Boolean indicating whether grafting is enabled. - (lambda (store) - (values (%graft?) store))) - ;; Local Variables: ;; eval: (put 'with-cache 'scheme-indent-function 1) ;; End: diff --git a/guix/store.scm b/guix/store.scm index 4d21c5ff1a..a36dce416e 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -182,6 +182,11 @@ interned-file interned-file-tree + %graft? + without-grafting + set-grafting + grafting? + %store-prefix store-path output-path @@ -2173,6 +2178,37 @@ connection, and return the result." ;;; +;;; Whether to enable grafts. +;;; + +(define %graft? + ;; Whether to honor package grafts by default. + (make-parameter #t)) + +(define (call-without-grafting thunk) + (lambda (store) + (values (parameterize ((%graft? #f)) + (run-with-store store (thunk))) + store))) + +(define-syntax-rule (without-grafting mexp ...) + "Bind monadic expressions MEXP in a dynamic extent where '%graft?' is +false." + (call-without-grafting (lambda () (mbegin %store-monad mexp ...)))) + +(define-inlinable (set-grafting enable?) + ;; This monadic procedure enables grafting when ENABLE? is true, and + ;; disables it otherwise. It returns the previous setting. + (lambda (store) + (values (%graft? enable?) store))) + +(define-inlinable (grafting?) + ;; Return a Boolean indicating whether grafting is enabled. + (lambda (store) + (values (%graft?) store))) + + +;;; ;;; Store paths. ;;; |