Modify the monad test macros to work with state

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.

include/monad-tests.lfe

@@ -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)

src/calrissian-util.lfe

@@ -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)))