add =>, set=>, and=>

3 files changed, 54 insertions, 3 deletions

diff --git a/mew.scm b/mew.scm
index abd4cb8..a6bef13 100644
--- a/mew.scm
+++ b/mew.scm
@@ -25,6 +25,7 @@
      -> fun-> fun->> set->
      =? <>?
      ~?
+     => and=> set=>
 
      generic-make-accumulator)
 
@@ -718,9 +719,6 @@
                                  `(,(rename 'equal?) x ,v))
                                (cdr expr)))))))
 
-  (define (per . args)
-    (apply comp (reverse args)))
-
   (define inject
     (case-lambda
       ((f) (lambda (o)
@@ -744,9 +742,27 @@
     (lambda args
       (unlist (map (lambda (f) (apply f args)) fs))))
 
+  (define (per . args)
+    (apply comp (reverse args)))
+
   (define (act x . fs)
     ((apply per fs) x))
 
+  (define => act)
+
+  (define-syntax set=>
+    (syntax-rules ()
+      ((_ location . fs)
+       (set location (=> location . fs)))))
+
+  (define (and=> x . fs)
+    (and x
+         (if (null? fs)
+           x
+           (let ((result ((car fs) x)))
+             (and result
+                  (apply and=> result (cdr fs)))))))
+
   (define-syntax proj
     (syntax-rules ()
       ((_ 0) (lambda (a . args) a))
diff --git a/mew.svnwiki b/mew.svnwiki
index dc2208d..18ae072 100644
--- a/mew.svnwiki
+++ b/mew.svnwiki
@@ -194,6 +194,19 @@ Reverse function composition.
 
 Reverse function compose all {{<fun>}}, then apply to {{<obj>}}.
 
+<procedure>(=> <obj> <fun>...)</procedure>
+
+Alias for {{act}}.
+
+<syntax>(set=> <loc> <fun>...)</set>
+
+Shortcut for {{(set <loc> (=> <loc> <fun>...))}}.
+
+<procedure>(and=> <obj> <fun>...)</procedure>
+
+Apply the first function in {{<fun>}} to {{<obj>}}, then the second to
+the result, etc.  Stop if any value is false.
+
 <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 9cbef3e..c8c9d16 100644
--- a/tests/test.mew
+++ b/tests/test.mew
@@ -434,6 +434,28 @@
   (test 43 (act '(6 7) (op apply * _) inc))
   (test 42 (act 42)))
 
+(test-group "=>"
+  (test 42 (=> 40 inc inc))
+  (test #f (=> 40 inc even?))
+  (test 43 (=> '(6 7) (op apply * _) inc))
+  (test 42 (=> 42)))
+
+(test-group "set=>"
+  (test 42 (seq
+             (def x 40)
+             (set=> x inc inc)
+             x))
+  (test 42 (seq
+             (def x #(13/2 2 3))
+             (set=> (at x 0) (juxt ceil floor) *)
+             (at x 0))))
+
+(test-group "and=>"
+  (test #t (and=> 42 even?))
+  (test #f (and=> #f even?))
+  (test 42 (and=> 40 inc inc))
+  (test #f (and=> 40 odd? inc)))
+
 (test-group "void"
   (test #t (void? (void)))
   (test #t (void? (void 1 2 3))))