✨ [thunk] Contextual has a thunk context

Problem: - Contextual does not have a context for thunks Solution: - Add a trivial context for thunks
sabjohnso · Nov 2, 2024 · 1df2536 · 1df2536
1 parent dddbd3b
commit 1df2536
Show file tree

Hide file tree

Showing 9 changed files with 133 additions and 21 deletions.
diff --git a/contextual.asd b/contextual.asd
@@ -21,14 +21,15 @@
      (:file "derivation")
      (:file "contextual")
      (:file "list")
-     (:file "optional"))))
+     (:file "optional")
+     (:file "thunk"))))
   :in-order-to ((test-op
                  (load-op :contextual)
                  (test-op :contextual/test))))
 
 (defsystem :contextual/test
   :description "Tests for the `CONTEXTUAL' system"
-  :depends-on (:fiveam)
+  :depends-on (:fiveam :contextual)
   :components
   ((:module "test"
     :serial t
@@ -38,11 +39,13 @@
      (:file "derivation-test")
      (:file "contextual-test")
      (:file "list-test")
-     (:file "optional-test"))))
+     (:file "optional-test")
+     (:file "thunk-test"))))
   :perform (test-op (o s)
              (symbol-call :binding-syntax-helpers-test :run-all-tests!)
              (symbol-call :contextual-internal-test :run-all-tests!)
              (symbol-call :contextual-derivation-test :run-all-tests!)
              (symbol-call :contextual-test :run-all-tests!)
              (symbol-call :contextual-list-test :run-all-tests!)
-             (symbol-call :contextual-optional-test :run-all-tests!)))
+             (symbol-call :contextual-optional-test :run-all-tests!)
+             (symbol-call :contextual-thunk-test :run-all-tests!)))
diff --git a/run-tests b/run-tests
@@ -19,8 +19,8 @@ exit $?
 (ql:quickload "trivia")
 (ql:quickload "fiveam")
 
-(asdf:load-system :contextual)
-(asdf:load-system :contextual/test)
+(asdf:oos 'asdf:load-op :contextual :force t)
+(asdf:oos 'asdf:load-op :contextual/test :force t)
 
 (defun run ()
   (if (5am:run-all-tests) 0 1))

diff --git a/src/derivation.lisp b/src/derivation.lisp
@@ -115,7 +115,7 @@ product operation, as derived from `FAPPLY' and `PURE'."
 (defmacro defun/product-to-fapply (name &key product fmap)
   "Define a named function that performs applicative mapping,
 as derived from the named input functions `PRODUCT' and `FMAP'"
-  (with-syms (mf mx fx f x)
+  (with-syms (mf mx fx)
     `(defun ,name (,mf ,mx)
        (,fmap (lambda (,fx)
                 (funcall (car ,fx) (cadr ,fx)))

diff --git a/src/internal.lisp b/src/internal.lisp
@@ -27,7 +27,7 @@
 (defun ctx-return (x)
   (make-contextual
    :func (lambda (ignored-context)
-           (declare (ignore context))
+           (declare (ignore ignored-context))
            x)))
 
 (defun ctx-injest (x)

diff --git a/src/optional.lisp b/src/optional.lisp
@@ -13,11 +13,18 @@
   (just value)
   (none))
 
-(declaim (ftype (function (function optional) optional) optional-flatmap))
+
+(deftype optional-constructor ()
+  '(function (t) optional))
+
+
 (defun optional-flatmap (f mx)
-  (match mx
-    ((just value) (funcall f value))
-    ((none)   mx)))
+  (declare (type optional-constructor f)
+           (type optional mx))
+  (the optional
+    (ematch mx
+      ((just value) (funcall f value))
+      ((none) mx))))
 
 (defun make-optional-context ()
   (make-instance 'monad-operators

diff --git a/src/syntax-helpers.lisp b/src/syntax-helpers.lisp
@@ -50,14 +50,15 @@
                                  ,body)))))
 
 (defun make-parallel-functor-binding (let-name &key let-sequential binding more-bindings body more-body)
+  (declare (ignore let-name))
   (let* ((bindings (cons binding more-bindings))
          (vars (mapcar #'car bindings))
          (exprs (mapcar #'cadr bindings))
          (new-vars (mapcar #'gensym-like vars))
          (rebindings (mapcar #'list vars new-vars))
          (body (macroexpand `(,let-sequential (,@rebindings)
-                                ,body
-                                ,@more-body))))
+                                              ,body
+                                              ,@more-body))))
     `(funcall (lambda (,@new-vars) ,body) ,@exprs)))
 
 (defun make-curried-function (var more-vars body more-body)

diff --git a/src/thunk.lisp b/src/thunk.lisp
@@ -0,0 +1,21 @@
+(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)
+  `(lambda () ,@exprs))
+
+(defun thunk-wrap (x)
+  (thunk x))
+
+(defun thunk-unwrap (thunk)
+  (funcall thunk))
+
+(defun make-thunk-context ()
+  (make-instance 'trivial-operators
+    :wrap #'thunk-wrap
+    :unwrap #'thunk-unwrap))
diff --git a/test/contextual-test.lisp b/test/contextual-test.lisp
@@ -6,8 +6,6 @@
 
 (in-package :contextual-test)
 
-
-
 (defun run-all-tests! ()
   (run! 'contextual))
 
@@ -294,7 +292,7 @@
 
  (defun ziplist-reverse (xs)
    (cond ((listp xs) (reverse xs))
-         ((repeatp xs) xs)))
+         ((repeat-p xs) xs)))
 
  (defun ziplist-fmap (f xs)
    (if (repeat-p xs)
@@ -407,10 +405,13 @@
          (ctx-run context (lift7 #'+ (pure 1) (pure 2) (pure 3) (pure 4) (pure 5) (pure 6) (pure 7)))))))
 
 (defmacro is-error (expr)
-  `(is-true
-    (handler-case
-        (progn ,expr nil)
-      (error (e) t))))
+  (let ((e (gensym "E")))
+    `(is-true
+      (handler-case
+          (progn ,expr nil)
+        (error (,e)
+          (declare (ignore ,e))
+          t)))))
 
 (test missing-operators
   (is-error (make-instance 'trivial-operators :wrap #'(lambda (x) (make-id :value x))))

diff --git a/test/thunk-test.lisp b/test/thunk-test.lisp
@@ -0,0 +1,79 @@
+(in-package :cl-user)
+
+(defpackage :contextual-thunk-test
+  (:use :cl :5am :contextual :contextual-thunk)
+  (:export #:run-all-tests!))
+
+(in-package :contextual-thunk-test)
+
+
+(def-suite thunk)
+
+(defun run-all-tests! ()
+  (run! 'thunk))
+
+(in-suite thunk)
+
+(test thunk-construction
+  (let ((mx (thunk (+ 1 2))))
+    (is-true (functionp mx))
+    (is (= 3 (funcall mx)))))
+
+(test fmap
+  (let ((context (make-thunk-context)))
+    (is (equalp "x"
+                (ctx-run context
+                  (unwrap (fmap #'symbol-name (thunk 'x))))))))
+(test pure/mreturn/wrap
+  (let ((context (make-thunk-context)))
+    (is (eq 'x (funcall (ctx-run context (pure 'x)))))
+    (is (eq 'x (funcall (ctx-run context (mreturn 'x)))))
+    (is (eq 'x (funcall (ctx-run context (wrap 'x)))))))
+
+(test fapply
+  (let ((context (make-thunk-context)))
+    (is (equal "X" (funcall (ctx-run context (fapply (pure #'symbol-name) (thunk 'x))))))))
+
+(test flatmap
+  (let ((context (make-thunk-context)))
+    (is (equal "X" (funcall (ctx-run context (flatmap (lambda (x) (thunk (symbol-name x))) (pure 'x))))))))
+
+(test flatten/unwrap
+  (let ((context (make-thunk-context)))
+    (is (eq 'x (funcall (ctx-run context (flatten (thunk (thunk 'x)))))))
+    (is (eq 'x (funcall (ctx-run context (unwrap (thunk (thunk 'x)))))))))
+
+(test binding-syntax
+  (let ((context (make-thunk-context)))
+    (is (= 3
+           (funcall
+            (ctx-run context
+              (let-mon ((x (thunk 1))
+                        (y (thunk 2)))
+                (mreturn (+ x y)))))))
+    (is (= 4
+           (funcall
+            (ctx-run context
+              (let*-mon ((x (thunk 1))
+                         (y (thunk (+ x 2))))
+                (mreturn (+ x y)))))))
+    (is (= 3
+           (funcall
+            (ctx-run context
+              (let-app ((x (thunk 1))
+                        (y (thunk 2)))
+                (+ x y))))))
+    (is (= 3
+           (funcall
+            (ctx-run context
+              (flatten
+               (let-fun ((x (thunk 1))
+                         (y (thunk 2)))
+                 (+ x y)))))))
+    (is (= 4
+           (funcall
+            (ctx-run context
+              (flatten
+               (let*-fun ((x (thunk 1))
+                          (y (thunk (+ x 2))))
+                 (+ x y)))))))))