diff options
| -rw-r--r-- | err.scm | 94 | ||||
| -rw-r--r-- | err.svnwiki | 91 | ||||
| -rwxr-xr-x | mew | 2 | ||||
| -rw-r--r-- | mew.egg | 4 | ||||
| -rw-r--r-- | tests/run.scm | 3 | ||||
| -rw-r--r-- | tests/test-err.scm | 61 | ||||
| -rw-r--r-- | tests/test.mew | 3 |
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) |