From 65c12abfd44652810ba857c40274b0e1947fa023 Mon Sep 17 00:00:00 2001
From: "Samuel B. Johnson" <sabjohnso@yahoo.com>
Date: Sat, 2 Nov 2024 18:52:58 -0500
Subject: [PATCH] :sparkles: [bare-function] Contexutal implements bare
 functions

Problem:
- Contextual does not provide a context for the environment monad
implemented with bare functions.

Solution:
- Add a context for bare functions
---
 contextual.asd               |  10 ++-
 src/bare-function.lisp       | 131 +++++++++++++++++++++++++++++++++++
 src/internal.lisp            |   5 +-
 src/syntax-helpers.lisp      | 105 +++++++++++++++++++++++++++-
 test/bare-function-test.lisp |  92 ++++++++++++++++++++++++
 5 files changed, 337 insertions(+), 6 deletions(-)
 create mode 100644 src/bare-function.lisp
 create mode 100644 test/bare-function-test.lisp

diff --git a/contextual.asd b/contextual.asd
index d7acd89..d6c6711 100644
--- a/contextual.asd
+++ b/contextual.asd
@@ -23,7 +23,8 @@
      (:file "list")
      (:file "optional")
      (:file "thunk")
-     (:file "bare"))))
+     (:file "bare")
+     (:file "bare-function"))))
   :in-order-to ((test-op
                  (load-op :contextual)
                  (test-op :contextual/test))))
@@ -42,7 +43,8 @@
      (:file "list-test")
      (:file "optional-test")
      (:file "thunk-test")
-     (:file "bare-test"))))
+     (:file "bare-test")
+     (:file "bare-function-test"))))
   :perform (test-op (o s)
              (symbol-call :binding-syntax-helpers-test :run-all-tests!)
              (symbol-call :contextual-internal-test :run-all-tests!)
@@ -51,4 +53,6 @@
              (symbol-call :contextual-list-test :run-all-tests!)
              (symbol-call :contextual-optional-test :run-all-tests!)
              (symbol-call :contextual-thunk-test :run-all-tests!)
-             (symbol-call :contextual-thunk-test :run-all-tests!)))
+             (symbol-call :contextual-thunk-test :run-all-tests!)
+             (symbol-call :contextual-bare-test :run-all-tests!)
+             (symbol-call :contextual-bare-function-test :run-all-tests!)))
diff --git a/src/bare-function.lisp b/src/bare-function.lisp
new file mode 100644
index 0000000..2c37022
--- /dev/null
+++ b/src/bare-function.lisp
@@ -0,0 +1,131 @@
+(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-asks
+           #: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)
+  (defun bf-run (e mx)
+    "Run a bare function context with the environment `E'."
+    (declare (type function mx))
+    (funcall mx e))
+
+  (defun bf-fmap (f mx)
+    (lambda (e)
+      (funcall f (bf-run e mx))))
+
+  (defun bf-pure (x)
+    (lambda (e)
+      (declare (ignore e))
+      x))
+
+  (defun bf-mreturn (x)
+    (lambda (e)
+      (declare (ignore e))
+      x))
+
+  (defun bf-fapply (mf mx)
+    (lambda (e) (funcall (bf-run e mf) (bf-run e mx))))
+
+  (defun bf-product (mx my)
+    (lambda (e)
+      (list (bf-run e mx) (bf-run e my))))
+
+  (defun bf-flatmap (f mx)
+    (lambda (e)
+      (bf-run e (funcall f (bf-run e mx)))))
+
+  (defun bf-flatten (mmx)
+    (lambda (e)
+      (bf-run e (bf-run e mmx))))
+
+  (defun bf-ask ()
+    #'identity)
+
+  (defun bf-asks (f)
+    "Return the environment"
+    (declare (type function f))
+    (lambda (e)
+      (funcall f e)))
+
+  (defun bf-local (f mx)
+    "Run a bare function with a locally modified environemnt"
+    (lambda (e)
+      (bf-run (funcall f e) mx)))
+
+  (defun make-bare-function-context ()
+    "Return a monadic context for bare functions."
+    (make-instance 'monad-operators
+      :fmap #'bf-fmap
+      :fapply #'bf-fapply
+      :product #'bf-product
+      :mreturn #'bf-mreturn
+      :flatmap #'bf-flatmap
+      :flatten #'bf-flatten)))
+
+(defmacro let*-fun/bf ((&rest bindings) &body body)
+  (make-sequential-functor-binding
+   'let*-fun/bf
+   :fmap 'bf-fmap
+   :bindings bindings
+   :body body))
+
+(defmacro let-fun/bf ((&rest bindings) &body body)
+  (make-parallel-functor-binding-ez
+   'let-fun/bf
+   :let-sequential 'let*-fun/bf
+   :bindings bindings
+   :body body))
+
+(defmacro let-app/bf ((&rest bindings) &body body)
+  (make-parallel-applicative-binding-ez
+   'let-app/bf
+   :fmap 'bf-fmap
+   :fapply 'bf-fapply
+   :bindings bindings
+   :body body))
+
+(defmacro progn-mon/bf (&body body)
+  (make-monad-progn-ez
+   'progn-mon/bf
+   :flatmap 'bf-flatmap
+   :body body))
+
+(defmacro let*-mon/bf ((&rest bindings) &body body)
+  (make-sequential-monad-binding-ez
+   'let*-mon/bf
+   :flatmap 'bf-flatmap
+   :monad-progn 'progn-mon/bf
+   :bindings bindings
+   :body body))
+
+(defmacro let-mon/bf ((&rest bindings) &body body)
+  (make-parallel-monad-binding
+   'let-mon/bf
+   :flatmap 'bf-flatmap
+   :sequential-let-name 'let*-mon/bf
+   :monad-progn 'progn-mon/bf
+   :bindings bindings
+   :body body))
+
+
+(define-constant +bare-function+
+  (make-bare-function-context))
diff --git a/src/internal.lisp b/src/internal.lisp
index e012159..103be67 100644
--- a/src/internal.lisp
+++ b/src/internal.lisp
@@ -21,8 +21,9 @@
 (defstruct contextual func)
 
 (defun ctx-run (context cx)
-  (declare (type contextual cx))
-  (funcall (contextual-func cx) context))
+  (if (contextual-p cx)
+      (funcall (contextual-func cx) context)
+      cx))
 
 (defun ctx-return (x)
   (make-contextual
diff --git a/src/syntax-helpers.lisp b/src/syntax-helpers.lisp
index 6a60e10..05650f9 100644
--- a/src/syntax-helpers.lisp
+++ b/src/syntax-helpers.lisp
@@ -8,7 +8,14 @@
    #:make-sequential-monad-binding
    #:make-parallel-monad-binding
    #:make-parallel-applicative-binding
-   #:make-parallel-functor-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)
 
@@ -136,3 +143,99 @@
                          :more-body more-body)))
           `(funcall (lambda (,@new-vars) ,body)
                     ,@exprs)))))
+
+(defun make-sequential-functor-binding-ez (let-name &key fmap bindings body)
+  "Return syntax for sequential functor bindings"
+  (declare (type symbol let-name fmap)
+           (type list bindings body))
+
+  (assert (not (null bindings)))
+  (assert (not (mull body)))
+
+  (destructuring-bind (binding . more-bindings) bindings
+    (destructuring-bind (body . more-body) body
+      (make-sequential-functor-binding
+       let-name
+       :fmap fmap
+       :binding binding
+       :more-bindings more-bindings
+       :body body
+       :more-body more-body))))
+
+(defun make-parallel-functor-binding-ez (let-name &key let-sequential bindings body)
+  (declare (type symbol let-name let-sequential)
+           (type list bindings body))
+
+  (assert (not (null bindings)))
+  (assert (not (null body)))
+
+  (destructuring-bind (binding . more-bindings) bindings
+    (destructuring-bind (body . more-body) body
+      (make-parallel-functor-binding
+       let-name
+       :let-sequential let-sequential
+       :binding binding
+       :more-bindings more-bindings
+       :body body
+       :more-body more-body))))
+
+(defun make-parallel-applicative-binding-ez (let-name &key fmap fapply bindings body)
+  (declare (type symbol let-name fmap fapply)
+           (type list bindings body))
+  (assert (not (null bindings)))
+  (assert (not (null body)))
+
+  (destructuring-bind (binding . more-bindings) bindings
+    (destructuring-bind (body . more-body) body
+      (make-parallel-applicative-binding
+       let-name
+       :fmap fmap
+       :fapply fapply
+       :binding binding
+       :more-bindings more-bindings
+       :body body
+       :more-body more-body))))
+
+
+(defun make-monad-progn-ez (progn-name &key flatmap body)
+  (declare (type symbol progn-name flatmap)
+           (type list body))
+  (assert (not (null body)))
+  (make-monad-progn progn-name :flatmap flatmap :body (car body) :more-body (cdr body)))
+
+
+(defun make-sequential-monad-binding-ez (let-name &key flatmap monad-progn bindings body)
+  (declare (type symbol let-name flatmap monad-progn)
+           (type list bindings body))
+  (assert (not (null body)))
+  (if (null bindings)
+      (macroexpand `(,monad-progn ,@body))
+      (destructuring-bind (binding . more-bindings) bindings
+        (destructuring-bind (body . more-body) body
+          (make-sequential-monad-binding
+             let-name
+             :flatmap flatmap
+             :monad-progn monad-progn
+             :binding binding
+             :more-bindings more-bindings
+             :body body
+             :more-body more-body)))))
+
+
+(defun make-parallel-monad-binding-ez (let-name &key flatmap sequential-let-name monad-progn bindings body)
+  (declare (type symbol let-name flatmap sequential-let-name monad-progn)
+           (type list bindings body))
+  (assert (not (null body)))
+  (if (null bindings)
+      (macroexpand `(,monad-progn ,@body))
+      (destructuring-bind (binding . more-bindings) bindings
+        (destructuring-bind (body . more-body) body
+          (make-parallel-monad-binding
+           'let-name
+           :flatmap flatmap
+           :sequential-let-name sequential-let-name
+           :monad-progn monad-progn
+           :binding binding
+           :more-bindings more-bindings
+           :body body
+           :more-body more-body)))))
diff --git a/test/bare-function-test.lisp b/test/bare-function-test.lisp
new file mode 100644
index 0000000..51f2c88
--- /dev/null
+++ b/test/bare-function-test.lisp
@@ -0,0 +1,92 @@
+(in-package :cl-user)
+
+(defpackage :contextual-bare-function-test
+  (:use :cl :5am :contextual :contextual-bare-function)
+  (:export #:run-all-tests!))
+
+(in-package :contextual-bare-function-test)
+
+(defun run-all-tests! ()
+  (run! 'bare-function))
+
+(def-suite bare-function)
+
+(in-suite bare-function)
+
+(test specific-context-functions
+  (is (eq 'x (bf-run 'e (bf-pure 'x))))
+  (is (eq 'x (bf-run 'e (bf-mreturn 'x))))
+  (is (equal "X" (bf-run 'e (bf-fmap #'symbol-name (bf-pure 'x)))))
+  (is (equal "E" (bf-run 'e (bf-fmap #'symbol-name (bf-ask)))))
+  (is (equal "E" (bf-run 'e (bf-fapply (bf-pure #'symbol-name) (bf-ask)))))
+  (is (equal "EX" (bf-run 'e
+                    (bf-flatmap
+                     (lambda (x)
+                       (let-app/bf ((e (bf-ask)))
+                         (concatenate 'string (symbol-name e) (symbol-name x))))
+                     (bf-pure 'x)))))
+  (is (eq 'e (bf-run 'e
+               (bf-flatten (bf-mreturn (bf-ask)))))))
+
+(test generic-context-functions
+  (let ((context (make-bare-function-context)))
+    (is (eq 'x (bf-run 'e (ctx-run context (pure 'x)))))
+    (is (eq 'e (bf-run 'e (ctx-run context (bf-ask)))))
+    (is (equal "X" (bf-run 'e (ctx-run context (fmap #'symbol-name (pure 'x))))))
+    (is (equal '(x e) (bf-run 'e
+                        (ctx-run context
+                          (product (pure 'x) (bf-ask))))))
+    (is (equal "X" (bf-run 'e
+                     (ctx-run context
+                       (flatmap (lambda (x)
+                                  (lambda (e)
+                                    (declare (ignore e))
+                                    (symbol-name x)))
+                                (pure 'x))))))
+    (is (eq 'x (bf-run 'e
+                 (ctx-run context
+                   (flatten (pure (pure 'x)))))))
+    (is (equal "E"
+               (bf-run 'e
+                 (ctx-run context
+                   (bf-asks #'symbol-name)))))
+    (is (equal "E"
+               (bf-run 'e
+                 (ctx-run context
+                   (bf-local
+                    #'symbol-name
+                    (bf-ask))))))))
+
+
+(test binding-syntax
+  (flet ((lookup (name) (lambda (e) (cdr (assoc name e)))))
+    (is (= 3
+           (bf-run '((x . 1) (y . 2))
+             (ctx-run +bare-function+
+               (flatten
+                (let-fun ((x (bf-asks (lookup 'x)))
+                          (y (bf-asks (lookup 'y))))
+                  (+ x y)))))))
+    (is (= 3
+          (bf-run '((x . 1) (y . 2))
+             (ctx-run +bare-function+
+               (let-app ((x (bf-asks (lookup 'x)))
+                         (y (bf-asks (lookup 'y))))
+                 (+ x y))))))
+
+    (is (= 3
+           (bf-run '((x . 1) (y . 2))
+             (ctx-run +bare-function+
+               (let-mon ((x (bf-asks (lookup 'x)))
+                         (y (bf-asks (lookup 'y))))
+                 (mreturn (+ x y)))))))
+
+    (is (= 5
+           (bf-run '((x . 1) (y . 2))
+             (ctx-run +bare-function+
+               (let-mon ((x (bf-asks (lookup 'x))))
+                 (bf-local (lambda (e) (cons `(x . ,(+ x 2)) e))
+                           (ctx-run +bare-function+
+                             (let-app ((x (bf-asks (lookup 'x)))
+                                       (y (bf-asks (lookup 'y))))
+                               (+ x y)))))))))))