impls/lib/protocols.mal

   1 ;; A sketch of Clojure-like protocols, implemented in Mal
   2
   3 ;; By chouser (Chris Houser)
   4 ;; Original: https://gist.github.com/Chouser/6081ea66d144d13e56fc
   5
   6 ;; This function maps a MAL value to a keyword representing its type.
   7 ;; Most applications will override the default with an explicit value
   8 ;; for the `:type` key in the metadata.
   9 (def! find-type (fn* [obj]
  10   (cond
  11     (symbol?  obj) :mal/symbol
  12     (keyword? obj) :mal/keyword
  13     (atom?    obj) :mal/atom
  14     (nil?     obj) :mal/nil
  15     (true?    obj) :mal/boolean
  16     (false?   obj) :mal/boolean
  17     (number?  obj) :mal/number
  18     (string?  obj) :mal/string
  19     (macro?   obj) :mal/macro
  20     true
  21     (let* [metadata (meta obj)
  22            type     (if (map? metadata) (get metadata :type))]
  23       (cond
  24         (keyword? type) type
  25         (list?   obj)   :mal/list
  26         (vector? obj)   :mal/vector
  27         (map?    obj)   :mal/map
  28         (fn?     obj)   :mal/function
  29         true            (throw "unknown MAL value in protocols"))))))
  30
  31 ;; A protocol (abstract class, interface..) is represented by a symbol.
  32 ;; It describes methods (abstract functions, contracts, signals..).
  33 ;; Each method is described by a sequence of two elements.
  34 ;; First, a symbol setting the name of the method.
  35 ;; Second, a vector setting its formal parameters.
  36 ;; The first parameter is required, plays a special role.
  37 ;; It is usually named `this` (`self`..).
  38 ;; For example,
  39 ;;   (defprotocol protocol
  40 ;;     (method1 [this])
  41 ;;     (method2 [this argument]))
  42 ;; can be thought as:
  43 ;;   (def! method1 (fn* [this]) ..)
  44 ;;   (def! method2 (fn* [this argument]) ..)
  45 ;;   (def! protocol ..)
  46 ;; The return value is the new protocol.
  47 (defmacro! defprotocol (fn* [proto-name & methods]
  48   ;; A protocol is an atom mapping a type extending the protocol to
  49   ;; another map from method names as keywords to implementations.
  50   (let* [
  51     drop2 (fn* [args]
  52       (if (= 2 (count args))
  53         ()
  54         (cons (first args) (drop2 (rest args)))))
  55     rewrite (fn* [method]
  56       (let* [
  57         name     (first method)
  58         args     (nth method 1)
  59         argc     (count args)
  60         varargs? (if (<= 2 argc) (= '& (nth args (- argc 2))))
  61         dispatch `(get (get @~proto-name
  62                             (find-type ~(first args)))
  63                        ~(keyword (str name)))
  64         body     (if varargs?
  65                    `(apply ~dispatch ~@(drop2 args) ~(nth args (- argc 1)))
  66                    (cons dispatch args))
  67         ]
  68         (list 'def! name (list 'fn* args body))))
  69     ]
  70     `(do
  71       ~@(map rewrite methods)
  72        (def! ~proto-name (atom {}))))))
  73
  74 ;; A type (concrete class..) extends (is a subclass of, implements..)
  75 ;; a protocol when it provides implementations for the required methods.
  76 ;;   (extend type protocol {
  77 ;;     :method1 (fn* [this] ..)
  78 ;;     :method2 (fn* [this arg1 arg2])})
  79 ;; Additionnal protocol/methods pairs are equivalent to successive
  80 ;; calls with the same type.
  81 ;; The return value is `nil`.
  82 (def! extend (fn* [type proto methods & more]
  83   (do
  84     (swap! proto assoc type methods)
  85     (if (first more)
  86       (apply extend type more)))))
  87
  88 ;; An object satisfies a protocol when its type extends the protocol,
  89 ;; that is if the required methods can be applied to the object.
  90 (def! satisfies? (fn* [protocol obj]
  91   (contains? @protocol (find-type obj))))
  92 ;; If `(satisfies protocol obj)` with the protocol below
  93 ;; then `(method1 obj)` and `(method2 obj 1 2)`
  94 ;; dispatch to the concrete implementation provided by the exact type.
  95 ;; Should the type evolve, the calling code needs not change.