✨ monad fail and monad plus

Problem:
- The contextual library does not have a class representing
monad fail or monad plus.

Solution:
- Add monad fail and moad plus classes and functions for their
operators
- Modify the tests to deal with the collision between `FIVEAM:FAIL`
and `CONTEXTUAL:FAIL`

src/contextual.lisp

@@ -21,6 +21,10 @@
 (defgeneric lookup-func (context))
 (defgeneric local-func (context))
 
+(defgeneric fail-func (context))
+(defgeneric mzero-func (context))
+(defgeneric mplus-func (context))
+
 (defun ask-fmap ()
   (ctx-asks #'fmap-func))
 
@@ -66,6 +70,15 @@
 (defun ask-local ()
   (ctx-asks #'local-func))
 
+(defun ask-fail ()
+  (ctx-asks #'fail-func))
+
+(defun ask-mzero ()
+  (ctx-asks #'mzero-func))
+
+(defun ask-mplus ()
+  (ctx-asks #'mplus-func))
+
 (defun fmap (f cmx)
   "Given a function and an embelished value, return a
 contexual expression with the embellishment of the result
@@ -189,6 +202,20 @@ the value extracted from the embellishment."
                 (mx (ctx-injest cmx)))
     (funcall local f mx)))
 
+(defun fail (str)
+  (let-app/ctx ((fail (ask-fail)))
+    (funcall fail str)))
+
+(defun mzero ()
+  (let-app/ctx ((mzero (ask-mzero)))
+    (funcall mzero)))
+
+(defun mplus (cmx cmy)
+  (let-app/ctx ((mplus (ask-mplus))
+                (mx cmx)
+                (my cmy))
+    (funcall mplus mx my)))
+
 (defmacro let*-fun (((var expr) &rest more-bindings) body &body more-body)
   (make-sequential-functor-binding
    'let*-fun
@@ -533,3 +560,32 @@ not occur in the arguments, return `NIL'."
   (let ((local (getf args :local)))
     (if local (setf (slot-value obj 'local) local)
         (error "`LOCAL' was not provided for `MONAD-ENVIRONMENT-OPERATORS'"))))
+
+(defclass monad-fail-operators (monad-operators)
+  ((fail :initarg :fail :reader fail-func)))
+
+(defmethod initialize-instance ((obj monad-fail-operators) &rest args)
+  (call-next-method)
+  (let ((fail (get-argument-or-slot-value args :fail obj 'fail)))
+    (assert fail)
+    (setf (slot-value obj 'fail) fail)))
+
+(defclass monad-plus-operators (monad-fail-operators)
+  ((mzero :initarg :mzero :reader mzero-func)
+   (mplus :initarg :mplus :reader mplus-func)))
+
+(defmethod initialize-instance ((obj monad-plus-operators) &rest args)
+  (let ((mzero (get-argument-or-slot-value args :mzero obj 'mzero)))
+    (setf (slot-value obj 'mzero) mzero))
+
+  (let ((mplus (get-argument-or-slot-value args :mplus obj 'mplus)))
+    (setf (slot-value obj 'mplus) mplus))
+
+  (let ((fail (get-argument-or-slot-value args :fail obj 'fail)))
+    (if fail (setf (slot-value obj 'fail) fail)
+        (let ((mzero (slot-value obj 'mzero)))
+          (setf (slot-value obj 'fail)
+                (lambda (str)
+                  (declare (ignore str))
+                  (funcall mzero))))))
+  (call-next-method))

src/list.lisp

@@ -19,6 +19,8 @@
        (recur xs nil)))))
 
 (define-constant +list+
-    (make-instance 'monad-operators
+    (make-instance 'monad-plus-operators
       :pure #'list
-      :flatmap #'list-flatmap))
+      :flatmap #'list-flatmap
+      :mzero (lambda () nil)
+      :mplus #'append))

src/package.lisp

@@ -86,6 +86,11 @@
    #:extract-func #:duplicate-func #:extend-func
    #:ask-func #:asks-func #:local-func
 
+   #:fail
+   #:fail-func
+   #:mzero #:mplus
+   #:mzero-func #:mplus-func
+
    #:let*-fun #:let-fun #:let-app #:let*-mon #:let-mon
    #:lift #:lift2 #:lift3 #:lift4 #:lift5 #:lift6 #:lift7
 
@@ -95,6 +100,8 @@
    #:comonad-operators
    #:trivial-operators
    #:monad-environment-operators
+   #:monad-fail-operators
+   #:monad-plus-operators
 
    #:ctx-run))
 

test/bare-function-test.lisp

@@ -2,6 +2,7 @@
 
 (defpackage :contextual-bare-function-test
   (:use :cl :5am :contextual :contextual-bare-function)
+  (:shadowing-import-from :contextual #:fail)
   (:export #:run-all-tests!))
 
 (in-package :contextual-bare-function-test)

test/bare-state-test.lisp

@@ -2,6 +2,7 @@
 
 (defpackage :contextual-bare-state-test
   (:use :cl :fiveam :trivia :contextual :contextual-bare-state)
+  (:shadowing-import-from :contextual #:fail)
   (:export #:run-all-tests!))
 
 (in-package :contextual-bare-state-test)

test/bare-test.lisp

@@ -1,6 +1,7 @@
 (in-package :cl-user)
 (defpackage :contextual-bare-test
   (:use :cl :5am :contextual :contextual-bare)
+  (:shadowing-import-from :contextual #:fail)
   (:export #:run-all-tests!))
 
 (in-package :contextual-bare-test)

test/contextual-test.lisp

@@ -2,6 +2,7 @@
 
 (defpackage :contextual-test
   (:use :cl :5am :contextual-utility :contextual)
+  (:shadowing-import-from :contextual #:fail)
   (:export #:run-all-tests!))
 
 (in-package :contextual-test)

test/list-test.lisp

@@ -2,6 +2,7 @@
 
 (defpackage :contextual-list-test
   (:use :cl :5am :contextual :contextual-list)
+  (:shadowing-import-from :contextual #:fail)
   (:export #:run-all-tests!))
 
 (in-package :contextual-list-test)
@@ -57,3 +58,16 @@
   (let ((xss '((1 2) (3 4))))
     (is (equal (loop for xs in xss appending xs)
                (ctx-run +list+ (flatten xss))))))
+
+(test monad-fail
+  (is (equal '() (ctx-run +list+ (fail "Yikes!")))))
+
+(test monad-plus
+  (is (equal '() (ctx-run +list+ (mzero))))
+  (let ((xs '(a b c))
+        (ys '(d e f)))
+    (is (equal xs (ctx-run +list+ (mplus xs (mzero)))))
+    (is (equal xs (ctx-run +list+ (mplus (mzero) xs))))
+    (is (equal (append xs ys)
+               (ctx-run +list+
+                 (mplus xs ys))))))

test/optional-test.lisp

@@ -2,6 +2,7 @@
 
 (defpackage :contextual-optional-test
   (:use :cl :5am :contextual-utility :contextual :contextual-optional)
+  (:shadowing-import-from :contextual #:fail)
   (:export #:run-all-tests))
 
 (in-package :contextual-optional-test)

test/thunk-test.lisp

@@ -2,6 +2,7 @@
 
 (defpackage :contextual-thunk-test
   (:use :cl :5am :contextual :contextual-thunk)
+  (:shadowing-import-from :contextual #:fail)
   (:export #:run-all-tests!))
 
 (in-package :contextual-thunk-test)

test/unitary-list-test.lisp

@@ -1,6 +1,7 @@
 (in-package :cl-user)
 (defpackage :contextual-unitary-list-test
   (:use :cl :5am :contextual :contextual-unitary-list)
+  (:shadowing-import-from :contextual #:fail)
   (:export :run-all-tests!))
 
 (in-package :contextual-unitary-list-test)