✨ Contextual has monoid contexts

Problem:
- Contextual does not have any contexts for monoids, despite the
fundamental nature of monoids.

Solution:
- Make a context class for monoid operators.
- Derive monoid operators from monad-plus operators.

contextual.asd

@@ -50,7 +50,8 @@
      (:file "bare-test")
      (:file "bare-function-test")
      (:file "bare-state-test")
-     (:file "unitary-list-test"))))
+     (:file "unitary-list-test")
+     (:file "monoid-test"))))
   :perform (test-op (o s)
              (symbol-call :binding-syntax-helpers-test :run-all-tests!)
              (symbol-call :contextual-internal-test :run-all-tests!)
@@ -63,4 +64,5 @@
              (symbol-call :contextual-bare-test :run-all-tests!)
              (symbol-call :contextual-bare-function-test :run-all-tests!)
              (symbol-call :contextual-bare-state-test :run-all-tests!)
-             (symbol-call :contextual-unitary-list-test :run-all-tests!)))
+             (symbol-call :contextual-unitary-list-test :run-all-tests!)
+             (symbol-call :contextual-monoid-test :run-all-tests!)))

src/contextual.lisp

@@ -25,6 +25,9 @@
 (defgeneric mzero-func (context))
 (defgeneric mplus-func (context))
 
+(defgeneric mempty-func (context))
+(defgeneric mappend-fuc (context))
+
 (defun ask-fmap ()
   (ctx-asks #'fmap-func))
 
@@ -79,6 +82,14 @@
 (defun ask-mplus ()
   (ctx-asks #'mplus-func))
 
+(defun ask-mempty ()
+  (ctx-asks #'mempty-func))
+
+(defun ask-mappend ()
+  (ctx-asks #'mappend-func))
+
+
+
 (defun fmap (f cmx)
   "Given a function and an embelished value, return a
 contexual expression with the embellishment of the result
@@ -212,10 +223,20 @@ the value extracted from the embellishment."
 
 (defun mplus (cmx cmy)
   (let-app/ctx ((mplus (ask-mplus))
-                (mx cmx)
-                (my cmy))
+                (mx (ctx-injest cmx))
+                (my (ctx-injest cmy)))
     (funcall mplus mx my)))
 
+(defun mempty ()
+  (let-app/ctx ((mempty (ask-mempty)))
+    (funcall mempty)))
+
+(defun mappend (cmx cmy)
+  (let-app/ctx ((mappend (ask-mappend))
+                (mx (ctx-injest cmx))
+                (my (ctx-injest cmy)))
+    (funcall mappend mx my)))
+
 (defmacro let*-fun (((var expr) &rest more-bindings) body &body more-body)
   (make-sequential-functor-binding
    'let*-fun
@@ -344,6 +365,19 @@ not occur in the arguments, return `NIL'."
 (deftype optional-function ()
   '(or null function))
 
+(defclass monoid-operators ()
+  ((mempty :initarg :mempty :type function :reader mempty-func)
+   (mappend :initarg :mappend :type function :reader mappend-func)))
+
+(defmethod initialize-instance ((obj monoid-operators) &rest args)
+  (let ((mempty (get-argument-or-slot-value args :mempty obj 'mempty)))
+    (assert mempty)
+    (setf (slot-value obj 'mempty) mempty))
+
+  (let ((mappend (get-argument-or-slot-value args :mappend obj 'mappend)))
+    (assert mappend)
+    (setf (slot-value obj 'mappend) mappend)))
+
 (defclass functor-operators ()
   ((fmap :initarg :fmap :type optional-function :reader fmap-func)))
 
@@ -570,22 +604,48 @@ not occur in the arguments, return `NIL'."
     (assert fail)
     (setf (slot-value obj 'fail) fail)))
 
-(defclass monad-plus-operators (monad-fail-operators)
+(defclass monad-plus-operators (monad-fail-operators monoid-operators)
   ((mzero :initarg :mzero :reader mzero-func)
    (mplus :initarg :mplus :reader mplus-func)))
 
 (defmethod initialize-instance ((obj monad-plus-operators) &rest args)
+  ;;
+  ;; ... set the slots for the monad plus operators
+  ;;
+
+  ;; mzero
   (let ((mzero (get-argument-or-slot-value args :mzero obj 'mzero)))
     (setf (slot-value obj 'mzero) mzero))
 
+  ;; mplus
   (let ((mplus (get-argument-or-slot-value args :mplus obj 'mplus)))
     (setf (slot-value obj 'mplus) mplus))
 
+  ;;
+  ;; ... set the slots for the monad-fail uperators
+  ;;
+
+  ;; fail
   (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))))))
+
+  ;;
+  ;; ... set the slots for the monoid operators
+  ;;
+
+  ;; mempty
+  (let ((mempty (or (get-argument-or-slot-value args :mempty obj 'mempty)
+                    (get-argument-or-slot-value args :mzero obj 'mzero))))
+    (setf (slot-value obj 'mempty) mempty))
+
+  ;; mappend
+  (let ((mappend (or (get-argument-or-slot-value args :mappend obj 'mappend)
+                     (get-argument-or-slot-value args :mplus obj 'mplus))))
+    (setf (slot-value obj 'mappend) mappend))
+
   (call-next-method))

src/package.lisp

@@ -91,9 +91,13 @@
    #:mzero #:mplus
    #:mzero-func #:mplus-func
 
+   #:mempty
+   #:mappend
+
    #:let*-fun #:let-fun #:let-app #:let*-mon #:let-mon
    #:lift #:lift2 #:lift3 #:lift4 #:lift5 #:lift6 #:lift7
 
+   #:monoid-operators
    #:functor-operators
    #:applicative-operators
    #:monad-operators

test/list-test.lisp

@@ -71,3 +71,13 @@
     (is (equal (append xs ys)
                (ctx-run +list+
                  (mplus xs ys))))))
+
+(test monoid-from-monad-plus
+  (is (equal '() (ctx-run +list+ (mempty))))
+  (let ((xs '(a b c))
+        (ys '(d e f)))
+    (is (equal xs (ctx-run +list+ (mappend xs (mempty)))))
+    (is (equal xs (ctx-run +list+ (mappend (mempty) xs))))
+    (is (equal (append xs ys)
+               (ctx-run +list+
+                 (mappend xs ys))))))

test/monoid-test.lisp

@@ -0,0 +1,48 @@
+(in-package :cl-user)
+
+(defpackage :contextual-monoid-test
+  (:use :cl :5am :contextual)
+  (:shadowing-import-from :5am :fail)
+  (:export #:run-all-tests!))
+
+(in-package :contextual-monoid-test)
+
+(defun run-all-tests! ()
+  (run! 'monoid))
+
+(def-suite monoid)
+
+(in-suite monoid)
+
+(test placeholder
+  (is (= (+ 1 2) 3)))
+
+
+(defun make-list-monoid-context ()
+    (make-instance 'monoid-operators
+      :mempty (lambda () nil)
+      :mappend #'append))
+
+
+(test monoid-context
+  (let ((context (make-list-monoid-context)))
+    (is (equal nil (ctx-run context (mempty))))
+    (let ((xs '(a b))
+          (ys '(c d)))
+      (is (equal xs (ctx-run context (mappend xs (mempty)))))
+      (is (equal ys (ctx-run context (mappend (mempty) ys))))
+      (is (equal (append xs ys) (ctx-run context (mappend xs ys)))))))
+
+
+(defun make-addition-monoid-context ()
+  (make-instance 'monoid-operators
+    :mempty (lambda () 0)
+    :mappend (lambda (x y) (+ x y))))
+
+(test addition-monoid-context
+  (let ((context (make-addition-monoid-context)))
+    (let ((x 3)
+          (y 4))
+      (is (= x (ctx-run context (mappend x (mempty)))))
+      (is (= y (ctx-run context (mappend (mempty) y))))
+      (is (= (+ x y) (ctx-run context (mappend x y)))))))