[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
17/29: packages: Core procedures are written in monadic style.
From: |
guix-commits |
Subject: |
17/29: packages: Core procedures are written in monadic style. |
Date: |
Mon, 8 Mar 2021 06:24:52 -0500 (EST) |
civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.
commit e39fe224949c077f0f479232d3408c2fc19dc3b3
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Jun 28 21:57:16 2017 +0200
packages: Core procedures are written in monadic style.
This plays better with the functional object cache, which is no longer
lost across calls to procedures created by 'store-lift'.
* guix/packages.scm (input-graft, input-cross-graft): Remove 'store'
parameter. Return a monadic procedure.
(bag-grafts): Remove 'store' parameter and turn into a monadic
procedure.
(graft-derivation*): New procedure.
(cached): Remove clause to match syntax without (=> CACHE).
(package-grafts): Define using 'store-lower'.
(package-grafts*): New procedure, from former 'package-grafts'. Remove
'store' parameter and turn into a monadic procedure.
(package->derivation): Rewrite using 'mcached' and a monadic variant of
the former 'package-derivation' procedure.
(package->cross-derivation): Likewise.
(package-derivation, package-cross-derivation): Rewrite in terms of
'store-lower'.
(%graft-cache): Remove.
---
guix/packages.scm | 254 +++++++++++++++++++++++++++++-------------------------
1 file changed, 136 insertions(+), 118 deletions(-)
diff --git a/guix/packages.scm b/guix/packages.scm
index 845985b..4080af9 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1192,9 +1192,7 @@ Return the cached result when available."
(#f (cache! cache package key thunk))
(value value)))
(#f
- (cache! cache package key thunk)))))
- ((_ package system body ...)
- (cached (=> %derivation-cache) package system body ...))))
+ (cache! cache package key thunk)))))))
(define* (expand-input package input #:key native?)
"Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is
@@ -1270,45 +1268,51 @@ and return it."
(&package-error
(package package))))))))))))
-(define %graft-cache
- ;; 'eq?' cache mapping package objects to a graft corresponding to their
- ;; replacement package.
- (make-weak-key-hash-table 200))
+(define (input-graft system)
+ "Return a monadic procedure that, given a package with a graft, returns a
+graft, and #f otherwise."
+ (with-monad %store-monad
+ (match-lambda*
+ (((? package? package) output)
+ (let ((replacement (package-replacement package)))
+ (if replacement
+ ;; XXX: We should use a separate cache instead of abusing the
+ ;; object cache.
+ (mcached (mlet %store-monad ((orig (package->derivation package
system
+ #:graft?
#f))
+ (new (package->derivation
replacement system
+ #:graft?
#t)))
+ (return (graft
+ (origin orig)
+ (origin-output output)
+ (replacement new)
+ (replacement-output output))))
+ package 'graft output system)
+ (return #f))))
+ (_
+ (return #f)))))
-(define (input-graft store system)
- "Return a procedure that, given a package with a replacement and an output
name,
-returns a graft, and #f otherwise."
- (match-lambda*
- (((? package? package) output)
- (let ((replacement (package-replacement package)))
- (and replacement
- (cached (=> %graft-cache) package (cons output system)
- (let ((orig (package-derivation store package system
- #:graft? #f))
- (new (package-derivation store replacement system
- #:graft? #t)))
- (graft
- (origin orig)
- (origin-output output)
- (replacement new)
- (replacement-output output)))))))))
-
-(define (input-cross-graft store target system)
+(define (input-cross-graft target system)
"Same as 'input-graft', but for cross-compilation inputs."
- (match-lambda*
- (((? package? package) output)
- (let ((replacement (package-replacement package)))
- (and replacement
- (let ((orig (package-cross-derivation store package target system
- #:graft? #f))
- (new (package-cross-derivation store replacement
- target system
- #:graft? #t)))
- (graft
- (origin orig)
- (origin-output output)
- (replacement new)
- (replacement-output output))))))))
+ (with-monad %store-monad
+ (match-lambda*
+ (((? package? package) output)
+ (let ((replacement (package-replacement package)))
+ (if replacement
+ (mlet %store-monad ((orig (package->cross-derivation package
+ target system
+ #:graft? #f))
+ (new (package->cross-derivation replacement
+ target system
+ #:graft?
#t)))
+ (return (graft
+ (origin orig)
+ (origin-output output)
+ (replacement new)
+ (replacement-output output))))
+ (return #f))))
+ (_
+ (return #f)))))
(define* (fold-bag-dependencies proc seed bag
#:key (native? #t))
@@ -1343,7 +1347,7 @@ dependencies; otherwise, restrict to target dependencies."
((head . tail)
(loop tail result visited)))))
-(define* (bag-grafts store bag)
+(define* (bag-grafts bag)
"Return the list of grafts potentially applicable to BAG. Potentially
applicable grafts are collected by looking at direct or indirect dependencies
of BAG that have a 'replacement'. Whether a graft is actually applicable
@@ -1352,46 +1356,55 @@ to (see 'graft-derivation'.)"
(define system (bag-system bag))
(define target (bag-target bag))
- (define native-grafts
- (let ((->graft (input-graft store system)))
- (parameterize ((%current-system system)
- (%current-target-system #f))
- (fold-bag-dependencies (lambda (package output grafts)
- (match (->graft package output)
- (#f grafts)
- (graft (cons graft grafts))))
- '()
- bag))))
-
- (define target-grafts
- (if target
- (let ((->graft (input-cross-graft store target system)))
+ (mlet %store-monad
+ ((native-grafts
+ (let ((->graft (input-graft system)))
(parameterize ((%current-system system)
- (%current-target-system target))
+ (%current-target-system #f))
(fold-bag-dependencies (lambda (package output grafts)
- (match (->graft package output)
- (#f grafts)
- (graft (cons graft grafts))))
- '()
- bag
- #:native? #f)))
- '()))
-
- ;; We can end up with several identical grafts if we stumble upon packages
- ;; that are not 'eq?' but map to the same derivation (this can happen when
- ;; using things like 'package-with-explicit-inputs'.) Hence the
- ;; 'delete-duplicates' call.
- (delete-duplicates
- (append native-grafts target-grafts)))
-
-(define* (package-grafts store package
- #:optional (system (%current-system))
- #:key target)
+ (mlet %store-monad ((grafts grafts))
+ (>>= (->graft package output)
+ (match-lambda
+ (#f (return grafts))
+ (graft (return (cons graft
grafts)))))))
+ (return '())
+ bag))))
+
+ (target-grafts
+ (if target
+ (let ((->graft (input-cross-graft target system)))
+ (parameterize ((%current-system system)
+ (%current-target-system target))
+ (fold-bag-dependencies
+ (lambda (package output grafts)
+ (mlet %store-monad ((grafts grafts))
+ (>>= (->graft package output)
+ (match-lambda
+ (#f (return grafts))
+ (graft (return (cons graft grafts)))))))
+ (return '())
+ bag
+ #:native? #f)))
+ (return '()))))
+
+ ;; We can end up with several identical grafts if we stumble upon packages
+ ;; that are not 'eq?' but map to the same derivation (this can happen when
+ ;; using things like 'package-with-explicit-inputs'.) Hence the
+ ;; 'delete-duplicates' call.
+ (return (delete-duplicates
+ (append native-grafts target-grafts)))))
+
+(define* (package-grafts* package
+ #:optional (system (%current-system))
+ #:key target)
"Return the list of grafts applicable to PACKAGE as built for SYSTEM and
TARGET."
(let* ((package (or (package-replacement package) package))
(bag (package->bag package system target)))
- (bag-grafts store bag)))
+ (bag-grafts bag)))
+
+(define package-grafts
+ (store-lower package-grafts*))
(define-inlinable (derivation=? drv1 drv2)
"Return true if DRV1 and DRV2 are equal."
@@ -1431,7 +1444,6 @@ error reporting."
;; It's possible that INPUTS contains packages that are not 'eq?' but
;; that lead to the same derivation. Delete those duplicates to avoid
;; issues down the road, such as duplicate entries in '%build-inputs'.
- ;; TODO: Change to monadic style.
(apply (bag-build bag) (bag-name bag)
(delete-duplicates input-drvs input=?)
#:search-paths paths
@@ -1481,51 +1493,57 @@ This is an internal procedure."
(define bag->derivation*
(store-lower bag->derivation))
-(define* (package-derivation store package
- #:optional (system (%current-system))
- #:key (graft? (%graft?)))
+(define graft-derivation*
+ (store-lift graft-derivation))
+
+(define* (package->derivation package
+ #:optional (system (%current-system))
+ #:key (graft? (%graft?)))
"Return the <derivation> object of PACKAGE for SYSTEM."
;; Compute the derivation and cache the result. Caching is important
;; because some derivations, such as the implicit inputs of the GNU build
;; system, will be queried many, many times in a row.
- (cached package (cons system graft?)
- (let* ((bag (package->bag package system #f #:graft? graft?))
- (drv (bag->derivation* store bag package)))
- (if graft?
- (match (bag-grafts store bag)
- (()
- drv)
- (grafts
- (let ((guile (package-derivation store (guile-for-grafts)
- system #:graft? #f)))
- ;; TODO: As an optimization, we can simply graft the tip
- ;; of the derivation graph since 'graft-derivation'
- ;; recurses anyway.
- (graft-derivation store drv grafts
- #:system system
- #:guile guile))))
- drv))))
-
-(define* (package-cross-derivation store package target
- #:optional (system (%current-system))
- #:key (graft? (%graft?)))
+ (mcached (mlet* %store-monad ((bag -> (package->bag package system #f
+ #:graft? graft?))
+ (drv (bag->derivation bag package)))
+ (if graft?
+ (>>= (bag-grafts bag)
+ (match-lambda
+ (()
+ (return drv))
+ (grafts
+ (mlet %store-monad ((guile (package->derivation
+ (default-guile)
+ system #:graft? #f)))
+ (graft-derivation* drv grafts
+ #:system system
+ #:guile guile)))))
+ (return drv)))
+ package system #f graft?))
+
+(define* (package->cross-derivation package target
+ #:optional (system (%current-system))
+ #:key (graft? (%graft?)))
"Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
system identifying string)."
- (cached package (list system target graft?)
- (let* ((bag (package->bag package system target #:graft? graft?))
- (drv (bag->derivation* store bag package)))
- (if graft?
- (match (bag-grafts store bag)
- (()
- drv)
- (grafts
- (graft-derivation store drv grafts
- #:system system
- #:guile
- (package-derivation store
(guile-for-grafts)
- system #:graft? #f))))
- drv))))
+ (mcached (mlet* %store-monad ((bag -> (package->bag package system target
+ #:graft? graft?))
+ (drv (bag->derivation bag package)))
+ (if graft?
+ (>>= (bag-grafts bag)
+ (match-lambda
+ (()
+ (return drv))
+ (grafts
+ (mlet %store-monad ((guile (package->derivation
+ (default-guile)
+ system #:graft? #f)))
+ (graft-derivation* drv grafts
+ #:system system
+ #:guile guile)))))
+ (return drv)))
+ package system target graft?))
(define* (package-output store package
#:optional (output "out") (system (%current-system)))
@@ -1573,11 +1591,11 @@ unless you know what you are doing."
out)
store))))
-(define package->derivation
- (store-lift package-derivation))
+(define package-derivation
+ (store-lower package->derivation))
-(define package->cross-derivation
- (store-lift package-cross-derivation))
+(define package-cross-derivation
+ (store-lower package->cross-derivation))
(define-gexp-compiler (package-compiler (package <package>) system target)
;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
- 20/29: build-system: Use 'sexp->gexp' for plain sexps., (continued)
- 20/29: build-system: Use 'sexp->gexp' for plain sexps., guix-commits, 2021/03/08
- 21/29: build-system: Use 'input-tuples->gexp' and 'outputs->gexp'., guix-commits, 2021/03/08
- 02/29: store: Micro-optimize object cache lookup., guix-commits, 2021/03/08
- 28/29: grafts: Add 'without-grafting'., guix-commits, 2021/03/08
- 29/29: gexp: Allowed/disallowed references and graphs never refer to grafted inputs., guix-commits, 2021/03/08
- 14/29: build-system: Rewrite using gexps., guix-commits, 2021/03/08
- 15/29: packages: Turn 'bag->derivation' into a monadic procedure., guix-commits, 2021/03/08
- 16/29: packages: Simplify patch instantiation., guix-commits, 2021/03/08
- 25/29: tests: Refer to '%derivation-cache' in the right module., guix-commits, 2021/03/08
- 26/29: packages: 'expand-input' accepts any file-like object., guix-commits, 2021/03/08
- 17/29: packages: Core procedures are written in monadic style.,
guix-commits <=
- 19/29: gexp: Add 'sexp->gexp'., guix-commits, 2021/03/08
- 05/29: gexp: Micro-optimize sexp serialization., guix-commits, 2021/03/08
- 12/29: gexp: Add 'with-build-variables'., guix-commits, 2021/03/08
- 18/29: packages: Default origin 'patch-flags' is a gexp., guix-commits, 2021/03/08
- 22/29: gexp: Honor #:target in 'compiled-modules'., guix-commits, 2021/03/08
- 23/29: packages: '%standard-patch-inputs' is not influenced by '%current-target-system'., guix-commits, 2021/03/08
- 24/29: download: 'url-fetch/tarbomb' and 'url-fetch/zipbomb' refer to native tools., guix-commits, 2021/03/08
- 27/29: packages: Call 'bag-grafts' only on the tip of the package graph., guix-commits, 2021/03/08