Added merge-with

docs/language/core.rst

@@ -449,6 +449,24 @@ Returns the single step macro expansion of form.
    => (macroexpand-1 '(-> (a b) (-> (c d) (e f))))
    (u'_>' (u'a' u'b') (u'c' u'd') (u'e' u'f'))
 
+
+.. _merge-with-fn:
+
+merge-with
+----------
+
+.. versionadded:: 0.10.0
+
+Usage: ``(merge-with f &rest maps)
+
+Returns a map that consist of the rest of the maps joined onto first. If a key occurs in more than one map, the mapping(s) from the latter (left-to-right) will be combined with the mapping in the result by calling (f val-in-result val-in-latter).
+
+.. code-block:: clojure
+
+    => (merge-with (fn [x y] (+ x y)) {"a" 10 "b" 20} {"a" 1 "c" 30})
+    {u'a': 11L, u'c': 30L, u'b': 20L}
+
+
 .. _neg?-fn:
 
 neg?

hy/core/language.hy

@@ -253,6 +253,22 @@
   (setv name (calling-module-name))
   (hy.macros.macroexpand-1 form name))
 
+(defn merge-with [f &rest maps]
+  "Returns a map that consists of the rest of the maps joined onto
+   the first. If a key occurs in more than one map, the mapping(s)
+   from the latter (left-to-right) will be combined with the mapping in
+   the result by calling (f val-in-result val-in-latter)."
+  (if (any maps)
+    (let [[merge-entry (fn [m e]
+			 (let [[k (get e 0)] [v (get e 1)]]
+			   (if (in k m)
+			     (assoc m k (f (get m k) v))
+			     (assoc m k v)))
+			 m)]
+	  [merge2 (fn [m1 m2]
+		    (reduce merge-entry (.items m2) (or m1 {})))]]
+      (reduce merge2 maps))))
+
 (defn neg? [n]
   "Return true if n is < 0"
   (_numeric-check n)
@@ -360,7 +376,7 @@
                  every? first filter filterfalse flatten float? gensym identity
                  inc input instance? integer integer? integer-char? interleave
                  interpose iterable? iterate iterator? keyword? list*
-                 macroexpand macroexpand-1 map neg? nil? none? nth
+                 macroexpand macroexpand-1 map merge-with neg? nil? none? nth
                  numeric? odd? pos? range read remove repeat repeatedly
                  rest reduce second some string string? take take-nth
                  take-while zero? zip zip_longest zipwith])

tests/native_tests/language.hy

@@ -1,6 +1,7 @@
 (import [tests.resources [kwtest function-with-a-dash]]
         [os.path [exists isdir isfile]]
-        [sys :as systest])
+        [sys :as systest]
+        [operator [or_]])
 (import sys)
 
 (import [hy._compat [PY33 PY34]])
@@ -985,6 +986,24 @@
   (assert (= (macroexpand-1 '(-> (a b) (-> (c d) (e f))))
              '(-> (a b) (c d) (e f)))))
 
+(defn test-merge-with []
+  "NATIVE: test merge-with"
+  (assert (= (merge-with + {} {}) nil))
+  (assert (= (merge-with + {"a" 10 "b" 20} {}) {"a" 10 "b" 20}))
+  (assert (= (merge-with + {} {"a" 10 "b" 20}) {"a" 10 "b" 20}))
+  (assert (= (merge-with + {"a" 10 "b" 20} {"a" 1 "c" 30})
+	     {"a" 11 "b" 20 "c" 30}))
+  (assert (= (merge-with +
+                         {:a 1  :b 2}
+                         {:a 9  :b 98  :c 0}
+                         {:a 10 :b 100 :c 10}
+                         {:a 5}
+                         {:c 5  :d 42})
+             {:d 42 :c 15 :a 25 :b 200}))
+  (assert (= (merge-with or_
+                         {"a" (set [1 2 3]) "b" (set [4 5 6])}
+                         {"a" (set [2 3 7 8]) "c" (set [1 2 3])})
+             {"a" (set [1 2 3 7 8]) "c" (set [1 2 3]) "b" (set [4 5 6])})))
 
 (defn test-calling-module-name []
   "NATIVE: Test the calling-module-name function"