From db5da6cdc78cce6634f28c26f8a230683273908a Mon Sep 17 00:00:00 2001
From: Andrey Orst <andreyorst@gmail.com>
Date: Sun, 15 Nov 2020 16:15:12 +0300
Subject: feature(core): implement `reduced`

---
 cljlib.fnl     | 39 +++++++++++++++++++++++++++++----------
 tests/core.fnl | 13 +++++++++++++
 2 files changed, 42 insertions(+), 10 deletions(-)

diff --git a/cljlib.fnl b/cljlib.fnl
index d519383..d429d09 100644
--- a/cljlib.fnl
+++ b/cljlib.fnl
@@ -265,25 +265,44 @@ val and f is not called.  Calls `seq` on `col`."
        _ (let [[a b & rest] col]
            (reduce f (f a b) rest)))))
   ([f val col]
-   (let [col (or (seq col) (empty []))]
-     (let [[x & xs] col]
-       (if (nil? x)
-           val
-           (reduce f (f val x) xs))))))
+   (if-some [reduced (when-some [m (getmetatable val)]
+                       (and m.cljlib/reduced
+                            (= m.cljlib/reduced.status :ready)
+                            m.cljlib/reduced.val))]
+     reduced
+     (let [col (or (seq col) (empty []))]
+       (let [[x & xs] col]
+         (if (nil? x)
+             val
+             (reduce f (f val x) xs)))))))
+
+(fn* core.reduced
+  "Wraps `x` in such a way so [`reduce`](#reduce) will terminate early
+  with this value."
+  [x]
+  (setmetatable
+   {} {:cljlib/reduced {:status :ready
+                        :val x}}))
 
 (fn* core.reduce-kv
   "Reduces an associative table using function `f` and initial value `val`.
 
 `f` should be a function of 3 arguments.  Returns the result of
-applying `f` to `val`, the first key and the first value in `coll`,
+applying `f` to `val`, the first key and the first value in `tbl`,
 then applying `f` to that result and the 2nd key and value, etc.  If
-`coll` contains no entries, returns `val` and `f` is not called.  Note
+`tbl` contains no entries, returns `val` and `f` is not called.  Note
 that reduce-kv is supported on sequential tables and strings, where
 the keys will be the ordinals."
-  [f val col]
+  [f val tbl]
   (var res val)
-  (each [_ [k v] (pairs (or (seq col) (empty [])))]
-    (set res (f res k v)))
+  (each [_ [k v] (pairs (or (seq tbl) (empty [])))]
+    (set res (f res k v))
+    (when-some [reduced (when-some [m (getmetatable res)]
+                          (and m.cljlib/reduced
+                               (= m.cljlib/reduced.status :ready)
+                               m.cljlib/reduced.val))]
+      (set res reduced)
+      (lua :break)))
   res)
 
 (fn* core.mapv
diff --git a/tests/core.fnl b/tests/core.fnl
index 2481f02..3939458 100644
--- a/tests/core.fnl
+++ b/tests/core.fnl
@@ -315,6 +315,19 @@
     (assert-not (pcall reduce-kv #(+ $1 $3)))
     (assert-not (pcall reduce-kv)))
 
+  (testing "reduced"
+    (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) [1]) 1)
+    (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) [1 2]) 3)
+    (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) [1 2 3 4]) 10)
+    (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) [1 2 3 4 5]) 15)
+    (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) [1 2 3 4 5 6]) -1)
+    (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) 10 [1]) 11)
+    (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) 10 [1 2]) -1)
+
+    (assert-eq (reduce-kv (fn [res _ v] (if (> res 10) (reduced -1) (+ res v))) 0 {:a 1 :b 2}) 3)
+    (assert-eq (reduce-kv (fn [res _ v] (if (> res 10) (reduced -1) (+ res v))) 0 {:a 10 :b 2}) 12)
+    (assert-eq (reduce-kv (fn [res _ v] (if (> res 10) (reduced -1) (+ res v))) 1 {:a 10 :b 2}) -1))
+
   (testing "assoc"
     (assert-not (pcall assoc))
     (assert-not (pcall assoc {}))
-- 
cgit v1.2.3