✨ [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

@@ -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!)))

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))))))

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))))))))