me
/
guix
Archived
1
0
Fork 0
Code

packages: Turn 'bag->derivation' into a monadic procedure. 

* guix/packages.scm (bag->derivation): Turn into a monadic procedure by
  remove 'store' parameter and removing the call to 'store-lower'.
  (bag->cross-derivation): Likewise.
  (bag->derivation*): New procedure.
  (package-derivation, package-cross-derivation): Use it instead of
  'bag->derivation'.
* tests/packages.scm ("bag->derivation"): Change to monadic style.
  ("bag->derivation, cross-compilation"): Likewise.
master
Ludovic Courtès 2015-04-04 22:05:15 +02:00
parent 7d873f194c
commit ba41f87ec7
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 15 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
guix/packages.scm
View File

@ -1420,13 +1420,12 @@ TARGET."
(derivation=? obj1 obj2)) (derivation=? obj1 obj2))
(equal? obj1 obj2)))))))) (equal? obj1 obj2))))))))
(define* (bag->derivation store bag (define* (bag->derivation bag #:optional context)
#:optional context)
"Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
a package object describing the context in which the call occurs, for improved a package object describing the context in which the call occurs, for improved
error reporting." error reporting."
(if (bag-target bag) (if (bag-target bag)
(bag->cross-derivation store bag) (bag->cross-derivation bag)
(let* ((system (bag-system bag)) (let* ((system (bag-system bag))
(inputs (bag-transitive-inputs bag)) (inputs (bag-transitive-inputs bag))
(input-drvs (map (cut expand-input context <> #:native? #t) (input-drvs (map (cut expand-input context <> #:native? #t)
@ -1442,15 +1441,13 @@ error reporting."
;; that lead to the same derivation. Delete those duplicates to avoid ;; that lead to the same derivation. Delete those duplicates to avoid
;; issues down the road, such as duplicate entries in '%build-inputs'. ;; issues down the road, such as duplicate entries in '%build-inputs'.
;; TODO: Change to monadic style. ;; TODO: Change to monadic style.
(apply (store-lower (bag-build bag)) (apply (bag-build bag) (bag-name bag)
store (bag-name bag)
(delete-duplicates input-drvs input=?) (delete-duplicates input-drvs input=?)
#:search-paths paths #:search-paths paths
#:outputs (bag-outputs bag) #:system system #:outputs (bag-outputs bag) #:system system
(bag-arguments bag))))) (bag-arguments bag)))))
(define* (bag->cross-derivation store bag (define* (bag->cross-derivation bag #:optional context)
#:optional context)
"Return the derivation to build BAG, which is actually a cross build. "Return the derivation to build BAG, which is actually a cross build.
Optionally, CONTEXT can be a package object denoting the context of the call. Optionally, CONTEXT can be a package object denoting the context of the call.
This is an internal procedure." This is an internal procedure."
@ -1480,9 +1477,7 @@ This is an internal procedure."
(_ '())) (_ '()))
all)))) all))))
;; TODO: Change to monadic style. (apply (bag-build bag) (bag-name bag)
(apply (store-lower (bag-build bag))
store (bag-name bag)
#:build-inputs (delete-duplicates build-drvs input=?) #:build-inputs (delete-duplicates build-drvs input=?)
#:host-inputs (delete-duplicates host-drvs input=?) #:host-inputs (delete-duplicates host-drvs input=?)
#:target-inputs (delete-duplicates target-drvs input=?) #:target-inputs (delete-duplicates target-drvs input=?)
@ -1492,6 +1487,9 @@ This is an internal procedure."
#:system system #:target target #:system system #:target target
(bag-arguments bag)))) (bag-arguments bag))))
(define bag->derivation*
(store-lower bag->derivation))
(define* (package-derivation store package (define* (package-derivation store package
#:optional (system (%current-system)) #:optional (system (%current-system))
#:key (graft? (%graft?))) #:key (graft? (%graft?)))
@ -1502,7 +1500,7 @@ This is an internal procedure."
;; system, will be queried many, many times in a row. ;; system, will be queried many, many times in a row.
(cached package (cons system graft?) (cached package (cons system graft?)
(let* ((bag (package->bag package system #f #:graft? graft?)) (let* ((bag (package->bag package system #f #:graft? graft?))
(drv (bag->derivation store bag package))) (drv (bag->derivation* store bag package)))
(if graft? (if graft?
(match (bag-grafts store bag) (match (bag-grafts store bag)
(() (()
@ -1525,7 +1523,7 @@ This is an internal procedure."
system identifying string)." system identifying string)."
(cached package (list system target graft?) (cached package (list system target graft?)
(let* ((bag (package->bag package system target #:graft? graft?)) (let* ((bag (package->bag package system target #:graft? graft?))
(drv (bag->derivation store bag package))) (drv (bag->derivation* store bag package)))
(if graft? (if graft?
(match (bag-grafts store bag) (match (bag-grafts store bag)
(() (()

8
tests/packages.scm
View File

@ -1243,12 +1243,13 @@
(parameterize ((%current-target-system #f)) (parameterize ((%current-target-system #f))
(bag-transitive-inputs bag))))) (bag-transitive-inputs bag)))))
(test-assert "bag->derivation" (test-assertm "bag->derivation"
(parameterize ((%graft? #f)) (parameterize ((%graft? #f))
(let ((bag (package->bag gnu-make)) (let ((bag (package->bag gnu-make))
(drv (package-derivation %store gnu-make))) (drv (package-derivation %store gnu-make)))
(parameterize ((%current-system "foox86-hurd")) ;should have no effect (parameterize ((%current-system "foox86-hurd")) ;should have no effect
(equal? drv (bag->derivation %store bag)))))) (mlet %store-monad ((bag-drv (bag->derivation bag)))
(return (equal? drv bag-drv)))))))
(test-assert "bag->derivation, cross-compilation" (test-assert "bag->derivation, cross-compilation"
(parameterize ((%graft? #f)) (parameterize ((%graft? #f))
@ -1257,7 +1258,8 @@
(drv (package-cross-derivation %store gnu-make target))) (drv (package-cross-derivation %store gnu-make target)))
(parameterize ((%current-system "foox86-hurd") ;should have no effect (parameterize ((%current-system "foox86-hurd") ;should have no effect
(%current-target-system "foo64-linux-gnu")) (%current-target-system "foo64-linux-gnu"))
(equal? drv (bag->derivation %store bag)))))) (mlet %store-monad ((bag-drv (bag->derivation bag)))
(return (equal? drv bag-drv)))))))
(when (or (not (network-reachable?)) (shebang-too-long?)) (when (or (not (network-reachable?)) (shebang-too-long?))
(test-skip 1)) (test-skip 1))