Merge pull request #1050 from tuturto/multimethod

Modify multimethods to use dispatching function

docs/contrib/multi.rst

@@ -2,18 +2,22 @@
 defmulti
 ========
 
+defn
+----
 .. versionadded:: 0.10.0
 
-``defmulti`` lets you arity-overload a function by the given number of
-args and/or kwargs. Inspired by Clojure's take on ``defn``.
+``defn`` lets you arity-overload a function by the given number of
+args and/or kwargs. This version of ``defn`` works with regular syntax and
+with the arity overloaded one. Inspired by Clojures take on ``defn``.
 
 .. code-block:: clj
 
-    => (require [hy.contrib.multi [defmulti]])
-    =>   (defmulti fun
-    ...     ([a] "a")
-    ...     ([a b] "a b")
-    ...     ([a b c] "a b c"))
+    => (require [hy.contrib.multi [defn]])
+    => (defn fun
+    ...  ([a] "a")
+    ...  ([a b] "a b")
+    ...  ([a b c] "a b c"))
+
     => (fun 1)
     "a"
     => (fun 1 2)
@@ -21,3 +25,86 @@ args and/or kwargs. Inspired by Clojure's take on ``defn``.
     => (fun 1 2 3)
     "a b c"
 
+    => (defn add [a b] 
+    ...  (+ a b))
+    => (add 1 2)
+    3
+
+
+defmulti
+--------
+
+.. versionadded:: 0.12.0
+
+``defmulti``, ``defmethod`` and ``default-method`` lets you define
+multimethods where a dispatching function is used to select between different
+implementations of the function. Inspired by Clojure's multimethod and based
+on the code by `Adam Bard`_.
+
+.. code-block:: clj
+
+    => (require [hy.contrib.multi [defmulti defmethod default-method]])
+    => (defmulti area [shape]
+    ...  "calculate area of a shape"
+    ...  (:type shape))
+  
+    => (defmethod area "square" [square]
+    ...  (* (:width square)
+    ...     (:height square)))
+  
+    => (defmethod area "circle" [circle]
+    ...  (* (** (:radius circle) 2) 
+    ...     3.14))
+
+    => (default-method area [shape]
+    ...  0)
+
+    => (area {:type "circle" :radius 0.5})
+    0.785
+
+    => (area {:type "square" :width 2 :height 2})
+    4
+
+    => (area {:type "non-euclid rhomboid"})
+    0
+
+``defmulti`` is used to define the initial multimethod with name, signature
+and code that selects between different implementations. In the example,
+multimethod expects a single input that is type of dictionary and contains
+at least key :type. The value that corresponds to this key is returned and
+is used to selected between different implementations.
+
+``defmethod`` defines a possible implementation for multimethod. It works
+otherwise in the same way as ``defn``, but has an extra parameters 
+for specifying multimethod and which calls are routed to this specific
+implementation. In the example, shapes with "square" as :type are routed to
+first function and shapes with "circle" as :type are routed to second
+function.
+
+``default-method`` specifies default implementation for multimethod that is
+called when no other implementation matches.
+
+Interfaces of multimethod and different implementation don't have to be
+exactly identical, as long as they're compatible enough. In practice this
+means that multimethod should accept the broadest range of parameters and
+different implementations can narrow them down.
+
+.. code-block:: clj
+
+    => (require [hy.contrib.multi [defmulti defmethod]])
+    => (defmulti fun [&rest args]
+    ...  (len args))
+
+    => (defmethod fun 1 [a]
+    ...  a)
+
+    => (defmethod fun 2 [a b]
+    ...  (+ a b))
+
+    => (fun 1)
+    1
+
+    => (fun 1 2)
+    3
+
+.. _Adam Bard: https://adambard.com/blog/implementing-multimethods-in-python/

hy/contrib/multi.hy

@@ -1,5 +1,6 @@
 ;; Hy Arity-overloading
 ;; Copyright (c) 2014 Morten Linderud <mcfoxax@gmail.com>
+;; Copyright (c) 2016 Tuukka Turto <tuukka.turto@oktaeder.net>
 
 ;; Permission is hereby granted, free of charge, to any person obtaining a
 ;; copy of this software and associated documentation files (the "Software"),
@@ -19,23 +20,67 @@
 ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
 ;; DEALINGS IN THE SOFTWARE.
 
-(import [collections [defaultdict]])
-(import [hy.models.string [HyString]])
+(import [collections [defaultdict]]
+        [hy.models.expression [HyExpression]]
+        [hy.models.list [HyList]]
+        [hy.models.string [HyString]])
 
+(defn multi-decorator [dispatch-fn]
+  (setv inner (fn [&rest args &kwargs kwargs]
+                (setv dispatch-key (apply dispatch-fn args kwargs))
+                (if (in dispatch-key inner.--multi--)
+                  (apply (get inner.--multi-- dispatch-key) args kwargs)
+                  (apply inner.--multi-default-- args kwargs))))
+  (setv inner.--multi-- {})
+  (setv inner.--doc-- dispatch-fn.--doc--)
+  (setv inner.--multi-default-- (fn [&rest args &kwargs kwargs] None))
+  inner)
 
-(defmacro defmulti [name &rest bodies]
-  (def comment (HyString))
-  (if (= (type (first bodies)) HyString)
-    (do (def comment (car bodies))
-        (def bodies (cdr bodies))))
-
-  (def ret `(do))
-  
-  (.append ret '(import [hy.contrib.dispatch [MultiDispatch]]))
+(defn method-decorator [dispatch-fn &optional [dispatch-key None]]
+  (setv apply-decorator
+        (fn [func]
+          (if (is dispatch-key None)
+            (setv dispatch-fn.--multi-default-- func)
+           (assoc dispatch-fn.--multi-- dispatch-key func))
+          dispatch-fn))
+  apply-decorator)
  
-  (for [body bodies]
-    (def let-binds (car body))
-    (def body (cdr body))
-    (.append ret 
-        `(with-decorator MultiDispatch (defn ~name ~let-binds ~comment ~@body))))
-  ret)
+(defmacro defmulti [name params &rest body]
+  `(do (import [hy.contrib.multi [multi-decorator]])
+       (with-decorator multi-decorator
+         (defn ~name ~params ~@body))))
+
+(defmacro defmethod [name multi-key params &rest body]
+  `(do (import [hy.contrib.multi [method-decorator]])
+       (with-decorator (method-decorator ~name ~multi-key)
+         (defn ~name ~params ~@body))))
+
+(defmacro default-method [name params &rest body]
+  `(do (import [hy.contrib.multi [method-decorator]])
+       (with-decorator (method-decorator ~name)
+         (defn ~name ~params ~@body))))
+
+(defmacro defn [name &rest bodies]
+  (def arity-overloaded? (fn [bodies]
+                           (if (isinstance (first bodies) HyString)
+                             (arity-overloaded? (rest bodies))
+                             (isinstance (first bodies) HyExpression))))
+
+  (if (arity-overloaded? bodies)
+    (do
+     (def comment (HyString))
+     (if (= (type (first bodies)) HyString)
+       (do (def comment (car bodies))
+           (def bodies (cdr bodies))))
+     (def ret `(do))
+     (.append ret '(import [hy.contrib.dispatch [MultiDispatch]]))
+     (for [body bodies]
+       (def let-binds (car body))
+       (def body (cdr body))
+       (.append ret 
+                `(with-decorator MultiDispatch (defn ~name ~let-binds ~comment ~@body))))
+     ret)
+    (do
+     (setv lambda-list (first bodies))
+     (setv body (rest bodies))
+     `(setv ~name (fn ~lambda-list ~@body)))))

tests/native_tests/contrib/multi.hy

@@ -1,4 +1,5 @@
 ;; Copyright (c) 2014 Morten Linderud <mcfoxax@gmail.com>
+;; Copyright (c) 2016 Tuukka Turto <tuukka.turto@oktaeder.net>
  
 ;; Permission is hereby granted, free of charge, to any person obtaining a
 ;; copy of this software and associated documentation files (the "Software"),
@@ -18,12 +19,81 @@
 ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
 ;; DEALINGS IN THE SOFTWARE.
 
-(require [hy.contrib.multi [defmulti]])
+(require [hy.contrib.multi [defmulti defmethod default-method defn]])
 
+(defn test-different-signatures []
+  "NATIVE: Test multimethods with different signatures"
+  (defmulti fun [&rest args]
+    (len args))
+
+  (defmethod fun 0 []
+    "Hello!")
+
+  (defmethod fun 1 [a]
+    a)
+
+  (defmethod fun 2 [a b]
+    "a b")
+
+  (defmethod fun 3 [a b c]
+    "a b c")
+
+  (assert (= (fun) "Hello!"))
+  (assert (= (fun "a") "a"))
+  (assert (= (fun "a" "b") "a b"))
+  (assert (= (fun "a" "b" "c") "a b c")))
+
+
+(defn test-basic-dispatch []
+  "NATIVE: Test basic dispatch"
+  (defmulti area [shape]
+    (:type shape))
+  
+  (defmethod area "square" [square]
+    (* (:width square)
+       (:height square)))
+  
+  (defmethod area "circle" [circle]
+    (* (** (:radius circle) 2) 
+       3.14))
+
+  (default-method area [shape]
+    0)
+
+  (assert (< 0.784 (area {:type "circle" :radius 0.5}) 0.786))
+  (assert (= (area {:type "square" :width 2 :height 2})) 4)
+  (assert (= (area {:type "non-euclid rhomboid"}) 0)))
+
+(defn test-docs []
+  "NATIVE: Test if docs are properly handled"
+  (defmulti fun [a b]
+    "docs"
+    a)
+
+  (defmethod fun "foo" [a b]
+    "foo was called")
+
+  (defmethod fun "bar" [a b]
+    "bar was called")
+  
+  (assert (= fun.--doc-- "docs")))
+
+(defn test-kwargs-handling []
+  "NATIVE: Test handling of kwargs with multimethods"
+  (defmulti fun [&kwargs kwargs]
+    (get kwargs "type"))
+
+  (defmethod fun "foo" [&kwargs kwargs]
+    "foo was called")
+
+  (defmethod fun "bar" [&kwargs kwargs]
+    "bar was called")
+
+  (assert (= (fun :type "foo" :extra "extra") "foo was called")))
 
 (defn test-basic-multi []
-  "NATIVE: Test a basic defmulti"
-  (defmulti fun
+  "NATIVE: Test a basic arity overloaded defn"
+  (defn fun
     ([] "Hello!")
     ([a] a)
     ([a b] "a b")
@@ -36,8 +106,8 @@
 
 
 (defn test-kw-args []
-  "NATIVE: Test if kwargs are handled correctly"
-  (defmulti fun
+  "NATIVE: Test if kwargs are handled correctly for arity overloading"
+  (defn fun
     ([a] a)
     ([&optional [a "nop"] [b "p"]] (+ a b)))
    
@@ -48,8 +118,8 @@
 
 
 (defn test-docs []
-  "NATIVE: Test if docs are properly handled"
-  (defmulti fun
+  "NATIVE: Test if docs are properly handled for arity overloading"
+  (defn fun
     "docs"
     ([a] (print a))
     ([a b] (print b)))