Multimethods with variants

variant-multimethods.clj

; it's a bit cumbersome to set up and there's the unfortunate need to ignore the tag
; in the individual methods, but this allows you to leave the interpretation of open 
; variants, well, *open* for extension by multimethod.

; dispatch off the first argument, which will be the tag
(defmethod command-multi (fn [tag & data] tag))

; the first argument to the *method* is still the tag
(defmulti command-multi :print [_ val] (println val))
(defmulti command-multi :read [_ fname] (slurp fname))

; partially applying `apply` so that the variant vectors
; get flattened - it's a bit odd but gets the job done
(def command (partial apply command-multi))

(command [:print "hello world"]) ; prints "hello world"
(command [:read "./project.clj"]) ; returns the contents of project.clj

Haha yeah! I did almost the same thing in Ambrose's gist: https://gist.github.com/frenchy64/c7e1a318c67baf7576c5. I like your naming better, but it is nice for the macro to provide something that kind of looks like core.match

or even more compact

(defmacro defvariants [name & cases]
  (cons 'do (cons `(defmulti ~name first)
                  (for [[tag args & body] cases]
                    `(defmethod ~name ~tag [[_# ~@args]] ~@body)))))

(defvariants cmds
              [:print [val] (println "print " val)]
              [:read [fname] (println "slurping...") (slurp fname)])

hm, that is more compact - but the point of using multimethods is that the implementations can appear in other parts of the source, or be implemented by other people.

yes, right.. I realized that after my comment

I guess this could be combined with an additional defcase-like macro,
so it will be extensional as well.
And then, that defcase-like macro could take a seq of cases in turn, in addition to a 1 case arity..

hm.. maybe this all could be the same macro defvariants, if it can check for an existing defmulti.. creating one if not existing or extending an existing one.

I will try that

@jneen

Minor glitch on http://www.jneen.net/posts/2014-11-23-clojure-conj-variants-errata, a missing ~@ before body.

(defmacro defcase [name [tag & binders] body]
  `(defmethod ~name ~tag [[_# ~@binders]] ~@body))

oh thanks @geraldodev

jneen, sorry I'm a macro newbie.
body do not compile
~@Body compiles and I infered it was right but it eats ()
What worked was ~body

Proof

(defmacro defcase [name [tag & binders] body]
  `(defmethod ~name ~tag [[_# ~@binders]] ~body))

(macroexpand '(defcase teste [:nome parametro] (do parametro)))

Sorry again.

Very good presentation of yours btw.

Here's a somewhat hardened version of the above I just hacked together...

(ns variants)

(defn take-when
  "Helper useful for parsing regular function argument seqeunces. If a predicate
  is satisfied, returns a pair [(first col), (rest col)] otherwise returns the pair
  [empty, col].

  Ex. (let [[?docstring args] (take-when string? \"\" args)
            [?attr-map  args] (take-when map? {} args)]
        ..)"
  [f empty col]
  (let [[x & rest] col]
    (if (f x) [x rest] [empty col])))

(defmacro deftag
  "Defines a tagged value constructor with a namespace qualified keyword tag,
  and a body map with keyword named members. Preconditions on members may be
  specified by the pre-map as for clojure.core/defn.

  Ex. (deftag test \"A demo variant tag\" [a b]
        {:pre [(number? a) (vector? b)]})"
  {:arglists '([name doc-string? attr-map? members pre-map?])}
  [vname & args]
  (let [;; Parse direct args
        [?docstring args] (take-when string? "" args)
        [?attr-map args]  (take-when map? {} args)
        [members args]    (take-when vector? nil args)
        [?pre-map args]   (take-when map? {} args)

        ;; FIXME inline guards are a bad habit of mine
        _                 (assert (vector? members) "Members is not a vector!")
        _                 (assert (every? symbol? members) "Members may contain only symbols!")

        ;; Build used datastructures
        kw-members        (mapv (comp keyword name) members)
        kw-tag            (keyword (name (ns-name *ns*))
                                   (name vname))
        ?attr-map         (assoc ?attr-map
                                 :variants/tag true
                                 :tag/members  kw-members
                                 :tag/tag      kw-tag)]
    `(do (defn ~vname ~?docstring ~?attr-map ~members
           ~?pre-map
           [~kw-tag (hash-map ~@(interleave kw-members members))])
         nil)))

(defmacro defvariant
  "Defines a function over an open variant and a predicate returning true if the
  function is implemented for a given tagged value.

  Ex. => (defvariant foo)
      nil
      => (deftag a [a b c])
      nil
      => (foo (a 1 2 3))
      ;; No Such Method exception
      => (foo? (a 1 2 3))
      false"
  [variant-name]
  (let [pred-name    (symbol (str (name variant-name) "?"))
        default-case (keyword (name (gensym)))]
    `(do (defmulti ~pred-name first
           :default ~default-case)
         (defmulti ~variant-name first)
         (alter-meta! (var ~variant-name)
                      merge {:variants/variant true
                             :variant/predicate (quote ~(symbol (name (ns-name *ns*))
                                                                (name pred-name)))})
         (defmethod ~pred-name ~default-case [& _#] false)
         nil)))

(defmacro extend-variant
  "Extends a previously defined variant adding a new tag dispatched method to
  its body and extending its predicate to indicate that the tag for which
  support was just added is an element of the set of tags for which there are
  dispatch values.

  Ex. => (deftag a [a])
      nil
      => (defvariant aable)
      nil
      => (extend-variant aable a [{:a a-val}] (inc a-val))
      nil
      => (aable? (a 1))
      true
      => (aable (a 1))
      2"
  [name tag args & body]
  (let [variant-var  (resolve name)
        variant-meta (meta variant-var)
        _            (assert (get variant-meta :variants/variant) "Tried to extend a non-variant!")
        variant-pred (:variant/predicate variant-meta)
        _            (assert variant-pred "Tried to extend a variant with no predicate!")
        _            (resolve variant-pred)
        tag-var      (resolve tag)
        tag-meta     (meta tag-var)
        _            (assert (:variants/tag tag-meta) "Tried to extend a variant on an unknown var!")
        tag-keyword  (:tag/tag tag-meta)
        _            (assert (keyword? tag-keyword) "Could not resolve the keyword for the given tag!")]
    `(do (defmethod ~name         ~tag-keyword [[_# ~@args]] ~@body)
         (defmethod ~variant-pred ~tag-keyword [& _#] true)
         nil)))

(comment
  (do (deftag foo [a])
      (deftag qux [b])
      (defvariant f-of-foo)
      (extend-variant f-of-foo foo [{:a a}] (println a))
      (f-of-foo? (foo 1)) ;; -> true
      (f-of-foo  (foo 1)) ;; prints 1
      (f-of-foo? (bar 1)) ;; -> false
      ))

any inspirations about leveraging clojure hierarchies for these variants ...?
see here:

• https://clojuredocs.org/clojure.core/make-hierarchy
• https://clojuredocs.org/clojure.core/derive
• http://www.clojureatlas.com/org.clojure:clojure:1.4.0?guest=t#concept/hierarchies

So that :foo-hound isa ::foo-species
...and 'species-commands' get evaluated as well ...?