github/calrissian
1
0
Fork 0
mirror of https://github.com/correl/calrissian.git synced 2024-11-23 11:09:58 +00:00
Code Issues Projects Releases Packages Wiki Activity

Modify the monad test macros to work with state

Browse source 
If the monad being tested implements the new state behaviour, evaluate
the expected value and the result by running them both against a default
state before comparing them.
This commit is contained in:
Correl Roush 2014-07-09 01:32:56 -04:00
parent abf8291058
commit d399492679
2 changed files with 55 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
include/monad-tests.lfe
View file

@ -1,27 +1,36 @@
(defmacro evaluate-m (monad mval)
`(cond ((: calrissian-util implements? 'state ,monad)
(call ,monad 'run ,mval 'undefined))
('true ,mval)))
(defmacro is-equal-m (monad mval1 mval2)
`(is-equal (evaluate-m ,monad ,mval1)
(evaluate-m ,monad ,mval2)))
(defmacro test-monad-functions (monad)
`(progn
(deftest monad->>=
(is-equal (return ,monad 2)
(is-equal-m ,monad (return ,monad 2)
(>>= ,monad
(return ,monad 1)
(lambda (n) (return ,monad (+ 1 n))))))
(deftest monad->>
(is-equal (return ,monad 1)
(is-equal-m ,monad (return ,monad 1)
(>> ,monad
(return ,monad 5)
(return ,monad 1))))
(deftest monad-do
(is-equal (return ,monad 'ok)
(is-equal-m ,monad (return ,monad 'ok)
(do-m ,monad
(return ,monad 'ignored)
(return ,monad 'ok))))
(deftest monad-do-binding
(is-equal (return ,monad 9)
(is-equal-m ,monad (return ,monad 9)
(do-m ,monad
(a <- (return ,monad 3))
(return ,monad (* a a)))))
(deftest monad-sequence
(is-equal (return ,monad (list 1 2 3))
(is-equal-m ,monad (return ,monad (list 1 2 3))
(sequence ,monad (list (return ,monad 1)
(return ,monad 2)
(return ,monad 3)))))
@ -32,31 +41,31 @@
(deftest monad-left-identity
(let ((a 3)
(f (lambda (n) (return ,monad (* 3 n)))))
(is-equal (>>= ,monad (return ,monad a) f)
(is-equal-m ,monad (>>= ,monad (return ,monad a) f)
(funcall f a))))
(deftest monad-right-identity
(let ((m (return ,monad 3)))
(is-equal (>>= ,monad m (lambda (m') (return ,monad m')))
(is-equal-m ,monad (>>= ,monad m (lambda (m') (return ,monad m')))
m)))
(deftest monad-associativity
(let ((m (return ,monad 3))
(f (lambda (n) (return ,monad (* 3 n))))
(g (lambda (n) (return ,monad (+ 5 n)))))
(is-equal (>>= ,monad (>>= ,monad m f) g)
(is-equal-m ,monad (>>= ,monad (>>= ,monad m f) g)
(>>= ,monad m (lambda (x) (>>= ,monad (funcall f x) g))))))
(deftest monad-do-left-identity
(let ((a 3)
(f (lambda (n) (return ,monad (* 3 n)))))
(is-equal (do-m ,monad (a' <- (return ,monad a))
(is-equal-m ,monad (do-m ,monad (a' <- (return ,monad a))
(funcall f a'))
(do-m ,monad (funcall f a)))))
(deftest monad-do-right-identity
(let ((m (return ,monad 3)))
(is-equal (do-m ,monad (x <- m)
(is-equal-m ,monad (do-m ,monad (x <- m)
(return ,monad x))
(do-m ,monad m))))
@ -64,7 +73,7 @@
(let ((m (return ,monad 3))
(f (lambda (n) (return ,monad (* 3 n))))
(g (lambda (n) (return ,monad (+ 5 n)))))
(is-equal (do-m ,monad (y <- (do-m ,monad (x <- m)
(is-equal-m ,monad (do-m ,monad (y <- (do-m ,monad (x <- m)
(funcall f x)))
(funcall g y))
(do-m ,monad (x <- m)

35
src/calrissian-util.lfe Normal file
View file

@ -0,0 +1,35 @@
(defmodule calrissian-util
(export (module-info 1)
(module-info 2)
(implements? 2)
(exports? 2)))
(defun module-info
(((tuple module _args))
;; Report exported function arities as (arity - 1) to account for
;; the extra argument supplied to tuple modules
(let ((fix-info (lambda (info-plist)
(let* ((exports (: proplists get_value 'exports info-plist))
(fix-arity (match-lambda
;; module_info is added by the compiler and therefore remains as-is
(((tuple 'module_info arity)) (tuple 'module_info arity))
(((tuple fun arity)) (tuple fun (- arity 1)))))
(info-dict (: dict from_list info-plist))
(new-dict (: dict store 'exports (: lists map fix-arity exports) info-dict))
(new-plist (: dict to_list new-dict)))
new-plist))))
(funcall fix-info (module-info module))))
((module) (call module 'module_info)))
(defun module-info (module key)
(: proplists get_value key (module-info module)))
(defun implements? (behaviour module)
(let* ((exports (module-info module 'exports))
(exported? (lambda (definition) (: lists member definition exports))))
(: lists all exported?
(call behaviour 'behaviour_info 'callbacks))))
(defun exports? (definition module)
(: lists member definition
(module-info module 'exports)))