ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

grafts: Move '%graft?' and related bindings to (guix store).

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2022-10-14 21:51:18 +02:00
parent b544f46098
commit 5f0febcd45
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 41 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
guix/grafts.scm
View file

@ -39,12 +39,11 @@ (define-module (guix grafts)
graft-replacement-output graft-replacement-output
graft-derivation graft-derivation
graft-derivation/shallow graft-derivation/shallow)
#:re-export (%graft? ;for backward compatibility
%graft? without-grafting
without-grafting set-grafting
set-grafting grafting?))
grafting?))
(define-record-type* <graft> graft make-graft (define-record-type* <graft> graft make-graft
graft? graft?
@ -334,36 +333,6 @@ (define* (graft-derivation store drv grafts
(graft-replacement first) (graft-replacement first)
drv))))) 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: ;; Local Variables:
;; eval: (put 'with-cache 'scheme-indent-function 1) ;; eval: (put 'with-cache 'scheme-indent-function 1)
;; End: ;; End:

36
guix/store.scm
View file

@ -182,6 +182,11 @@ (define-module (guix store)
interned-file interned-file
interned-file-tree interned-file-tree
%graft?
without-grafting
set-grafting
grafting?
%store-prefix %store-prefix
store-path store-path
output-path output-path
@ -2171,6 +2176,37 @@ (define* (run-with-store store mval
(set-store-connection-caches! store caches))) (set-store-connection-caches! store caches)))
result)))) 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. ;;; Store paths.