Fix construction of :guard patterns left hand sides.

Author: neshtea

src/active/clojure/match.clj

@@ -510,27 +510,47 @@
     (optional-clause? clause)
     {}))
 
-(defn deep-merge-with
-  "Like merge-with, but merges maps recursively, applying the given fn
-  only when there's a non-map at a particular level.
-  (deep-merge-with + {:a {:b {:c 1 :d {:x 1 :y 2}} :e 3} :f 4}
-                     {:a {:b {:c 2 :d {:z 9} :z 3} :e 100}})
-  -> {:a {:b {:z 3, :c 3, :d {:z 9, :x 1, :y 2}}, :e 103}, :f 4}"
-  [f & maps]
-  (apply
-   (fn m [& maps]
-     (if (every? map? maps)
-       (apply merge-with m maps)
-       (apply f maps)))
-   maps))
+(defn deep-merge [v & vs]
+  (letfn [(rec-merge [v1 v2]
+            (if (and (map? v1) (map? v2))
+              (merge-with deep-merge v1 v2)
+              v2))]
+    (if (some identity vs)
+      (reduce #(rec-merge %1 %2) v vs)
+      v)))
+
+(defn reduce-lhs
+  [lhss]
+  (reduce (fn [acc lhs]
+            (cond
+              (and (map? acc) (map? lhs))
+              (deep-merge acc lhs)
+
+              (and (sequential? acc) (map? lhs))
+              (let [[acc-map & tail] acc]
+                (cons (deep-merge acc-map lhs) tail))
+
+              (and (map? acc) (sequential? lhs))
+              (let [[lhs-map & tail] lhs]
+                (cons (deep-merge acc lhs-map) tail))
+
+              (and (sequential? acc) (sequential? lhs))
+              (let [[acc-map guard-key acc-tail] acc
+                    [lhs-map guard-key lhs-tail] lhs]
+                (list (deep-merge acc-map lhs-map) :guard (concat acc-tail lhs-tail)))
+
+              :else
+              (c/assertion-violation `reduce-lhs "not a valid lhs pattern:" lhs)))
+          {}
+          lhss))
 
 (defn pattern->lhs
   [message pattern]
   (let [clauses (pattern-clauses pattern)]
     (->> pattern
          pattern-clauses
          (mapv (partial clause->lhs message))
-         (apply deep-merge-with merge))))
+         reduce-lhs)))
 
 (defn clause->rhs
   [message bindings clause]

test/active/clojure/match_test.clj

@@ -129,6 +129,25 @@
                                              (-> (p/path-matches-clause [:x :y :z] (p/match-const "b"))
                                                  (p/bind-match 'rebind))))))
 
+(t/deftest reduce-lhs-test
+  (t/is (empty? (p/reduce-lhs [])))
+  (t/is (= {:x "x"} (p/reduce-lhs [{:x "x"}])))
+  (t/is (= {:x "x" :y 'y} (p/reduce-lhs [{:x "x"} {:y 'y}])))
+  (t/is (= {:x "other"} (p/reduce-lhs [{:x "X"} {:x "other"}])))
+  (t/is (= (list {:x "x" :y "y"} :guard [:some-guard])
+           (p/reduce-lhs [(list {:x "x"} :guard [:some-guard])
+                          {:y "y"}])))
+  (t/is (= (list {:x "x" :y "y"})
+           (p/reduce-lhs [{:x "x"} (list {:y "y"})])))
+
+  (t/is (= (list {:x "x" :y '_ :a 42 :z '_} :guard [:guard-1 :guard-2 :guard-3])
+           (p/reduce-lhs [{:x "x"}
+                          (list {:y '_} :guard [:guard-1])
+                          (list {:y '_} :guard [:guard-2])
+                          {:a 42}
+                          (list {:z '_} :guard [:guard-3])]))))
+
+
 ;; Imported test from active.clojure.match-test
 (def one-data
   {:kind "one" :x "x" :y "y" :z "z" :w "w"})
@@ -211,46 +230,49 @@
 
 
 ;;; FIXME these tests all fail because compare-fn patterns dont work.
-;; (p/defpattern one-guard
-;;   [(:kind #"one")
-;;    (:x (:compare-fn #(= % (last ["a" "b" "c" "x"]))) :as x)
-;;    (:y (:compare-fn #(= % (:y {:x "x" :y "y" :z "z"}))))
-;;    (:z :as z)
-;;    :w])
-
-;; (def example-guard-matcher
-;;   (p/map-matcher
-;;    one-guard [x y z w]
-;;    two [a b c Z Y X foo]
-;;    :else false))
-
-;; (def predicate-matcher
-;;   (p/map-matcher
-;;    ;; The order is important
-;;    [(:x (:compare-fn #(string? %)))] ::string
-;;    [(:x (:compare-fn (fn [x] (boolean? x))))] ::boolean
-;;    [(:x (:compare-fn even?))] ::even
-;;    [(:x (:compare-fn odd?))] ::odd))
-
-;; (t/deftest map-matcher-predicate-test
-;;   (t/is (= ::even (predicate-matcher {:x 42})))
-;;   (t/is (= ::odd (predicate-matcher {:x 41})))
-;;   (t/is (= ::string (predicate-matcher {:x "string"})))
-;;   (t/is (= ::boolean (predicate-matcher {:x true}))))
-
-;; (p/defpattern predicate-pattern
-;;   [(:x (:compare-fn even?))])
-
-;; (t/deftest map-matcher-polymorphism-test
-;;   (t/testing "works with a pattern record"
-;;     (t/is (= ::even
-;;              ((p/map-matcher predicate-pattern ::even)
-;;               {:x 42}))))
-
-;;   (t/testing "works with pattern syntax"
-;;     (t/is (= ::even
-;;              ((p/map-matcher [(:x (:compare-fn even?))] ::even)
-;;               {:x 42})))))
+(p/defpattern one-guard
+  [(:kind #"one")
+   (:x (:compare-fn #(= % (last ["a" "b" "c" "x"]))) :as x)
+   (:y (:compare-fn #(= % (:y {:x "x" :y "y" :z "z"}))))
+   (:z :as z)
+   :w])
+
+(macroexpand-1 '(old-match/map-matcher [(:x (:compare-fn even?))
+                                        :y] x))
+
+(def example-guard-matcher
+  (p/map-matcher
+   one-guard [x y z w]
+   two [a b c Z Y X foo]
+   :else false))
+
+(def predicate-matcher
+  (p/map-matcher
+   ;; The order is important
+   [(:x (:compare-fn #(string? %)))] ::string
+   [(:x (:compare-fn (fn [x] (boolean? x))))] ::boolean
+   [(:x (:compare-fn even?))] ::even
+   [(:x (:compare-fn odd?))] ::odd))
+
+(t/deftest map-matcher-predicate-test
+  (t/is (= ::even (predicate-matcher {:x 42})))
+  (t/is (= ::odd (predicate-matcher {:x 41})))
+  (t/is (= ::string (predicate-matcher {:x "string"})))
+  (t/is (= ::boolean (predicate-matcher {:x true}))))
+
+(p/defpattern predicate-pattern
+  [(:x (:compare-fn even?))])
+
+(t/deftest map-matcher-polymorphism-test
+  (t/testing "works with a pattern record"
+    (t/is (= ::even
+             ((p/map-matcher predicate-pattern ::even)
+              {:x 42}))))
+
+  (t/testing "works with pattern syntax"
+    (t/is (= ::even
+             ((p/map-matcher [(:x (:compare-fn even?))] ::even)
+              {:x 42})))))
 
 ;; FIXME this should work
 ;; (t/deftest closes-over-outer-variables-test