diff options
author | Leah Neukirchen <leah@vuxu.org> | 2022-11-19 17:03:36 +0100 |
---|---|---|
committer | Leah Neukirchen <leah@vuxu.org> | 2022-11-19 17:03:36 +0100 |
commit | 824bf7c8794b317e1a45e8f8787871194a165fcb (patch) | |
tree | 6cc55a6b40973fc71f1a836cc460729f975acb61 /err.scm | |
parent | 5bde1a7f4936e991c86da20fe0a143b527161ae2 (diff) | |
download | mew-824bf7c8794b317e1a45e8f8787871194a165fcb.tar.gz mew-824bf7c8794b317e1a45e8f8787871194a165fcb.tar.xz mew-824bf7c8794b317e1a45e8f8787871194a165fcb.zip |
add err library
Diffstat (limited to 'err.scm')
-rw-r--r-- | err.scm | 94 |
1 files changed, 94 insertions, 0 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)) ...)))) + +) |