Skip to content

Instantly share code, notes, and snippets.

Created November 22, 2014 20:55
Show Gist options
  • Save jneen/f9f6ca49bdf8efc39ec2 to your computer and use it in GitHub Desktop.
Save jneen/f9f6ca49bdf8efc39ec2 to your computer and use it in GitHub Desktop.
Multimethods with variants
; 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
Copy link

Do you think there's any problems with adding a little sugar for the pattern via macros? Here's a simple example (not accounting for all the things you need to support with defn style macros of course).

(defmacro defvariant [name]
  `(defmulti ~name first))

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

(defvariant foo)

(defcase foo :first
  [aseq] (first aseq))

(defcase foo :last
  [aseq] (last aseq))

(foo [:first [1 2 3]])
(foo [:last [1 2 3]])

Copy link

jneen commented Nov 23, 2014

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

Copy link

clojj commented Nov 28, 2014

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)])

Copy link

jneen commented Nov 28, 2014

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.

Copy link

clojj commented Nov 28, 2014

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

Copy link


Minor glitch on, a missing ~@ before body.

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

Copy link

jneen commented Nov 30, 2014

oh thanks @geraldodev

Copy link

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


(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.

Copy link

arrdem commented Jan 30, 2015

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
           [~kw-tag (hash-map ~@(interleave kw-members members))])

(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)
      => (deftag a [a b c])
      => (foo (a 1 2 3))
      ;; No Such Method exception
      => (foo? (a 1 2 3))
  (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)

(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])
      => (defvariant aable)
      => (extend-variant aable a [{:a a-val}] (inc a-val))
      => (aable? (a 1))
      => (aable (a 1))
  [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)

  (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

Copy link

clojj commented Feb 17, 2015

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

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment