[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
16/16: packages: Core procedures are written in monadic style.
From: |
Ludovic Courtès |
Subject: |
16/16: packages: Core procedures are written in monadic style. |
Date: |
Wed, 28 Jun 2017 17:48:56 -0400 (EDT) |
civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.
commit 6ce5f33b866372bb97f950bd43e359df42850cd7
Author: Ludovic Courtès <address@hidden>
Date: 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'.
---
guix/packages.scm | 234 +++++++++++++++++++++++++++++-------------------------
1 file changed, 125 insertions(+), 109 deletions(-)
diff --git a/guix/packages.scm b/guix/packages.scm
index 36c5884..6bf8039 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -843,9 +843,7 @@ Return the cached result when available."
(#f
(cache! cache package key thunk))))
(#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
@@ -925,40 +923,44 @@ and return it."
;; replacement package.
(make-weak-key-hash-table 200))
-(define (input-graft store system)
- "Return a procedure that, given a package with a graft, returns a graft, and
-#f otherwise."
- (match-lambda
- ((? package? package)
- (let ((replacement (package-replacement package)))
- (and replacement
- (cached (=> %graft-cache) package system
- (let ((orig (package-derivation store package system
- #:graft? #f))
- (new (package-derivation store replacement system
- #:graft? #t)))
- (graft
- (origin orig)
- (replacement new)))))))
- (x
- #f)))
+(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)
+ (let ((replacement (package-replacement package)))
+ (if replacement
+ (mlet %store-monad ((orig (package->derivation package system
+ #:graft? #f))
+ (new (package->derivation replacement system
+ #:graft? #t)))
+ (return (graft
+ (origin orig)
+ (replacement new))))
+ (return #f))))
+ (_
+ (return #f)))))
-(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)
- (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)
- (replacement new))))))
- (_
- #f)))
+ (with-monad %store-monad
+ (match-lambda
+ ((? package? package)
+ (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)
+ (replacement new))))
+ (return #f))))
+ (_
+ (return #f)))))
(define* (fold-bag-dependencies proc seed bag
#:key (native? #t))
@@ -994,7 +996,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
@@ -1003,42 +1005,50 @@ to (see 'graft-derivation'.)"
(define system (bag-system bag))
(define target (bag-target bag))
- (define native-grafts
- (let ((->graft (input-graft store system)))
- (fold-bag-dependencies (lambda (package grafts)
- (match (->graft package)
- (#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)))
(fold-bag-dependencies (lambda (package grafts)
- (match (->graft package)
- (#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)
+ (match-lambda
+ (#f (return grafts))
+ (graft (return (cons graft
grafts)))))))
+ (return '())
+ bag)))
+
+ (target-grafts
+ (if target
+ (let ((->graft (input-cross-graft target system)))
+ (fold-bag-dependencies (lambda (package grafts)
+ (mlet %store-monad ((grafts grafts))
+ (>>= (->graft package)
+ (match-lambda
+ (#f grafts)
+ (graft (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* (bag->derivation bag #:optional context)
"Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
@@ -1105,51 +1115,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 (default-guile)
- 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 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 (default-guile)
- 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)))
@@ -1193,11 +1209,11 @@ cross-compilation target triplet."
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
- 12/16: gexp: 'local-file' calls 'canonicalize-path' only in rare cases., (continued)
- 12/16: gexp: 'local-file' calls 'canonicalize-path' only in rare cases., Ludovic Courtès, 2017/06/28
- 14/16: download: 'built-in-builders*' relies on the functional cache., Ludovic Courtès, 2017/06/28
- 01/16: gnu: bootstrap: Move 'use-modules' forms to the beginning of build expressions., Ludovic Courtès, 2017/06/28
- 15/16: store: Add 'GUIX_PROFILING' support for the object cache., Ludovic Courtès, 2017/06/28
- 09/16: Use 'mapm' instead of 'sequence' + 'map'., Ludovic Courtès, 2017/06/28
- 05/16: packages: Turn 'bag->derivation' into a monadic procedure., Ludovic Courtès, 2017/06/28
- 11/16: packages: Turn 'cache!' into a single-value-return cache., Ludovic Courtès, 2017/06/28
- 06/16: store: Add a functional object cache and use it in 'lower-object'., Ludovic Courtès, 2017/06/28
- 10/16: gexp: 'imported-files' takes file-like objects., Ludovic Courtès, 2017/06/28
- 07/16: DRAFT gexp: Handle list conversion to <gexp-input> in the expanded code., Ludovic Courtès, 2017/06/28
- 16/16: packages: Core procedures are written in monadic style.,
Ludovic Courtès <=
- 02/16: build-system: Rewrite using gexps., Ludovic Courtès, 2017/06/28