blob: 0dad12b168b7b88481f4c245a6177dfc6f1dfee8 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
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)) ...))))
)
|
