From d3994926797466f9337f0670822c91d2de7c62d9 Mon Sep 17 00:00:00 2001
From: Correl Roush <correl@gmail.com>
Date: Wed, 9 Jul 2014 01:32:56 -0400
Subject: [PATCH] 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 | 31 ++++++++++++++++++++-----------
 src/calrissian-util.lfe | 35 +++++++++++++++++++++++++++++++++++
 2 files changed, 55 insertions(+), 11 deletions(-)
 create mode 100644 src/calrissian-util.lfe

diff --git a/include/monad-tests.lfe b/include/monad-tests.lfe
index cb6b4b9..0e99d4a 100644
--- a/include/monad-tests.lfe
+++ b/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)
diff --git a/src/calrissian-util.lfe b/src/calrissian-util.lfe
new file mode 100644
index 0000000..3055123
--- /dev/null
+++ b/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)))
\ No newline at end of file