;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix tests)
#:use-module (guix store)
#:use-module (guix monads)
+ #:use-module (guix grafts)
#:use-module (guix derivations)
- #:use-module ((guix packages)
- #:select (package-derivation %current-system))
+ #:use-module (guix packages)
#:use-module (gnu packages)
#:use-module (gnu packages bootstrap)
#:use-module ((gnu packages base) #:select (coreutils))
(define %store
(open-connection-for-tests))
+;; Globally disable grafts because they can trigger early builds.
+(%graft? #f)
+
(define %monads
- (list %identity-monad %store-monad))
+ (list %identity-monad %store-monad %state-monad))
(define %monad-run
(list identity
- (cut run-with-store %store <>)))
+ (cut run-with-store %store <>)
+ (cut run-with-state <> '())))
+
+(define-syntax-rule (values->list exp)
+ (call-with-values (lambda () exp)
+ list))
\f
(test-begin "monads")
(test-assert "lift"
(every (lambda (monad run)
- (let ((f (lift1 1+ monad)))
+ (let ((f (lift1 1+ monad))
+ (g (apply lift1 1+ (list monad))))
(with-monad monad
(let ((number (random 777)))
(= (run (>>= (return number) f))
+ (run (>>= (return number) g))
(1+ number))))))
%monads
%monad-run))
+(test-assert ">>= with more than two arguments"
+ (every (lambda (monad run)
+ (let ((1+ (lift1 1+ monad))
+ (2* (lift1 (cut * 2 <>) monad)))
+ (with-monad monad
+ (let ((number (random 777)))
+ (= (run (>>= (return number)
+ 1+ 1+ 1+
+ 2* 2* 2*))
+ (* 8 (+ number 3)))))))
+ %monads
+ %monad-run))
+
(test-assert "mbegin"
(every (lambda (monad run)
(with-monad monad
(call-with-input-file b get-string-all))))
#:guile-for-build (package-derivation %store %bootstrap-guile)))
-(define derivation-expression
- (@@ (guix monads) derivation-expression))
-
-(test-assert "mlet* + derivation-expression"
- (run-with-store %store
- (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile"))
- (gdrv (package->derivation %bootstrap-guile))
- (exp -> `(let ((out (assoc-ref %outputs "out")))
- (mkdir out)
- (symlink ,guile
- (string-append out "/guile-rocks"))))
- (drv (derivation-expression "rocks" exp
- #:inputs
- `(("g" ,gdrv))))
- (out -> (derivation->output-path drv))
- (built? (built-derivations (list drv))))
- (return (and built?
- (equal? guile
- (readlink (string-append out "/guile-rocks"))))))
- #:guile-for-build (package-derivation %store %bootstrap-guile)))
-
(test-assert "mapm"
(every (lambda (monad run)
(with-monad monad
- (equal? (run (mapm monad (lift1 1+ monad) (map return (iota 10))))
+ (equal? (run (mapm monad (lift1 1+ monad) (iota 10)))
(map 1+ (iota 10)))))
%monads
%monad-run))
(test-assert "anym"
(every (lambda (monad run)
(eq? (run (with-monad monad
- (let ((lst (list (return 1) (return 2) (return 3))))
- (anym monad
- (lambda (x)
- (and (odd? x) 'odd!))
- lst))))
+ (anym monad
+ (lift1 (lambda (x)
+ (and (odd? x) 'odd!))
+ monad)
+ (append (make-list 1000 0)
+ (list 1 2)))))
'odd!))
%monads
%monad-run))
-(test-end "monads")
+(test-equal "set-current-state"
+ (list '(a a d) 'd)
+ (values->list
+ (run-with-state
+ (mlet* %state-monad ((init (current-state))
+ (init2 (set-current-state 'b)))
+ (mbegin %state-monad
+ (set-current-state 'c)
+ (set-current-state 'd)
+ (mlet %state-monad ((last (current-state)))
+ (return (list init init2 last)))))
+ 'a)))
-\f
-(exit (= (test-runner-fail-count (test-runner-current)) 0))
+(test-equal "state-push etc."
+ (list '((z . 2) (p . (1)) (a . (1))) '(2 1))
+ (values->list
+ (run-with-state
+ (mbegin %state-monad
+ (state-push 1) ;(1)
+ (state-push 2) ;(2 1)
+ (mlet* %state-monad ((z (state-pop)) ;(1)
+ (p (current-state))
+ (a (state-push z))) ;(2 1)
+ (return `((z . ,z) (p . ,p) (a . ,a)))))
+ '())))
+
+(test-end "monads")