From 694ff870e05ec690a619b7668b3a650ae4e09295 Mon Sep 17 00:00:00 2001
From: "Samuel B. Johnson" <sabjohnso@yahoo.com>
Date: Thu, 7 Nov 2024 07:32:03 -0600
Subject: [PATCH] :sparkles: [unitary-list] Contextual has unitary lists

Problem:
- Unitary lists (lists with zero or one element) are useful for many
things, as they are isomorphic to optional values but can also
be spliced optionally into a list, a common pattern in
macros. However, the contexutal library does not have a context
for unitary lists.

Solution:
- Add a context for unitary lists.
---
 contextual.asd              |  9 ++++--
 src/unitary-list.lisp       | 24 +++++++++++++++
 test/unitary-list-test.lisp | 59 +++++++++++++++++++++++++++++++++++++
 3 files changed, 89 insertions(+), 3 deletions(-)
 create mode 100644 src/unitary-list.lisp
 create mode 100644 test/unitary-list-test.lisp

diff --git a/contextual.asd b/contextual.asd
index ca22d3e..9c0dd6f 100644
--- a/contextual.asd
+++ b/contextual.asd
@@ -25,7 +25,8 @@
      (:file "thunk")
      (:file "bare")
      (:file "bare-function")
-     (:file "bare-state"))))
+     (:file "bare-state")
+     (:file "unitary-list"))))
   :in-order-to ((test-op
                  (load-op :contextual)
                  (test-op :contextual/test))))
@@ -46,7 +47,8 @@
      (:file "thunk-test")
      (:file "bare-test")
      (:file "bare-function-test")
-     (:file "bare-state-test"))))
+     (:file "bare-state-test")
+     (:file "unitary-list-test"))))
   :perform (test-op (o s)
              (symbol-call :binding-syntax-helpers-test :run-all-tests!)
              (symbol-call :contextual-internal-test :run-all-tests!)
@@ -58,4 +60,5 @@
              (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!)
-             (symbol-call :contextual-bare-state-test :run-all-tests!)))
+             (symbol-call :contextual-bare-state-test :run-all-tests!)
+             (symbol-call :contextual-unitary-list-test :run-all-tests!)))
diff --git a/src/unitary-list.lisp b/src/unitary-list.lisp
new file mode 100644
index 0000000..cb2169c
--- /dev/null
+++ b/src/unitary-list.lisp
@@ -0,0 +1,24 @@
+(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)
+  "Return `T' if `ARG' is `NIL' or single element list."
+  (or (null arg)
+      (and (listp arg)
+           (= 1 (length arg)))))
+
+(deftype unitary-list ()
+  '(satisfies unitary-list-p))
+
+(defun make-unitary-list-context ()
+  "Return the monad operators for a unitary list.
+
+A unitary list is a list with 1 or zero elements"
+  (make-instance 'monad-operators
+    :mreturn #'list
+    :flatmap (lambda (f mx)
+               (and mx (funcall f (car mx))))))
diff --git a/test/unitary-list-test.lisp b/test/unitary-list-test.lisp
new file mode 100644
index 0000000..69a2b37
--- /dev/null
+++ b/test/unitary-list-test.lisp
@@ -0,0 +1,59 @@
+(in-package :cl-user)
+(defpackage :contextual-unitary-list-test
+  (:use :cl :5am :contextual :contextual-unitary-list)
+  (:export :run-all-tests!))
+
+(in-package :contextual-unitary-list-test)
+
+(def-suite unitary-list)
+
+(in-suite unitary-list)
+
+(defun run-all-tests! ()
+  (run! 'unitary-list))
+
+
+(test type
+  (is-true (unitary-list-p nil))
+  (is-true (unitary-list-p '(x)))
+  (is-false (unitary-list-p '(x y)))
+  (is-false (unitary-list-p "A pink elephant"))
+  (is-true (typep nil 'unitary-list))
+  (is-true (typep '(x) 'unitary-list))
+  (is-false (typep '(x y) 'unitary-list))
+  (is-false (typep "A pink elephant" 'unitary-list)))
+
+(test functions
+  (let ((context (make-unitary-list-context)))
+    (is (equal '(x) (ctx-run context (pure 'x))))
+    (is (equal '("X") (ctx-run context (fmap #'symbol-name (pure 'x)))))
+    (is (equal '("X") (ctx-run context (fapply (pure #'symbol-name) (pure 'x)))))
+    (is (equal '((x y)) (ctx-run context (product (pure 'x) (pure 'y)))))
+    (is (equal '("X") (ctx-run context (flatmap (lambda (x) (mreturn (symbol-name x))) (pure 'x)))))))
+
+(test binding
+  (let ((context (make-unitary-list-context)))
+    (is (equal '((7)) (ctx-run context
+                        (let*-fun ((x (pure 3))
+                                   (y (pure (1+ x))))
+                          (+ x y)))))
+
+    (is (equal '((7)) (ctx-run context
+                        (let-fun ((x (pure 3))
+                                  (y (pure 4)))
+                          (+ x y)))))
+
+    (is (equal '(7) (ctx-run context
+                      (let-app ((x (pure 3))
+                                (y (pure 4)))
+                        (+ x y)))))
+
+    (is (equal '(7) (ctx-run context
+                      (let*-mon ((x (pure 3))
+                                 (y (pure (1+ x))))
+                        (mreturn (+ x y))))))
+
+    (is (equal '(7) (ctx-run context
+                      (let-mon ((x (pure 3))
+                                (y (pure 4)))
+                        (mreturn (+ x y))))))))