Merge pull request #532 from dubek/vhdl-fix-defmacro

[jackhill/mal.git] / impls / lib / protocols.mal

;; A sketch of Clojure-like protocols, implemented in Mal

;; By chouser (Chris Houser)
;; Original: https://gist.github.com/Chouser/6081ea66d144d13e56fc

;; This function maps a MAL value to a keyword representing its type.
;; Most applications will override the default with an explicit value
;; for the `:type` key in the metadata.
(def! find-type (fn* [obj]
  (cond
    (symbol?  obj) :mal/symbol
    (keyword? obj) :mal/keyword
    (atom?    obj) :mal/atom
    (nil?     obj) :mal/nil
    (true?    obj) :mal/boolean
    (false?   obj) :mal/boolean
    (number?  obj) :mal/number
    (string?  obj) :mal/string
    (macro?   obj) :mal/macro
    true
    (let* [metadata (meta obj)
           type     (if (map? metadata) (get metadata :type))]
      (cond
        (keyword? type) type
        (list?   obj)   :mal/list
        (vector? obj)   :mal/vector
        (map?    obj)   :mal/map
        (fn?     obj)   :mal/function
        true            (throw "unknown MAL value in protocols"))))))

;; A protocol (abstract class, interface..) is represented by a symbol.
;; It describes methods (abstract functions, contracts, signals..).
;; Each method is described by a sequence of two elements.
;; First, a symbol setting the name of the method.
;; Second, a vector setting its formal parameters.
;; The first parameter is required, plays a special role.
;; It is usually named `this` (`self`..).
;; For example,
;;   (defprotocol protocol
;;     (method1 [this])
;;     (method2 [this argument]))
;; can be thought as:
;;   (def! method1 (fn* [this]) ..)
;;   (def! method2 (fn* [this argument]) ..)
;;   (def! protocol ..)
;; The return value is the new protocol.
(defmacro! defprotocol (fn* [proto-name & methods]
  ;; A protocol is an atom mapping a type extending the protocol to
  ;; another map from method names as keywords to implementations.
  (let* [
    drop2 (fn* [args]
      (if (= 2 (count args))
        ()
        (cons (first args) (drop2 (rest args)))))
    rewrite (fn* [method]
      (let* [
        name     (first method)
        args     (nth method 1)
        argc     (count args)
        varargs? (if (<= 2 argc) (= '& (nth args (- argc 2))))
        dispatch `(get (get @~proto-name
                            (find-type ~(first args)))
                       ~(keyword (str name)))
        body     (if varargs?
                   `(apply ~dispatch ~@(drop2 args) ~(nth args (- argc 1)))
                   (cons dispatch args))
        ]
        (list 'def! name (list 'fn* args body))))
    ]
    `(do
      ~@(map rewrite methods)
       (def! ~proto-name (atom {}))))))

;; A type (concrete class..) extends (is a subclass of, implements..)
;; a protocol when it provides implementations for the required methods.
;;   (extend type protocol {
;;     :method1 (fn* [this] ..)
;;     :method2 (fn* [this arg1 arg2])})
;; Additionnal protocol/methods pairs are equivalent to successive
;; calls with the same type.
;; The return value is `nil`.
(def! extend (fn* [type proto methods & more]
  (do
    (swap! proto assoc type methods)
    (if (first more)
      (apply extend type more)))))

;; An object satisfies a protocol when its type extends the protocol,
;; that is if the required methods can be applied to the object.
(def! satisfies? (fn* [protocol obj]
  (contains? @protocol (find-type obj))))
;; If `(satisfies protocol obj)` with the protocol below
;; then `(method1 obj)` and `(method2 obj 1 2)`
;; dispatch to the concrete implementation provided by the exact type.
;; Should the type evolve, the calling code needs not change.