Merge pull request #247 from carloshernandez2/test-new-cats-mlet-macro

Test cats mlet macro that avoids nesting fn declarations

Author: sovelten

CHANGELOG.md

@@ -1,5 +1,11 @@
 # Changelog #
 
+## Version 2.4.3
+
+Date: 2025-03-10
+
+- Change mlet to declare monad functions on a single let form to avoid too long class file names
+
 ## Version 2.4.2
 
 Date: 2022-02-22

dev/user.clj

@@ -8,12 +8,7 @@
   *namespaces*
   ['cats.core-spec
    'cats.builtin-spec
-   'cats.applicative.validation-spec
    'cats.labs.channel-spec
-   'cats.labs.state-spec
-   'cats.labs.writer-spec
-   'cats.labs.reader-spec
-   'cats.labs.continuation-spec
    'cats.monad.identity-spec
    'cats.monad.either-spec
    'cats.monad.exception-spec

project.clj

@@ -1,4 +1,4 @@
-(defproject funcool/cats "2.4.2"
+(defproject funcool/cats "2.4.3-beta.1"
   :description "Category Theory abstractions for Clojure"
   :url         "https://github.com/funcool/cats"
   :license {:name "BSD (2 Clause)"

src/cats/core.cljc

@@ -229,6 +229,22 @@
 ;; Monadic Let Macro
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(defn- flatten-bindings
+  [bindings]
+  (filterv symbol? (tree-seq coll? seq bindings)))
+
+(defn- parse-step
+  [[l r] fn-bindings fn-sym]
+  (case l
+    :let
+    (let [normalized-bindings (flatten-bindings (conj fn-bindings (take-nth 2 r)))]
+      [`(let ~r (~fn-sym ~@normalized-bindings)) normalized-bindings])
+    :when
+    (let [normalized-bindings (flatten-bindings fn-bindings)]
+      [`(bind (guard ~r) (partial ~fn-sym ~@normalized-bindings)) (conj normalized-bindings '_)])
+    (let [normalized-bindings (flatten-bindings fn-bindings)]
+      [`(bind ~r (partial ~fn-sym ~@normalized-bindings)) (conj normalized-bindings l)])))
+
 #?(:clj
    (defmacro mlet
      "Monad composition macro that works like Clojure's
@@ -258,14 +274,20 @@
                     (not-empty bindings)
                     (even? (count bindings)))
        (throw (IllegalArgumentException. "bindings has to be a vector with even number of elements.")))
-     (->> (reverse (partition 2 bindings))
-          (reduce (fn [acc [l r]]
-                    (case l
-                      :let  `(let ~r ~acc)
-                      :when `(bind (guard ~r)
-                                   (fn [~(gensym)] ~acc))
-                      `(bind ~r (fn [~l] ~acc))))
-                  `(do ~@body)))))
+     (let [first-sym (gensym)
+           [let-body new-fn-bindings] (parse-step (take 2 bindings) [] first-sym)]
+       (loop [rem-bindings (next (partition 2 bindings))
+              current-sym first-sym
+              fn-bindings new-fn-bindings
+              new-bindings []]
+         (if (empty? rem-bindings)
+           (list 'let (into [] cat [[current-sym `(fn ~'_ ~(conj ['&] fn-bindings) ~@body)] new-bindings]) let-body)
+           (let [new-sym (gensym)
+                 [expr new-fn-bindings] (parse-step (first rem-bindings) fn-bindings new-sym)]
+             (recur (next rem-bindings)
+                    new-sym
+                    new-fn-bindings
+                    (into [] cat [[current-sym `(fn ~'_ ~(conj ['&] fn-bindings) ~expr)] new-bindings]))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Applicative Let Macro

test/cats/core_spec.cljc

@@ -31,9 +31,9 @@
 (t/deftest mlet-tests
   (t/testing "Support regular let bindings inside mlet"
     (t/is (= (maybe/just 2)
-             (m/mlet [i (maybe/just 1)
+             (m/mlet [{i :i j :j} (maybe/just {:i 1 :j 0})
                       :let [i (inc i)]]
-               (m/return i)))))
+               (m/return (+ i j))))))
 
   (t/testing "Support :when guards inside its bindings"
     (t/is (= (maybe/nothing)