From a06b95c052b4e70fe6fe61f7d90874fb6be00b56 Mon Sep 17 00:00:00 2001
From: Leah Neukirchen <leah@vuxu.org>
Date: Sat, 19 Nov 2022 17:23:53 +0100
Subject: add ok->, ok->>, err->, err->> to ->

---
 mew.scm        | 55 ++++++++++++++++++++++++++++++++++++++++++++++++++++---
 mew.svnwiki    | 15 ++++++++++++++-
 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->
 
-- 
cgit 1.4.1