From 37aed9407e0ac0c317d9d28b6852b77d169fc776 Mon Sep 17 00:00:00 2001 From: "Samuel B. Johnson" Date: Thu, 28 Nov 2024 19:27:22 -0600 Subject: [PATCH] :truck: Move `DEFPACKAGE` forms to a single file Problem: - Having package definitions in multiple files make it difficult to quickly view packages and the symbols they are exporting. Solution: - Move all of the package definition forms to a single file. --- contextual.asd | 4 +- run-coverage | 3 - src/bare-function.lisp | 22 --- src/bare-state.lisp | 37 ++--- src/bare.lisp | 7 - src/contextual.lisp | 32 ---- src/derivation.lisp | 304 ++++++++++++++++++++++++++++++++++---- src/internal.lisp | 18 --- src/list.lisp | 6 - src/package.lisp | 155 +++++++++++++++++++ src/syntax-helpers.lisp | 19 --- src/thunk.lisp | 6 - src/unitary-list.lisp | 5 - src/utility.lisp | 11 -- test/derivation-test.lisp | 260 +++++++++++++++++++++++++++++++- 15 files changed, 711 insertions(+), 178 deletions(-) create mode 100644 src/package.lisp diff --git a/contextual.asd b/contextual.asd index 9c0dd6f..8e88132 100644 --- a/contextual.asd +++ b/contextual.asd @@ -14,8 +14,10 @@ :serial t :components ((:module "src" + :serial t :components - ((:file "utility") + ((:file "package") + (:file "utility") (:file "syntax-helpers") (:file "internal") (:file "derivation") diff --git a/run-coverage b/run-coverage index 96f3aba..a8aac0a 100755 --- a/run-coverage +++ b/run-coverage @@ -24,9 +24,6 @@ exit $? (declaim (optimize (sb-cover:store-coverage-data 0))) (asdf:oos 'asdf:load-op :contextual :force t) -(asdf:oos 'asdf:load-op :contextual/test :force t) - - (declaim (optimize sb-cover:store-coverage-data)) (asdf:oos 'asdf:load-op :contextual :force t) diff --git a/src/bare-function.lisp b/src/bare-function.lisp index 105b250..ee233fe 100644 --- a/src/bare-function.lisp +++ b/src/bare-function.lisp @@ -1,25 +1,3 @@ -(in-package :cl-user) - -(defpackage :contextual-bare-function - (:use :cl :binding-syntax-helpers :contextual :contextual-utility) - (:export #:make-bare-function-context - #:+bare-function+ - #:bf-run - #:bf-fmap - #:bf-pure - #:bf-fapply - #:bf-mreturn - #:bf-flatmap - #:bf-flatten - #:bf-ask - #:bf-lookup - #:bf-local - #:let*-fun/bf - #:let-fun/bf - #:let-app/bf - #:let*-mond/bf - #:let-mon/bf)) - (in-package :contextual-bare-function) (eval-when (:load-toplevel :compile-toplevel) diff --git a/src/bare-state.lisp b/src/bare-state.lisp index a600d28..61c4e10 100644 --- a/src/bare-state.lisp +++ b/src/bare-state.lisp @@ -1,19 +1,3 @@ -(in-package :cl-user) - - -(defpackage :contextual-bare-state - (:nicknames :bs) - (:use :cl :contextual :contextual-derivation) - (:export - #:bs-run #:bs-exec #:bs-eval - #:bs-fmap - #:bs-pure #:bs-fapply #:bs-product - #:bs-mreturn #:bs-flatmap #:bs-bind #:bs-flatten - #:bs-mget #:bs-mput #:bs-select #:bs-modify - #:let*-fun/bs #:let-fun/bs - #:let-app/bs - #:progn-mon/bs #:let*-mon/bs #:let-mon/bs)) - (in-package :contextual-bare-state) (defun bs-run (s mx) @@ -127,15 +111,24 @@ with the updated state." (defun bs-select (f) "Projects a value out of the current state by applying `F' to the result of `BS-MGET'." - (lambda (s) (list (funcall f s) s))) - -(derive-monad-interface bs - :fmap bs-fmap - :pure bs-pure - :fapply bs-fapply +(defun bs-state (mx) + "Embed a simple state action into the monad. For the +bare state monad, this is simply the identity funcion." + mx) + + +(derive-state-monad-interface bs + :state bs-state + :mput bs-mput + :select bs-select + :mget bs-mget + :modify bs-modify + :fmap bs-fmap + :pure bs-pure + :fapply bs-fapply :product bs-product :mreturn bs-mreturn :flatmap bs-flatmap diff --git a/src/bare.lisp b/src/bare.lisp index 90b4486..b437f4a 100644 --- a/src/bare.lisp +++ b/src/bare.lisp @@ -1,10 +1,3 @@ -(in-package :cl-user) - -(defpackage :contextual-bare - (:use :cl :contextual) - (:export #:make-bare-context)) - - (in-package :contextual-bare) (defun make-bare-context () diff --git a/src/contextual.lisp b/src/contextual.lisp index 330773e..a630b15 100644 --- a/src/contextual.lisp +++ b/src/contextual.lisp @@ -1,35 +1,3 @@ -(in-package :cl-user) - -(defpackage :contextual - (:use :cl :binding-syntax-helpers :contextual-internal :contextual-derivation) - (:export - #:fmap - #:pure #:fapply #:product - #:mreturn #:flatmap #:flatten - #:wrap #:unwrap - #:extract #:duplicate #:extend - #:expel - #:ask #:lookup #:local - - #:fmap-func - #:pure-func #:fapply-func #:product-func - #:flatmap-func #:flatten-func - #:wrap-func #:unwrap-func - #:extract-func #:duplicate-func #:extend-func - #:ask-func #:asks-func #:local-func - - #:let*-fun #:let-fun #:let-app #:let*-mon #:let-mon - #:lift #:lift2 #:lift3 #:lift4 #:lift5 #:lift6 #:lift7 - - #:functor-operators - #:applicative-operators - #:monad-operators - #:comonad-operators - #:trivial-operators - #:monad-environment-operators - - #:ctx-run)) - (in-package :contextual) (defgeneric fmap-func (context)) diff --git a/src/derivation.lisp b/src/derivation.lisp index 7926571..9b6f811 100644 --- a/src/derivation.lisp +++ b/src/derivation.lisp @@ -1,33 +1,10 @@ -(in-package :cl-user) - -(defpackage :contextual-derivation - (:use :cl :contextual-utility :binding-syntax-helpers) - (:export - #:defun/flatmap-to-fmap #:lambda/flatmap-to-fmap - #:defun/wrap-and-unwrap-to-fmap #:lambda/wrap-and-unwrap-to-fmap - #:defun/flatmap-to-flatten #:lambda/flatmap-to-flatten - #:defun/flatten-to-flatmap #:lambda/flatten-to-flatmap - #:defun/flatmap-to-fapply #:lambda/flatmap-to-fapply - #:defun/fapply-to-product #:lambda/fapply-to-product - #:defun/product-to-fapply #:lambda/product-to-fapply - #:defun/fapply-to-fmap #:lambda/fapply-to-fmap - #:defun/duplicate-to-extend #:lambda/duplicate-to-extend - #:defun/extend-to-duplicate #:lambda/extend-to-duplicate - #:defun/ask-to-lookup #:lambda/ask-to-lookup - #:defun/lookup-to-ask #:lambda/lookup-to-ask - - #:derive-functor-interface - #:derive-applicative-interface - #:derive-monad-interface - #:derive-environment-monad-interface - #:derive-trivial-interface - #:derive-comonad-interface)) - (in-package :contextual-derivation) (defmacro defun/flatmap-to-fmap (name &key flatmap mreturn) "Define a named function that performs functor mapping, as derived from `FLATMAP' and `MRETURN'" + (assert flatmap) + (assert mreturn) (with-syms (f mx x) `(defun ,name (,f ,mx) (,flatmap (lambda (,x) (,mreturn (funcall ,f ,x))) ,mx)))) @@ -35,6 +12,8 @@ as derived from `FLATMAP' and `MRETURN'" (defun lambda/flatmap-to-fmap (&key flatmap mreturn) "Return an unnamed function that performs functor mapping, as derived from `FLATMAP' and `MRETURN'" + (assert flatmap) + (assert mreturn) (flet ((flatmap (f mx) (funcall flatmap f mx)) (mreturn (x) (funcall mreturn x))) (lambda (f mx) @@ -43,6 +22,8 @@ as derived from `FLATMAP' and `MRETURN'" (defmacro defun/wrap-and-unwrap-to-fmap (name &key wrap unwrap) "Return and unnamed function that performs functor mapping, as derived from `WRAP' and `UNWRAP' for a trivial context" + (assert wrap) + (assert unwrap) (with-syms (f mx) `(defun ,name (,f ,mx) (,wrap (funcall ,f (,unwrap ,mx)))))) @@ -50,6 +31,8 @@ derived from `WRAP' and `UNWRAP' for a trivial context" (defun lambda/wrap-and-unwrap-to-fmap (&key wrap unwrap) "Return and unnamed function that performs functor mapping, as derived from `WRAP' and `UNWRAP' for a trivial context" + (assert wrap) + (assert unwrap) (flet ((wrap (x) (funcall wrap x)) (unwrap (mx) (funcall unwrap mx))) (lambda (f mx) (wrap (funcall f (unwrap mx)))))) @@ -58,6 +41,7 @@ derived from `WRAP' and `UNWRAP' for a trivial context" (defmacro defun/flatmap-to-flatten (name &key flatmap) "Define a named function that performs monadic flattening, as derived from `FLATMAP'." + (assert flatmap) (with-syms (mmx mx) `(defun ,name (,mmx) (,flatmap (lambda (,mx) ,mx) ,mmx)))) @@ -65,6 +49,7 @@ as derived from `FLATMAP'." (defun lambda/flatmap-to-flatten (&key flatmap) "Return an unnamed function that performs monadic flattening, as derived from `FLATMAP'." + (assert flatmap) (flet ((flatmap (f mx) (funcall flatmap f mx))) (lambda (mmx) (flatmap (lambda (mx) mx) mmx)))) @@ -72,6 +57,8 @@ as derived from `FLATMAP'." (defmacro defun/flatten-to-flatmap (name &key flatten fmap) "Define a named function performing monadic mapping, as derived from `FLATTEN' and `FMAP'" + (assert flatten) + (assert fmap) (with-syms (f mx) `(defun ,name (,f ,mx) (,flatten (,fmap ,f ,mx))))) @@ -277,6 +264,8 @@ to some-context with an identity function." (lambda (wx) (extend (lambda (wx) wx) wx)))) (defmacro defun/ask-to-lookup (name &key ask fmap documentation) + (assert ask) + (assert fmap) (let ((documentation (if documentation (list documentation) nil))) (with-syms (f) `(defun ,name (,f) @@ -284,6 +273,8 @@ to some-context with an identity function." (,fmap ,f (,ask)))))) (defun lambda/ask-to-lookup (&key ask fmap) + (assert ask) + (assert fmap) (flet ((ask () (funcall ask)) (fmap (f mx) (funcall fmap f mx))) (lambda (f) @@ -291,16 +282,171 @@ to some-context with an identity function." (defmacro defun/lookup-to-ask (name &key lookup documentation) + (assert lookup) (let ((documentation (if documentation (list documentation) nil))) `(defun ,name () ,@documentation (,lookup #'identity)))) (defun lambda/lookup-to-ask (&key lookup) + (assert lookup) (flet ((lookup (f) (funcall lookup f))) (lambda () (lookup #'identity)))) + +(defmacro defun/mget-to-state (name &key mget mput mreturn flatmap documentation) + (assert mget) + (assert mput) + (assert mreturn) + (assert flatmap) + (let ((documentation (if documentation (list documentation) nil))) + (with-syms (f s x ignored) + `(defun ,name (,f) + ,@documentation + (,flatmap (lambda (,s) + (destructuring-bind (,x ,s) (funcall ,f ,s) + (,flatmap (lambda (,ignored) (declare (ignore ignored)) + (,mreturn ,x)) + (,mput ,s)))) + (,mget)))))) + +(defun lambda/mget-to-state (&key mget flatmap) + (assert mget) + (assert flatmap) + (flet ((mget () (funcall mget)) + (flatmap (f mx) (funcall flatmap f mx))) + (lambda (f) + (flatmap (lambda (s) (funcall f s)) (mget))))) + + +;; FIXME: Surely, this isn't a minimal derivation of state. +(defmacro defun/select-to-state (name &key select mput mreturn flatmap documentation) + (assert select) + (assert mput) + (assert mreturn) + (assert flatmap) + (let ((documentation (if documentation (list documentation) nil))) + (with-syms (f x/s x s ignored) + `(defun ,name (,f) + ,@documentation + (,flatmap (lambda (,x/s) + (destructuring-bind (,x ,s) ,x/s + (,flatmap (lambda (,ignored) + (declare (ignore ,ignored)) + (,mreturn ,x)) + (,mput ,s)))) + (,select ,f)))))) + +(defun lambda/select-to-state (&key select mput mreturn flatmap) + (assert select) + (assert mput) + (assert mreturn) + (assert flatmap) + (flet ((select (f) (funcall select f)) + (mput (s) (funcall mput s)) + (mreturn (x) (funcall mreturn x)) + (bind (mx f) (funcall flatmap f mx))) + (lambda (f) + (bind (select f) + (lambda (x/s) + (destructuring-bind (x s) x/s + (bind (mput s) + (lambda (ignored) (declare (ignore ignored)) + (mreturn x))))))))) + +(defmacro defun/state-to-mget (name &key state documentation) + (assert state) + (let ((documentation (and documentation (list documentation)))) + (with-syms (s) + `(defun ,name () + ,@documentation + (,state (lambda (,s) (list ,s ,s))))))) + +(defun lambda/state-to-mget (&key state) + (assert state) + (flet ((state (f) (funcall state f))) + (lambda () (state (lambda (s) (list s s)))))) + +(defmacro defun/state-to-select (name &key state documentation) + (assert state) + (let ((documentation (and documentation (list documentation)))) + (with-syms (f s) + `(defun ,name (,f) + ,@documentation + (,state (lambda (,s) (list (funcall ,f ,s) ,s))))))) + +(defun lambda/state-to-select (&key state) + (assert state) + (flet ((state (f) (funcall state f))) + (lambda (f) (state (lambda (s) (list (funcall f s) s)))))) + +(defmacro defun/select-to-mget (name &key select documentation) + (assert select) + (let ((documentation (if documentation (list documentation) nil))) + `(defun ,name () + ,@documentation + (,select #'identity)))) + +(defun lambda/select-to-mget (&key select) + (assert select) + (flet ((select (f) (funcall select f))) + (lambda () (select #'identity)))) + + +(defmacro defun/mget-to-select (name &key mget fmap documentation) + (assert mget) + (assert fmap) + (let ((documentation (if documentation (list documentation) nil))) + (with-syms (fun) + `(defun ,name (,fun) + ,@documentation + (,fmap ,fun (,mget)))))) + +(defun lambda/mget-to-select (&key mget fmap) + (assert mget) + (assert fmap) + (flet ((mget () (funcall mget)) + (fmap (f mx) (funcall fmap f mx))) + (lambda (f) (fmap f (mget))))) + +(defmacro defun/modify-to-mput (name &key modify documentation) + (assert modify) + (let ((documentation (if documentation (list documentation) nil))) + (with-syms (s s-ignored) + `(defun ,name (,s) + ,@documentation + (,modify (lambda (,s-ignored) + (declare (ignore ,s-ignored)) + ,s)))))) + +(defun lambda/modify-to-mput (&key modify) + (assert modify) + (flet ((modify (f) (funcall modify f))) + (lambda (s) + (modify (lambda (s-ignored) + (declare (ignore s-ignored)) + s))))) + +(defmacro defun/mput-to-modify (name &key mput mget flatmap documentation) + (assert mput) + (assert mget) + (assert flatmap) + (let ((documentation (if documentation (list documentation) nil))) + (with-syms (f s) + `(defun ,name (,f) + ,@documentation + (,flatmap (lambda (,s) (,mput (funcall ,f ,s))) (,mget)))))) + +(defun lambda/mput-to-modify (&key mput mget flatmap) + (assert mput) + (assert mget) + (assert flatmap) + (flet ((mput (s) (funcall mput s)) + (mget () (funcall mget)) + (flatmap (f mx) (funcall flatmap f mx))) + (lambda (f) (flatmap (lambda (s) (mput (funcall f s))) (mget))))) + (defun make-functor-binding-interface ( tag &key fmap) (let ((let*-fun (format-symbol "LET*-FUN/~A" tag)) (let-fun (format-symbol "LET-FUN/~A" tag)) @@ -644,3 +790,111 @@ the fapply and fmap functions." `(progn ,@environment-monad-interface ',environment-monad-symbols))) + + +(defun make-state-monad-interface + (tag &key state mget select mput modify fmap pure fapply product mreturn flatmap flatten) + (if (and (or state mget select) (or mput modify)) + (multiple-value-bind (monad-interface monad-interface-symbols) + (make-monad-interface tag + :fmap fmap + :pure pure + :fapply fapply + :product product + :mreturn mreturn + :flatmap flatmap + :flatten flatten) + (let* ((state-name (if state state (format-symbol "~A-STATE" tag))) + (mget-name (if mget mget (format-symbol "~A-MGET" tag))) + (select-name (if select select (format-symbol "~A-SELECT" tag))) + (mput-name (if mput mput (format-symbol "~A-MPUT" tag))) + (modify-name (if modify modify (format-symbol "~A-MODIFY" tag))) + + + (state-def (when-missing state + (macroexpand + (if mget + `(defun/mget-to-state ,state-name + :mget ,mget-name + :mput ,mput-name + :mreturn ,(getf monad-interface-symbols :mreturn) + :flatmap ,(getf monad-interface-symbols :flatmap)) + `(defun/select-to-state ,state-name + :select ,select-name + :mput ,mput-name + :mreturn ,(getf monad-interface-symbols :mreturn) + :flatmap ,(getf monad-interface-symbols :flatmap)))))) + + (mget-def (when-missing mget + (if state + `(defun/state-to-mget ,mget-name + :state ,state-name) + `(defun/select-to-mget ,mget-name + :select ,select-name)))) + + (select-def (when-missing select + (if state + `(defun/state-to-select ,select-name + :state ,state-name) + `(defun/mget-to-select ,select-name + :mget ,mget-name + :fmap ,(getf monad-interface-symbols :fmap))))) + + (mput-def (when-missing mput + `(defun/modify-to-mput ,mput-name + :modify ,modify-name))) + + + (modify-def (when-missing modify + `(defun/mput-to-modify ,modify-name + :mput ,mput-name + :mget ,mget-name + :flatmap ,(getf monad-interface-symbols :flatmap))))) + (values + `(,@monad-interface + (declaim (ftype (function (t) t) ,state-name)) + ,@state-def + ,@mget-def + ,@select-def + ,@mput-def + ,@modify-def) + `(,@monad-interface-symbols + :mget ,mget-name + :select ,select-name + :mput ,mput-name + :modify ,modify-name)))) + (error (format nil "The input was not sufficient for deriving a state monad:~%~s" + `(:state ,state + :mget ,mget + :select ,select + :mput ,mput + :modify ,modify + :fmap ,fmap + :pure ,pure + :fapply ,fapply + :product ,product + :mreturn ,mreturn + :flatmap ,flatmap + :flatten ,flatten))))) + + +(defmacro derive-state-monad-interface + (tag &key state mget select mput modify fmap pure fapply product mreturn flatmap flatten) + "Derivive an interface for an environment monad" + (multiple-value-bind (state-monad-interface state-monad-symbols) + (make-state-monad-interface tag + :state state + :mget mget + :select select + :mput mput + :modify modify + :fmap fmap + :pure pure + :fapply fapply + :product product + :mreturn mreturn + :flatmap flatmap + :flatten flatten) + `(progn + ,@state-monad-interface + ',state-monad-symbols))) diff --git a/src/internal.lisp b/src/internal.lisp index 103be67..6fe1ccc 100644 --- a/src/internal.lisp +++ b/src/internal.lisp @@ -1,21 +1,3 @@ -(in-package :cl-user) -(defpackage :contextual-internal - (:use :cl :binding-syntax-helpers) - (:export #:contextual-p - #:ctx-run - #:ctx-return - #:ctx-injest - #:ctx-fmap - #:ctx-fapply - #:ctx-product - #:ctx-flatmap - #:ctx-flatten - #:ctx-ask - #:ctx-asks - #:let*-fun/ctx - #:let-app/ctx - #:let*-mon/ctx)) - (in-package :contextual-internal) (defstruct contextual func) diff --git a/src/list.lisp b/src/list.lisp index 2c59438..89f66e2 100644 --- a/src/list.lisp +++ b/src/list.lisp @@ -1,9 +1,3 @@ -(in-package :cl-user) - -(defpackage :contextual-list - (:use :cl :contextual-utility :contextual) - (:export #:+list+)) - (in-package :contextual-list) (eval-when (:load-toplevel :compile-toplevel) diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..5a7f3aa --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,155 @@ +(in-package :cl-user) + +(defpackage :contextual-utility + (:use :cl) + (:export #:with-syms + #:when-missing + #:define-constant + #:defunion + #:format-symbol + #:read-string)) + +(defpackage :binding-syntax-helpers + (:use :cl :contextual-utility) + (:export + #:make-monad-progn + #:make-sequential-functor-binding + #:make-sequential-monad-binding + #:make-parallel-monad-binding + #:make-parallel-applicative-binding + #:make-parallel-functor-binding + + #:make-sequential-functor-binding-ez + #:make-parallel-functor-binding-ez + #:make-parallel-applicative-binding-ez + #:make-monad-progn-ez + #:make-sequential-monad-binding-ez + #:make-parallel-monad-binding-ez)) + +(in-package :cl-user) +(defpackage :contextual-internal + (:use :cl :binding-syntax-helpers) + (:export #:contextual-p + #:ctx-run + #:ctx-return + #:ctx-injest + #:ctx-fmap + #:ctx-fapply + #:ctx-product + #:ctx-flatmap + #:ctx-flatten + #:ctx-ask + #:ctx-asks + #:let*-fun/ctx + #:let-app/ctx + #:let*-mon/ctx)) + +(defpackage :contextual-derivation + (:use :cl :contextual-utility :binding-syntax-helpers) + (:export + #:defun/flatmap-to-fmap #:lambda/flatmap-to-fmap + #:defun/wrap-and-unwrap-to-fmap #:lambda/wrap-and-unwrap-to-fmap + #:defun/flatmap-to-flatten #:lambda/flatmap-to-flatten + #:defun/flatten-to-flatmap #:lambda/flatten-to-flatmap + #:defun/flatmap-to-fapply #:lambda/flatmap-to-fapply + #:defun/fapply-to-product #:lambda/fapply-to-product + #:defun/product-to-fapply #:lambda/product-to-fapply + #:defun/fapply-to-fmap #:lambda/fapply-to-fmap + #:defun/duplicate-to-extend #:lambda/duplicate-to-extend + #:defun/extend-to-duplicate #:lambda/extend-to-duplicate + #:defun/ask-to-lookup #:lambda/ask-to-lookup + #:defun/lookup-to-ask #:lambda/lookup-to-ask + + #:derive-functor-interface + #:derive-applicative-interface + #:derive-monad-interface + #:derive-environment-monad-interface + #:derive-trivial-interface + #:derive-comonad-interface + #:derive-state-monad-interface)) + +(defpackage :contextual + (:use :cl :binding-syntax-helpers :contextual-internal :contextual-derivation) + (:export + #:fmap + #:pure #:fapply #:product + #:mreturn #:flatmap #:flatten + #:wrap #:unwrap + #:extract #:duplicate #:extend + #:expel + #:ask #:lookup #:local + + #:fmap-func + #:pure-func #:fapply-func #:product-func + #:flatmap-func #:flatten-func + #:wrap-func #:unwrap-func + #:extract-func #:duplicate-func #:extend-func + #:ask-func #:asks-func #:local-func + + #:let*-fun #:let-fun #:let-app #:let*-mon #:let-mon + #:lift #:lift2 #:lift3 #:lift4 #:lift5 #:lift6 #:lift7 + + #:functor-operators + #:applicative-operators + #:monad-operators + #:comonad-operators + #:trivial-operators + #:monad-environment-operators + + #:ctx-run)) + +(defpackage :contextual-bare + (:use :cl :contextual) + (:export #:make-bare-context)) + +(defpackage :contextual-bare-function + (:use :cl :binding-syntax-helpers :contextual :contextual-utility) + (:export #:make-bare-function-context + #:+bare-function+ + #:bf-run + #:bf-fmap + #:bf-pure + #:bf-fapply + #:bf-mreturn + #:bf-flatmap + #:bf-flatten + #:bf-ask + #:bf-lookup + #:bf-local + #:let*-fun/bf + #:let-fun/bf + #:let-app/bf + #:let*-mond/bf + #:let-mon/bf)) + +(defpackage :contextual-bare-state + (:nicknames :bs) + (:use :cl :contextual :contextual-derivation) + (:export + #:bs-run #:bs-exec #:bs-eval + #:bs-fmap + #:bs-pure #:bs-fapply #:bs-product + #:bs-mreturn #:bs-flatmap #:bs-bind #:bs-flatten + #:bs-mget #:bs-mput #:bs-select #:bs-modify + #:let*-fun/bs #:let-fun/bs + #:let-app/bs + #:progn-mon/bs #:let*-mon/bs #:let-mon/bs)) + +(defpackage :contextual-list + (:use :cl :contextual-utility :contextual) + (:export #:+list+)) + +(defpackage :contextual-optional + (:use :cl :trivia :contextual-utility :contextual) + (:export #:optional #:optional-p + #:just #:just-p + #:none #:none-p + #:make-optional-context)) + +(defpackage :contextual-thunk + (:use :cl :contextual) + (:export #:thunk #:thunk-wrap #:thunk-unwrap #:make-thunk-context)) + +(defpackage :contextual-unitary-list + (:use :cl :contextual) + (:export #:make-unitary-list-context #:unitary-list-p #:unitary-list)) diff --git a/src/syntax-helpers.lisp b/src/syntax-helpers.lisp index 26b4ae4..44ad08e 100644 --- a/src/syntax-helpers.lisp +++ b/src/syntax-helpers.lisp @@ -1,22 +1,3 @@ -(in-package :cl-user) - -(defpackage :binding-syntax-helpers - (:use :cl :contextual-utility) - (:export - #:make-monad-progn - #:make-sequential-functor-binding - #:make-sequential-monad-binding - #:make-parallel-monad-binding - #:make-parallel-applicative-binding - #:make-parallel-functor-binding - - #:make-sequential-functor-binding-ez - #:make-parallel-functor-binding-ez - #:make-parallel-applicative-binding-ez - #:make-monad-progn-ez - #:make-sequential-monad-binding-ez - #:make-parallel-monad-binding-ez)) - (in-package :binding-syntax-helpers) (defun binding-pair-p (x) diff --git a/src/thunk.lisp b/src/thunk.lisp index e44fcea..2d8f485 100644 --- a/src/thunk.lisp +++ b/src/thunk.lisp @@ -1,9 +1,3 @@ -(in-package :cl-user) - -(defpackage :contextual-thunk - (:use :cl :contextual) - (:export #:thunk #:thunk-wrap #:thunk-unwrap #:make-thunk-context)) - (in-package :contextual-thunk) (defmacro thunk (&rest exprs) diff --git a/src/unitary-list.lisp b/src/unitary-list.lisp index cb2169c..8b1b74b 100644 --- a/src/unitary-list.lisp +++ b/src/unitary-list.lisp @@ -1,8 +1,3 @@ -(in-package :cl-user) -(defpackage :contextual-unitary-list - (:use :cl :contextual) - (:export #:make-unitary-list-context #:unitary-list-p #:unitary-list)) - (in-package :contextual-unitary-list) (defun unitary-list-p (arg) diff --git a/src/utility.lisp b/src/utility.lisp index 547eb6d..370494a 100644 --- a/src/utility.lisp +++ b/src/utility.lisp @@ -1,14 +1,3 @@ -(in-package :cl-user) - -(defpackage :contextual-utility - (:use :cl) - (:export #:with-syms - #:when-missing - #:define-constant - #:defunion - #:format-symbol - #:read-string)) - (in-package :contextual-utility) (defmacro with-syms ((&rest names) &body body) diff --git a/test/derivation-test.lisp b/test/derivation-test.lisp index 0e8c608..9e89cf3 100644 --- a/test/derivation-test.lisp +++ b/test/derivation-test.lisp @@ -210,9 +210,267 @@ (y (bf-lookup (by-key :y)))) (+ x y))))) - (is (= 7 (bf-run e (let-mon/bf ((x (bf-lookup (by-key :x))) (y (bf-lookup (by-key :y)))) (bf-mreturn (+ x y))))))))) + + +(defun bs-run (s mx) + (funcall mx s)) + +(defun bs-mreturn (x) + (lambda (s) (list x s))) + +(defun bs-flatmap (f mx) + (lambda (s) + (destructuring-bind (x s) (bs-run s mx) + (bs-run s (funcall f x))))) + +(defun bs-state (f) f) + +(defun bs-mput (s) + (lambda (ignored) + (declare (ignore ignored)) + (list nil s))) + +(derive-state-monad-interface bs + :mreturn bs-mreturn + :flatmap bs-flatmap + :state bs-state + :mput bs-mput) + + +(test derived-state-monad-interface- + (is-true (functionp #'bs-fmap)) + (is-true (functionp #'bs-pure)) + (is-true (functionp #'bs-fapply)) + (is-true (functionp #'bs-product)) + (is-true (functionp #'bs-mreturn)) + (is-true (functionp #'bs-flatmap)) + (is-true (functionp #'bs-flatten)) + (is-true (functionp #'bs-mget)) + (is-true (functionp #'bs-select)) + (is-true (functionp #'bs-mput)) + (is-true (functionp #'bs-modify)) + (is-true (functionp #'bs-state)) + + (is (equal '(x s) (bs-run 's (bs-mreturn 'x)))) + (is (equal '(x s) (bs-run 's (bs-pure 'x)))) + (is (equal '("X" s) (bs-run 's (bs-fmap #'symbol-name (bs-pure 'x))))) + (is (equal '(s s) (bs-run 's (bs-mget)))) + (is (equal '("S" s) (bs-run 's (bs-select #'symbol-name)))) + (is (equal '(nil s*) (bs-run 's (bs-mput 's*)))) + (is (equal '(nil "S") (bs-run 's (bs-modify #'symbol-name)))) + (is (equal '(x s) (bs-run 's (bs-state (lambda (s) (list 'x 's)))))) + + (let ((s0 '((x . 3) (y . 4)))) + (flet ((by-key (k) (lambda (s) + (assert (listp s)) + (assert (not (null s))) + (cdr (assoc k s))))) + (is (equal (list 7 s0) + (bs-run s0 + (let-app/bs ((x (bs-select (by-key 'x))) + (y (bs-select (by-key 'y)))) + (+ x y))))) + + (is (equal (list 7 s0) + (bs-run s0 + (bs-flatten + (let-fun/bs ((x (bs-select (by-key 'x))) + (y (bs-select (by-key 'y)))) + (+ x y)))))) + + (is (equal (list 10 s0) + (bs-run s0 + (bs-flatten + (let*-fun/bs ((x (bs-select (by-key 'x))) + (y (bs-fmap (lambda (y) (+ x y)) (bs-select (by-key 'y))))) + (+ x y)))))) + + (is (equal (list 7 s0) + (bs-run s0 + (let-mon/bs ((x (bs-select (by-key 'x))) + (y (bs-select (by-key 'y)))) + (bs-mreturn (+ x y)))))) + + (is (equal (list 10 s0) + (bs-run s0 + (let*-mon/bs ((x (bs-select (by-key 'x))) + (y (bs-fmap (lambda (y) (+ x y)) (bs-select (by-key 'y))))) + (bs-mreturn (+ x y))))))))) + + + +(defun bs2-mreturn (x) + (bs-mreturn x)) + +(defun bs2-flatmap (f mx) + (bs-flatmap f mx)) + +(defun bs2-mget () + (bs-mget)) + +(defun bs2-mput (s) + (bs-mput s)) + + +(derive-state-monad-interface bs2 + :mreturn bs2-mreturn + :flatmap bs2-flatmap + :mget bs2-mget + :mput bs2-mput) + + +(defun bs2-run (s mx) + (bs-run s mx)) + +(test derived-state-monad-interface- + (is-true (functionp #'bs2-fmap)) + (is-true (functionp #'bs2-pure)) + (is-true (functionp #'bs2-fapply)) + (is-true (functionp #'bs2-product)) + (is-true (functionp #'bs2-mreturn)) + (is-true (functionp #'bs2-flatmap)) + (is-true (functionp #'bs2-flatten)) + (is-true (functionp #'bs2-mget)) + (is-true (functionp #'bs2-select)) + (is-true (functionp #'bs2-mput)) + (is-true (functionp #'bs2-modify)) + (is-true (functionp #'bs2-state)) + + (is (equal '(x s) (bs2-run 's (bs2-mreturn 'x)))) + (is (equal '(x s) (bs2-run 's (bs2-pure 'x)))) + (is (equal '("X" s) (bs2-run 's (bs2-fmap #'symbol-name (bs2-pure 'x))))) + (is (equal '(s s) (bs2-run 's (bs2-mget)))) + (is (equal '("S" s) (bs2-run 's (bs2-select #'symbol-name)))) + (is (equal '(nil s*) (bs2-run 's (bs2-mput 's*)))) + (is (equal '(nil "S") (bs2-run 's (bs2-modify #'symbol-name)))) + (is (equal '(x s) (bs2-run 's (bs2-state (lambda (s) (list 'x 's)))))) + + (let ((s0 '((x . 3) (y . 4)))) + (flet ((by-key (k) (lambda (s) + (assert (listp s)) + (assert (not (null s))) + (cdr (assoc k s))))) + (is (equal (list 7 s0) + (bs2-run s0 + (let-app/bs ((x (bs2-select (by-key 'x))) + (y (bs2-select (by-key 'y)))) + (+ x y))))) + + (is (equal (list 7 s0) + (bs2-run s0 + (bs2-flatten + (let-fun/bs ((x (bs2-select (by-key 'x))) + (y (bs2-select (by-key 'y)))) + (+ x y)))))) + + (is (equal (list 10 s0) + (bs2-run s0 + (bs2-flatten + (let*-fun/bs ((x (bs2-select (by-key 'x))) + (y (bs2-fmap (lambda (y) (+ x y)) (bs2-select (by-key 'y))))) + (+ x y)))))) + + (is (equal (list 7 s0) + (bs2-run s0 + (let-mon/bs ((x (bs2-select (by-key 'x))) + (y (bs2-select (by-key 'y)))) + (bs2-mreturn (+ x y)))))) + + (is (equal (list 10 s0) + (bs2-run s0 + (let*-mon/bs ((x (bs2-select (by-key 'x))) + (y (bs2-fmap (lambda (y) (+ x y)) (bs2-select (by-key 'y))))) + (bs2-mreturn (+ x y))))))))) + + + +(defun bs3-run (s mx) + (funcall mx s)) + +(defun bs3-mreturn (x) + (bs-mreturn x)) + +(defun bs3-flatmap (f mx) + (bs-flatmap f mx)) + +(defun bs3-select (f) + (lambda (s) + (list (funcall f s) s))) + +(defun bs3-modify (f) + (lambda (s) + (list nil (funcall f s)))) + + +(derive-state-monad-interface bs3 + :mreturn bs3-mreturn + :flatmap bs3-flatmap + :select bs3-select + :modify bs3-modify) + + + +(test derived-state-monad-interface- + (is-true (functionp #'bs3-fmap)) + (is-true (functionp #'bs3-pure)) + (is-true (functionp #'bs3-fapply)) + (is-true (functionp #'bs3-product)) + (is-true (functionp #'bs3-mreturn)) + (is-true (functionp #'bs3-flatmap)) + (is-true (functionp #'bs3-flatten)) + (is-true (functionp #'bs3-mget)) + (is-true (functionp #'bs3-select)) + (is-true (functionp #'bs3-mput)) + (is-true (functionp #'bs3-modify)) + (is-true (functionp #'bs3-state)) + + (is (equal '(x s) (bs3-run 's (bs3-mreturn 'x)))) + (is (equal '(x s) (bs3-run 's (bs3-pure 'x)))) + (is (equal '("X" s) (bs3-run 's (bs3-fmap #'symbol-name (bs3-pure 'x))))) + (is (equal '(s s) (bs3-run 's (bs3-mget)))) + (is (equal '("S" s) (bs3-run 's (bs3-select #'symbol-name)))) + (is (equal '(nil s*) (bs3-run 's (bs3-mput 's*)))) + (is (equal '(nil "S") (bs3-run 's (bs3-modify #'symbol-name)))) + (is (equal '(x s) (bs3-run 's (bs3-state (lambda (s) (list 'x 's)))))) + + (let ((s0 '((x . 3) (y . 4)))) + (flet ((by-key (k) (lambda (s) + (assert (listp s)) + (assert (not (null s))) + (cdr (assoc k s))))) + (is (equal (list 7 s0) + (bs3-run s0 + (let-app/bs ((x (bs3-select (by-key 'x))) + (y (bs3-select (by-key 'y)))) + (+ x y))))) + + (is (equal (list 7 s0) + (bs3-run s0 + (bs3-flatten + (let-fun/bs ((x (bs3-select (by-key 'x))) + (y (bs3-select (by-key 'y)))) + (+ x y)))))) + + (is (equal (list 10 s0) + (bs3-run s0 + (bs3-flatten + (let*-fun/bs ((x (bs3-select (by-key 'x))) + (y (bs3-fmap (lambda (y) (+ x y)) (bs3-select (by-key 'y))))) + (+ x y)))))) + + (is (equal (list 7 s0) + (bs3-run s0 + (let-mon/bs ((x (bs3-select (by-key 'x))) + (y (bs3-select (by-key 'y)))) + (bs3-mreturn (+ x y)))))) + + (is (equal (list 10 s0) + (bs3-run s0 + (let*-mon/bs ((x (bs3-select (by-key 'x))) + (y (bs3-fmap (lambda (y) (+ x y)) (bs3-select (by-key 'y))))) + (bs3-mreturn (+ x y)))))))))