diff options
| -rw-r--r-- | mew.scm | 55 | ||||
| -rw-r--r-- | mew.svnwiki | 15 | ||||
| -rw-r--r-- | tests/test.mew | 8 |
3 files changed, 73 insertions, 5 deletions
diff --git a/mew.scm b/mew.scm index 167bb99..7870656 100644 --- a/mew.scm +++ b/mew.scm @@ -48,7 +48,7 @@ (hash-table-keys keys) (hash-table-values vals)) srfi-158 - matchable) + err) (reexport srfi-1) (reexport srfi-69) @@ -100,6 +100,7 @@ (reexport err) + (define (inc i) (+ i 1)) @@ -561,13 +562,45 @@ (if-apply-last expr bool then ((op)))) )) + (define-syntax ok-apply + (syntax-rules () + ((_ x f args ...) + (let ((v x)) + (if (ok? v) + (f v args ...) + v))))) + + (define-syntax ok-apply-last + (syntax-rules () + ((_ x f args ...) + (let ((v x)) + (if (ok? v) + (f args ... v) + v))))) + + (define-syntax err-apply + (syntax-rules () + ((_ x f args ...) + (let ((v x)) + (if (err? v) + (f (unerr v) args ...) + v))))) + + (define-syntax err-apply-last + (syntax-rules () + ((_ x f args ...) + (let ((v x)) + (if (err? v) + (f args ... (unerr v)) + v))))) + (define-syntax -> (syntax-rules () ((_ rest ...) (->chunk () () (rest ...))))) (define-syntax ->chunk - (syntax-rules (-> ->> and-> and->> if-> if->>) + (syntax-rules (-> ->> and-> and->> if-> if->> ok-> ok->> err-> err->>) ((_ (result ...) (current ...) (-> rest ...)) (->chunk (result ... (current ...)) (->) (rest ...))) ((_ (result ...) (current ...) (->> rest ...)) @@ -580,6 +613,14 @@ (->chunk (result ... (current ...)) (-> if-apply) (rest ...))) ((_ (result ...) (current ...) (if->> rest ...)) (->chunk (result ... (current ...)) (-> if-apply-last) (rest ...))) + ((_ (result ...) (current ...) (ok-> rest ...)) + (->chunk (result ... (current ...)) (-> ok-apply) (rest ...))) + ((_ (result ...) (current ...) (ok->> rest ...)) + (->chunk (result ... (current ...)) (-> ok-apply-last) (rest ...))) + ((_ (result ...) (current ...) (err-> rest ...)) + (->chunk (result ... (current ...)) (-> err-apply) (rest ...))) + ((_ (result ...) (current ...) (err->> rest ...)) + (->chunk (result ... (current ...)) (-> err-apply-last) (rest ...))) ((_ (result ...) (current ...) (a rest ...)) (->chunk (result ...) (current ... a) (rest ...))) ((_ ((x) result ...) (current ...) ()) @@ -607,7 +648,7 @@ (lambda (x) (-> x ->> rest ...))))) (define-syntax set-> - (syntax-rules (-> ->> and-> and->> if-> if->>) + (syntax-rules (-> ->> and-> and->> if-> if->> ok ok->> err-> err->>) ((_ location -> rest ...) (set! location (-> location -> rest ...))) ((_ location ->> rest ...) @@ -620,6 +661,14 @@ (set! location (-> location if-> rest ...))) ((_ location if->> rest ...) (set! location (-> location if->> rest ...))) + ((_ location ok-> rest ...) + (set! location (-> location ok-> rest ...))) + ((_ location ok->> rest ...) + (set! location (-> location ok->> rest ...))) + ((_ location err-> rest ...) + (set! location (-> location err-> rest ...))) + ((_ location err->> rest ...) + (set! location (-> location err->> rest ...))) ((_ location rest ...) ; default to -> (set! location (-> location -> rest ...))))) diff --git a/mew.svnwiki b/mew.svnwiki index 629d11b..e3cabdb 100644 --- a/mew.svnwiki +++ b/mew.svnwiki @@ -44,7 +44,8 @@ SRFI-158 (Generators and Accumulators), {{(chicken irregex)}}, {{(chicken pretty-print)}}}, {{(chicken sort)}}}, -and {{matchable}}. +{{matchable}}, +and {{err}} (see {{err.svnwiki}}). == Definitions, bindings and assignments @@ -540,3 +541,15 @@ Evaluate {{<val>}}. Then, when {{<cond>}} is not false, behaves like Like {{->}}/{{->>}} but skips nesting the code if the nested expression is false. + +<syntax>(-> ... ok-> ...)<syntax> +<syntax>(-> ... ok->> ...)<syntax> + +Like {{->}}/{{->>}} but skips nesting the code if the nested +expression is {{err?}}. + +<syntax>(-> ... err-> ...)<syntax> +<syntax>(-> ... err->> ...)<syntax> + +Like {{->}}/{{->>}} but skips nesting the code if the nested +expression is {{ok?}}. The unwrapped value is inserted into the nesting. diff --git a/tests/test.mew b/tests/test.mew index 948837a..52de20a 100644 --- a/tests/test.mew +++ b/tests/test.mew @@ -370,7 +370,13 @@ (into '() (cross-product '(a b c)))) (test '() (into '() (cross-product)))) -; -> +(test-group "->" + (test 6 (-> 3 -> inc -> + 2)) + (test 9 (-> #f -> or 7 -> + 2)) + (test 9 (-> 6 ->> or 7 -> + 2)) + (test 7 (-> 5 ok-> inc ok-> + 1)) + (test (err 7) (-> (err 7) ok-> inc ok-> + 1)) + (test 7 (-> (err 6) err-> + 1))) ; fun-> |