From 824bf7c8794b317e1a45e8f8787871194a165fcb Mon Sep 17 00:00:00 2001 From: Leah Neukirchen Date: Sat, 19 Nov 2022 17:03:36 +0100 Subject: add err library --- err.scm | 94 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ err.svnwiki | 91 ++++++++++++++++++++++++++++++++++++++++++++++++++++ mew | 2 +- mew.egg | 4 ++- tests/run.scm | 3 ++ tests/test-err.scm | 61 +++++++++++++++++++++++++++++++++++ tests/test.mew | 3 -- 7 files changed, 253 insertions(+), 5 deletions(-) create mode 100644 err.scm create mode 100644 err.svnwiki create mode 100644 tests/test-err.scm 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 + (%make-err data) + err? + (data %err-data)) + +(set-record-printer! + (lambda (x out) + (fprintf out "#" (%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 + +(err ) + +Returns an err object that contains {{}}. +If {{}} already is an err object, just returns {{}}. + +(unerr ) + +Returns the object wrapped in the {{err}} object {{}}. +Returns an unspecified value if {{}} is not an {{err}} object. + +(err? ) + +Returns true if {{}} is an {{err}} object, false otherwise. + +(ok? ) + +Returns true if {{}} is not an {{err}} object, false otherwise. + + +== Helpers + +(ok/if []) + +If {{}} is not an {{err}} object, calls {{}} with {{}} +as argument. If {{}} is an {{err}} object, and {{}} +is given, calls {{}} with the value that was wrapped in {{}}; +if {{}} is not given, returns {{}} as is. + +(ok=> ...) + +Successively applies functions {{}} to the value {{}} +(and then its return value etc.) as long as {{}} is {{ok?}}. + +(err=> ...) + +If {{}} is an {{err}} object, unwrap it and successively +apply the functions {{}}, else just return {{}}. +(NB: this is not the dual to {{ok=>}}, as immediate values +can be {{ok}} objects but function application continues.) + +(ok/or ...) + +Evaluate the expressions {{...}} from left to right, +stop and return as soon one is {{ok}}. + +(ok/and ...) + +Evaluate the expressions {{...}} from left to right, +stop and return as soon one is not {{ok}}. + +(guard-err [(...)] ) + +Evaluate {{}} and when an exception is raised which is listed in +{{...}} (or, by default, any exception), return the condition +object wrapped as an {{err}} object. + +(ok ) + +If {{>}} is an {{err}} object, raise it as an error (or re-raise +if it wrapped a condition). Else, return {{}}. 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 ") 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 "#" (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) -- cgit 1.4.1