From 8c855ecf741b99f239f147dabf15937f81fd2637 Mon Sep 17 00:00:00 2001 From: "Samuel B. Johnson" Date: Fri, 29 Nov 2024 07:36:22 -0600 Subject: [PATCH] :sparkles: 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 | 56 ++++++++++++++++++++++++++++++++++++ src/list.lisp | 6 ++-- src/package.lisp | 7 +++++ test/bare-function-test.lisp | 1 + test/bare-state-test.lisp | 1 + test/bare-test.lisp | 1 + test/contextual-test.lisp | 1 + test/list-test.lisp | 14 +++++++++ test/optional-test.lisp | 1 + test/thunk-test.lisp | 1 + test/unitary-list-test.lisp | 1 + 11 files changed, 88 insertions(+), 2 deletions(-) diff --git a/src/contextual.lisp b/src/contextual.lisp index a630b15..e33121d 100644 --- a/src/contextual.lisp +++ b/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)) diff --git a/src/list.lisp b/src/list.lisp index 89f66e2..c7c03f3 100644 --- a/src/list.lisp +++ b/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)) diff --git a/src/package.lisp b/src/package.lisp index 5a7f3aa..b9d375b 100644 --- a/src/package.lisp +++ b/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)) diff --git a/test/bare-function-test.lisp b/test/bare-function-test.lisp index c1a3def..762d2cd 100644 --- a/test/bare-function-test.lisp +++ b/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) diff --git a/test/bare-state-test.lisp b/test/bare-state-test.lisp index 638b29c..bdcf5c4 100644 --- a/test/bare-state-test.lisp +++ b/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) diff --git a/test/bare-test.lisp b/test/bare-test.lisp index 3cddc5d..2f84aa9 100644 --- a/test/bare-test.lisp +++ b/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) diff --git a/test/contextual-test.lisp b/test/contextual-test.lisp index 2d27134..2157253 100644 --- a/test/contextual-test.lisp +++ b/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) diff --git a/test/list-test.lisp b/test/list-test.lisp index 57d60c2..7174f69 100644 --- a/test/list-test.lisp +++ b/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)))))) diff --git a/test/optional-test.lisp b/test/optional-test.lisp index 19501f6..b391b7e 100644 --- a/test/optional-test.lisp +++ b/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) diff --git a/test/thunk-test.lisp b/test/thunk-test.lisp index 26fcc70..1d34d4d 100644 --- a/test/thunk-test.lisp +++ b/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) diff --git a/test/unitary-list-test.lisp b/test/unitary-list-test.lisp index 69a2b37..b493644 100644 --- a/test/unitary-list-test.lisp +++ b/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)