diff --git a/docs/contrib/multi.rst b/docs/contrib/multi.rst index 5740557..2f703a7 100644 --- a/docs/contrib/multi.rst +++ b/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/ diff --git a/hy/contrib/multi.hy b/hy/contrib/multi.hy index 19246ee..f8216f6 100644 --- a/hy/contrib/multi.hy +++ b/hy/contrib/multi.hy @@ -1,5 +1,6 @@ ;; Hy Arity-overloading ;; Copyright (c) 2014 Morten Linderud +;; Copyright (c) 2016 Tuukka Turto ;; 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))))) diff --git a/tests/native_tests/contrib/multi.hy b/tests/native_tests/contrib/multi.hy index 51162b0..d9c2b62 100644 --- a/tests/native_tests/contrib/multi.hy +++ b/tests/native_tests/contrib/multi.hy @@ -1,4 +1,5 @@ ;; Copyright (c) 2014 Morten Linderud +;; Copyright (c) 2016 Tuukka Turto ;; 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)))