add err library

7 files changed, 253 insertions, 5 deletions

diff --git a/err.scm b/err.scm
new file mode 100644
index 0000000..0dad12b
--- /dev/null
+++ b/err.scm
@@ -0,0 +1,94 @@
+; Influenced by Rust, Haskell, Racket rebellion/results, JS promises
+
+(module err (err unerr err? ok? ok=> err=> ok/if ok ok/or ok/and guard-err)
+
+(import
+  (scheme)
+  (chicken base)
+  (chicken format)
+  (chicken condition))
+
+(define-record-type <err>
+  (%make-err data)
+  err?
+  (data %err-data))
+
+(set-record-printer! <err>
+  (lambda (x out)
+    (fprintf out "#<err ~s>" (%err-data x))))
+
+(define (err x)
+  (if (err? x)
+    x
+    (%make-err x)))
+
+(define (ok? e)
+  (not (err? e)))
+
+(define (unerr e)
+  (if (err? e)
+    (%err-data e)
+    (if #f #f)))
+
+(define ok/if
+  (case-lambda
+    ((x when-ok)
+     (if (err? x)
+       x
+       (when-ok x)))
+    ((x when-ok when-err)
+     (if (err? x)
+       (when-err (unerr x))
+       (when-ok x)))))
+
+(define (ok=> x . fs)
+  (if (null? fs)
+    x
+    (if (ok? x)
+      (apply ok=> ((car fs) x) (cdr fs))
+      x)))
+
+(define (err=> x . fs)
+  (if (ok? x)
+    x
+    (let loop ((x (unerr x))
+               (fs fs))
+      (if (null? fs)
+        x
+        (loop ((car fs) x) (cdr fs))))))
+
+(define (ok x)
+  (err=> x (lambda (e)
+             (if (condition? e)
+               (abort e)
+               (error e)))))
+
+(define-syntax ok/or
+  (syntax-rules ()
+    ((_)            (err (if #f #f)))
+    ((_ a)          a)
+    ((_ a b)        (let ((va a))
+                      (if (err? va)
+                        b
+                        va)))
+    ((_ a b c ...)  (ok/or (ok/or a b) c ...))))
+
+(define-syntax ok/and
+  (syntax-rules ()
+    ((_)            #t)
+    ((_ a)          a)
+    ((_ a b)        (let ((va a))
+                      (if (err? va)
+                        va
+                        b)))
+    ((_ a b c ...)  (ok/and (ok/and a b) c ...))))
+
+(define-syntax guard-err
+  (syntax-rules ()
+    ((_ expr)
+     (guard-err expr ()))
+    ((_ expr conditions ...)
+     (condition-case expr
+       (exn conditions (err exn)) ...))))
+
+)
diff --git a/err.svnwiki b/err.svnwiki
new file mode 100644
index 0000000..9325184
--- /dev/null
+++ b/err.svnwiki
@@ -0,0 +1,91 @@
+= Err, a scheme library for reasoning with results
+
+{{err}} provides a disjoint error data type, and helper functions to
+conveniently work with them.
+
+
+== Design
+
+{{err}} distinguishes two types of values:
+{{err}} objects, for which {{err?}} returns true,
+and all others (so called {{ok}} objects).
+
+This means that existing code can be incorporated very easily as ok
+values do not need to be wrapped.
+Likewise, passing errors to existing code will trigger type errors quickly.
+(Note that the empty list, the false value, and the unspecified
+values are all considered {{ok}}.)
+
+For integrating with code which uses exceptions for error handling,
+{{err}} provides the {{guard-err}} macro and the {{ok}} procedure to convert
+between the two mechanisms.
+
+If you prefer explicit container types, you may like
+SRFI 189 ("Maybe and Either").
+
+If you need to deal with {{err}} values in a transparent way,
+you can use SRFI 111 ("Boxes") to contain them as {{ok}} values.
+
+
+== Core functions
+
+<procedure>(err <obj>)</procedure>
+
+Returns an err object that contains {{<obj>}}.
+If {{<obj>}} already is an err object, just returns {{<obj>}}.
+
+<procedure>(unerr <obj>)</procedure>
+
+Returns the object wrapped in the {{err}} object {{<obj>}}.
+Returns an unspecified value if {{<obj>}} is not an {{err}} object.
+
+<procedure>(err? <obj>)</procedure>
+
+Returns true if {{<obj>}} is an {{err}} object, false otherwise.
+
+<procedure>(ok? <obj>)</procedure>
+
+Returns true if {{<obj>}} is not an {{err}} object, false otherwise.
+
+
+== Helpers
+
+<procedure>(ok/if <obj> <case-ok> [<case-err>])</procedure>
+
+If {{<obj>}} is not an {{err}} object, calls {{<case-ok>}} with {{<obj>}}
+as argument.  If {{<obj>}} is an {{err}} object, and {{<case-err>}}
+is given, calls {{<case-err>}} with the value that was wrapped in {{<obj>}};
+if {{<case-err>}} is not given, returns {{<obj>}} as is.
+
+<procedure>(ok=> <obj> <fun>...)</procedure>
+
+Successively applies functions {{<fun>}} to the value {{<obj>}}
+(and then its return value etc.) as long as {{<obj>}} is {{ok?}}.
+
+<procedure>(err=> <obj> <fun>...)</procedure>
+
+If {{<obj>}} is an {{err}} object, unwrap it and successively
+apply the functions {{<fun>}}, else just return {{<obj>}}.
+(NB: this is not the dual to {{ok=>}}, as immediate values
+can be {{ok}} objects but function application continues.)
+
+<syntax>(ok/or <expr>...)</syntax>
+
+Evaluate the expressions {{<expr>...}} from left to right,
+stop and return as soon one is {{ok}}.
+
+<syntax>(ok/and <expr>...)</syntax>
+
+Evaluate the expressions {{<expr>...}} from left to right,
+stop and return as soon one is not {{ok}}.
+
+<syntax>(guard-err [(<exn>...)] <expr>)</syntax>
+
+Evaluate {{<expr>}} and when an exception is raised which is listed in
+{{<exn>...}} (or, by default, any exception), return the condition
+object wrapped as an {{err}} object.
+
+<syntax>(ok <obj>)</syntax>
+
+If {{<obj>>}} is an {{err}} object, raise it as an error (or re-raise
+if it wrapped a condition).  Else, return {{<obj>}}.
diff --git a/mew b/mew
index 1af1a2f..d2ce296 100755
--- a/mew
+++ b/mew
@@ -1,2 +1,2 @@
 #!/bin/sh
-exec csi -keyword-style prefix -R mew "$@"
+exec csi -keyword-style prefix -R mew -R err "$@"
diff --git a/mew.egg b/mew.egg
index 9c39c05..a31370c 100644
--- a/mew.egg
+++ b/mew.egg
@@ -1,6 +1,8 @@
 ;;; mew.egg -*- Scheme -*- vim: ft=scheme:
 
-((components (extension mew))
+((components
+   (extension mew)
+   (extension err))
  (version 0.0.1)
  (license "MIT")
  (author "Leah Neukirchen <leah@vuxu.org>")
diff --git a/tests/run.scm b/tests/run.scm
index 63df004..4f50a31 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1 +1,4 @@
 (load "test.mew")
+(load "test-err.scm")
+
+(test-exit)
diff --git a/tests/test-err.scm b/tests/test-err.scm
new file mode 100644
index 0000000..90ef00f
--- /dev/null
+++ b/tests/test-err.scm
@@ -0,0 +1,61 @@
+(import test
+        mew
+        err
+        (chicken condition))
+
+(test-group "basics"
+  (test #t (err? (err 42)))
+  (test #t (ok? 42))
+  (test #t (ok? #f))
+  (test #t (ok? (if #f #f)))
+  (test #t (ok? '()))
+  (test 42 (unerr (err 42)))
+  (test #t (void? (unerr 42))))
+
+(test-group "record-printer"
+  (test "#<err 42>" (format "~a" (err 42))))
+
+(test-group "ok/if"
+  (test 5 (ok/if 4 inc))
+  (test 5 (ok/if 4 inc dec))
+  (test 3 (ok/if (err 4) inc dec)))
+
+(test-group "ok=>"
+  (test 5 (ok=> 5))
+  (test 7 (ok=> 5 inc inc))
+  (test (err 5) (ok=> (err 5)))
+  (test (err 7) (ok=> 5 inc inc err inc inc)))
+
+(test-group "err=>"
+  (test 7 (err=> 7))
+  (test 7 (err=> (err 7)))
+  (test 7 (err=> 7 inc))
+  (test 9 (err=> (err 7) inc inc))
+  (test-error (err=> (err 7) err inc)))
+
+(test-group "ok"
+  (test 7 (ok 7))
+  (test-error (ok (err 7)))
+  (test #t (condition? (unerr (guard-err (ok (guard-err (/ 1 0))))))))
+
+(test-group "ok/or"
+  (test #t (err? (ok/or)))
+  (test 7 (ok/or 7))
+  (test #f (ok/or #f 7))
+  (test 7 (ok/or (err 6) 7))
+  (test 7 (ok/or (err 6) (err 8) 7))
+  (test 7 (ok/or (err 6) (err 8) 7 8))
+  (test 7 (ok/or 7 (error "not reached")))
+  (test-error (ok/or (err 7) (error "reached"))))
+
+(test-group "ok/and"
+  (test #t (ok/and))
+  (test 8 (ok/and 6 7 8))
+  (test 8 (ok/and #f 7 8))
+  (test (err 6) (ok/and (err 6) 7 8))
+  (test (err 7) (ok/and 6 (err 7) 8)))
+
+(test-group "guard-err"
+  (test #t (err? (guard-err (/ 1 0))))
+  (test 1/2 (guard-err (/ 1 2)))
+  (test-error (err? (guard-err (/ 1 0) (exn bounds)))))
diff --git a/tests/test.mew b/tests/test.mew
index 7782fb6..948837a 100644
--- a/tests/test.mew
+++ b/tests/test.mew
@@ -580,6 +580,3 @@
   (test 42 (imp #t #t #t 42))
   (test 42 (imp 39 40 41 42))
   (test #t (imp 39 #f 41 42)))
-
-
-(test-exit)