From 9816d6cea8603026458251f22b147df73b106bd8 Mon Sep 17 00:00:00 2001
From: Leah Neukirchen <leah@vuxu.org>
Date: Thu, 1 Dec 2022 21:46:18 +0100
Subject: add fun=>, op=>

---
 mew.scm        | 24 +++++++++++++++++++++++-
 mew.svnwiki    | 10 ++++++++++
 tests/test.mew | 12 ++++++++++++
 3 files changed, 45 insertions(+), 1 deletion(-)

diff --git a/mew.scm b/mew.scm
index 4caebd1..524c10c 100644
--- a/mew.scm
+++ b/mew.scm
@@ -27,7 +27,7 @@
      -> fun-> fun->> set->
      =? <>?
      ~?
-     => =>* and=> set=>
+     => =>* and=> fun=> op=> set=>
 
      generic-make-accumulator)
 
@@ -975,6 +975,28 @@
              (and result
                   (apply and=> result (cdr fs)))))))
 
+  (define-syntax fun=>-inner
+    (syntax-rules ()
+      ((_ (acc ...))
+       (compose acc ...))
+      ((_ (acc ...) ,arg args ...)
+       (fun=>-inner (arg acc ...) args ...))
+      ((_ (acc ...) (arg ...) args ...)
+       (fun=>-inner ((op arg ...) acc ...) args ...))
+      ((_ (acc ...) arg args ...)
+       (fun=>-inner (arg acc ...) args ...))
+      ))
+
+  (define-syntax fun=>
+    (syntax-rules ()
+      ((fun=> . args)
+       (fun=>-inner () . args))))
+
+  (define-syntax op=>
+    (syntax-rules (_)
+      ((op=> init . args)
+       ((fun=> . args) init))))
+
   (define-syntax proj
     (er-macro-transformer
       (lambda (expr rename compare)
diff --git a/mew.svnwiki b/mew.svnwiki
index c705e29..e6b437c 100644
--- a/mew.svnwiki
+++ b/mew.svnwiki
@@ -227,6 +227,16 @@ Shortcut for {{(set <loc> (=> <loc> <fun>...))}}.
 Apply the first function in {{<fun>}} to {{<obj>}}, then the second to
 the result, etc.  Stop if any value is false.
 
+<procedure>(op=> <obj> <form>...)</procedure>
+
+Like {{=>}}, but all {{<form>}} which are lists implicitly use {{op}}.
+If {{<form>}} is not a list, or an unquoted {{,}} list, it is used as is.
+
+<procedure>(fun=> <form>...)</procedure>
+
+Like {{per}}, but all {{<form>}} which are lists implicitly use {{op}}.
+If {{<form>}} is not a list, or an unquoted {{,}} list, it is used as is.
+
 <procedure>(juxt <fun>...)</procedure>
 
 Returns a function that applies each {{<fun>}} to its arguments and
diff --git a/tests/test.mew b/tests/test.mew
index 92eb35c..e674481 100644
--- a/tests/test.mew
+++ b/tests/test.mew
@@ -531,6 +531,18 @@
   (test 42 (and=> 40 inc inc))
   (test #f (and=> 40 odd? inc)))
 
+(test-group "op=>"
+  (test 42 (op=> 40 (+ _ 1) inc))
+  (test #f (op=> 40 inc even?))
+  (test 43 (op=> '(6 7) (apply * _) inc))
+  (test 42 (op=> 42)))
+
+(test-group "fun=>"
+  (test 42 ((fun=> (+ _ 1) inc) 40))
+  (test #f ((fun=> inc even?) 40))
+  (test 43 ((fun=> * inc) 6 7))
+  (test 42 ((fun=>) 42)))
+
 (test-group "void"
   (test #t (void? (void)))
   (test #t (void? (void 1 2 3))))
-- 
cgit 1.4.1