Advertisement
Guest User

Untitled

a guest
Dec 3rd, 2015
110
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. (defmacro ^:private def-super-record
  2.   "Defines an abstract super record that can be extended by extend-record. Also defines a protocol with the same name
  3.  except suffixed with 'able'. The protocol contains accessor functions for each field, named by the field name prefixed
  4.  with 'get-'."
  5.   [name fields]
  6.   (let [protocol-name (symbol (str name "able"))]
  7.     `(do
  8.        (def ~name '~fields)
  9.        (defprotocol ~protocol-name
  10.          ~@(for [field fields
  11.                  :let [field-accessor (symbol (str "get-" field))]]
  12.              `(~field-accessor [~'this]))))))
  13.  
  14. (defmacro ^:private extend-record
  15.   "Extends a super record (by inheriting its fields and implementing its protocol). Fields in the super record may be
  16.  accessed by a call to get-fieldname to avoid switching on the record's type."
  17.   [name parents fields & remainder]
  18.   (let [parent-vars (map resolve parents)]
  19.     `(defrecord
  20.        ~name
  21.        ~(into [] (concat (flatten (map deref parent-vars)) fields))
  22.        ~@(apply concat
  23.                 (for [parent parents
  24.                       :let [parent-protocol (symbol (str parent "able"))]]
  25.                   `(~parent-protocol
  26.                      ~@(for [field @(resolve parent)
  27.                              :let [field-accessor (symbol (str "get-" field))]]
  28.                          `(~field-accessor [~'this] ~field)))))
  29.        ~@remainder)))
  30. => #'user/def-super-record
  31. => #'user/extend-record
  32.  
  33. (def-super-record SuperRecord [super-field])
  34. => SuperRecordable
  35.  
  36. (extend-record SubRecord [SuperRecord] [sub-field])
  37. => user.SubRecord
  38.  
  39. (def test-subrecord (->SubRecord 0 1))
  40. => #'user/test-subrecord
  41.  
  42. (when (satisfies? SuperRecordable test-subrecord) (get-super-field test-subrecord))
  43. => 0
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement