evaluate-thunk-to-boolean

5 files changed, 28 insertions, 7 deletions

diff --git a/cond-thunk.egg b/cond-thunk.egg
index 469f237..2cce087 100644
--- a/cond-thunk.egg
+++ b/cond-thunk.egg
@@ -1,5 +1,5 @@
 ((author "Peter McGoron")
- (version "0.2.3")
+ (version "0.2.4")
  (synopsis "macros for abstracting conditional branches")
  (category "lang-exts")
  (license "Apache-2.0")
diff --git a/doc/mcgoron.cond-thunk.scm b/doc/mcgoron.cond-thunk.scm
index 8f740da..00be829 100644
--- a/doc/mcgoron.cond-thunk.scm
+++ b/doc/mcgoron.cond-thunk.scm
@@ -48,11 +48,16 @@ If `conditional` is true, return a thunk that when called executes
 Create a closure with arguments `formal` that evaluates `conditional`.
 If `conditional` returns a truthy value, a thunk closure with
 `body ...` as its body is returned. Otherwise the closure returns `#f`."))
- (name . "define-ct")
- (signature syntax-rules ((_ (name . formal) conditional body ...)))
- (desc "
+ ((name . "define-ct")
+  (signature syntax-rules ((_ (name . formal) conditional body ...)))
+  (desc "
 * It is an error if `formal` is not a lambda formal.
 * It is an error if `conditional` is not an expression.
 
 Define a procedure `name` as a conditional generating a thunk. See
-`lambda-ct` for more details."))
\ No newline at end of file
+`lambda-ct` for more details."))
+ ((name . "evaluate-thunk-to-boolean")
+  (signature syntax-rules ((_ (thunk args ...))))
+  (desc "
+Evaluates `(thunk args ...)` and turns the result into a boolean. If
+the evaluation returns `#f`, return `#f`. Otherwise return `#t`.")))
\ No newline at end of file
diff --git a/mcgoron.cond-thunk.scm b/mcgoron.cond-thunk.scm
index ebd8bfd..53a4300 100644
--- a/mcgoron.cond-thunk.scm
+++ b/mcgoron.cond-thunk.scm
@@ -56,3 +56,10 @@
      (define name
        (lambda-ct formal conditional body ...)))))
 
+(define-syntax evaluate-thunk-to-boolean
+  (syntax-rules ()
+    ((evaluate-thunk-to-boolean (thunk args ...))
+     (cond
+       ((thunk args ...) #t)
+       (else #f)))))
+
diff --git a/mcgoron.cond-thunk.sld b/mcgoron.cond-thunk.sld
index 5555ee2..21616a2 100644
--- a/mcgoron.cond-thunk.sld
+++ b/mcgoron.cond-thunk.sld
@@ -18,5 +18,6 @@
   (import (scheme base) (scheme case-lambda))
   (export cond-thunk any-thunk
           when-ct
-          lambda-ct define-ct)
+          lambda-ct define-ct
+          evaluate-thunk-to-boolean)
   (include "mcgoron.cond-thunk.scm"))
diff --git a/tests/basic.scm b/tests/basic.scm
index fdcc0d7..b029bfc 100644
--- a/tests/basic.scm
+++ b/tests/basic.scm
@@ -65,6 +65,14 @@
    (cond-thunk
      (on-pair #f)
      (on-boolean #f)
-     (else #f))))
+     (else #f)))
+  (test
+   "evaluate-thunk-to-boolean 1"
+   #f
+   (evaluate-thunk-to-boolean (on-pair #f)))
+  (test
+   "evaluate-thunk-to-boolean 2"
+   #t
+   (evaluate-thunk-to-boolean (on-boolean #t))))
 
 (test-end "(mcgoron cond-thunk base)")