|
| 1 | +(ns ^{:doc "A re-implementation of `active.clojure.record` that makes use of |
| 2 | +Clojure's new spec library. Define records the same ways as in the old |
| 3 | +implemenation or use the new syntax to automatically generate specs. |
| 4 | +If a field has no explicit spec, defaults to `any?`."} |
| 5 | + active.clojure.record-spec |
| 6 | + (:require [clojure.spec.alpha :as s] |
| 7 | + [active.clojure.condition :as c] |
| 8 | + [clojure.spec.gen.alpha :as gen])) |
| 9 | + |
| 10 | +;; Only needed in ClojureScript, does nothing in Clojure |
| 11 | +(defn check-type |
| 12 | + [type rec accessor] |
| 13 | + #?(:clj (do)) |
| 14 | + #?(:cljs |
| 15 | + (when-not (instance? type rec) |
| 16 | + (throw (js/Error. (str "Wrong record type passed to accessor." rec type)))))) |
| 17 | + |
| 18 | + |
| 19 | +(defn specs-vec |
| 20 | + [spec &form] |
| 21 | + (if (even? (count spec)) |
| 22 | + (throw (IllegalArgumentException. (str "invalid field spec " spec " in " *ns* " " (meta &form)))) |
| 23 | + (let [[field accessor & mods] spec |
| 24 | + mod-m (into {} (map vec (partition 2 mods)))] |
| 25 | + [field accessor (if-let [spec (:spec (meta field))] |
| 26 | + (assoc mod-m :spec spec) |
| 27 | + (assoc mod-m :spec any?))]))) |
| 28 | + |
| 29 | + |
| 30 | +(defn field-triples |
| 31 | + "Takes a vector of specs and the `&form` variable and returns a vector of triples. |
| 32 | + The specs are in one of two forms: |
| 33 | + - a list, containing the field name (symbol), the accessor's name (symobl) and |
| 34 | + optionally a key (`:spec|:lens`) followed by either the spec or the lens' |
| 35 | + name |
| 36 | + - two consecutive symbols (the field name (symbol) and the accessor's name |
| 37 | + (symbol). |
| 38 | + The `&form` is only used for reporting errors." |
| 39 | + [specs &form] |
| 40 | + (loop [specs (seq specs) |
| 41 | + triples []] |
| 42 | + (if (empty? specs) |
| 43 | + triples |
| 44 | + (let [spec (first specs)] |
| 45 | + (cond |
| 46 | + (list? spec) |
| 47 | + (recur (rest specs) (conj triples (specs-vec spec &form))) |
| 48 | + |
| 49 | + (symbol? spec) |
| 50 | + (do |
| 51 | + (when (empty? (rest specs)) |
| 52 | + (throw (IllegalArgumentException. (str "incomplete field spec for " spec " in " *ns* " " (meta &form))))) |
| 53 | + (when-not (symbol? (fnext specs)) |
| 54 | + (throw (IllegalArgumentException. (str "invalid accessor " (fnext specs) " for " spec " in " *ns* " " (meta &form))))) |
| 55 | + (println "spec:" (:spec (meta (fnext specs)))) |
| 56 | + (recur (nnext specs) |
| 57 | + (conj triples [spec (fnext specs) {:spec (or (:spec (meta spec)) any?)}]))) |
| 58 | + :else |
| 59 | + (throw (IllegalArgumentException. (str "invalid field spec " spec " in " *ns* " " (meta &form))))))))) |
| 60 | + |
| 61 | + |
| 62 | +(defn ns-keyword |
| 63 | + "Takes a symbol or string `the-name-sym` and returns a namespaces keyword |
| 64 | + based on that symbol. |
| 65 | +
|
| 66 | + Example: `(ns-keyword 'foo) => :calling.name.space/foo`" |
| 67 | + [the-name-sym] |
| 68 | + (if the-name-sym |
| 69 | + (keyword (str (ns-name *ns*)) (str the-name-sym)) |
| 70 | + (c/assertion-violation `ns-keyword "argument must not be nil" the-name-sym))) |
| 71 | + |
| 72 | + |
| 73 | +(defn define-spec-form |
| 74 | + "Takes the name of a type and a predicate and returns the form for defining |
| 75 | + the spec for this name using the predicate. |
| 76 | +
|
| 77 | + Example: |
| 78 | +
|
| 79 | + ``` |
| 80 | + (define-spec-form 'foo bar?) |
| 81 | + => (clojure.spec.alpha/def :calling.name.space/foo bar?) |
| 82 | + ```" |
| 83 | + [the-name the-predicate] |
| 84 | + (println "define-spec-form" the-name the-predicate) |
| 85 | + (let [ns-key (ns-keyword the-name)] |
| 86 | + `(s/def ~ns-key ~the-predicate))) |
| 87 | + |
| 88 | + |
| 89 | +(defn define-type-spec-form |
| 90 | + "Takes a symbol `the-name` and a seq of symbols `the-keys` and returns a spec |
| 91 | + form based on those values. |
| 92 | +
|
| 93 | + Example: |
| 94 | + ``` |
| 95 | + (define-type-spec-form 'foo ['bar 'baz]) |
| 96 | + => (clojure.spec.alpha/def :calling.name.space/foo |
| 97 | + (s/and |
| 98 | + predicate |
| 99 | + (clojure.spec.alpha/keys :req-un |
| 100 | + [:calling.name.space/bar |
| 101 | + :calling.name.space/baz]))) |
| 102 | + ```" |
| 103 | + [the-name constructor predicate the-keys] |
| 104 | + (let [ns-key (ns-keyword the-name) |
| 105 | + ks (mapv ns-keyword the-keys)] |
| 106 | + `(s/def ~ns-key |
| 107 | + (s/spec (s/and ~predicate (s/keys :req-un ~ks)) |
| 108 | + :gen (fn [] |
| 109 | + (->> (s/gen (s/keys :req-un ~ks)) |
| 110 | + (gen/fmap (fn [ks#] (apply ~constructor |
| 111 | + (vals ks#)))))))))) |
| 112 | + |
| 113 | + |
| 114 | +(defn define-constructor-spec-form |
| 115 | + "Takes the name of a constructor `the-name`, a seq of arguments and a list of |
| 116 | + specs and returns a spec-form for the constructor. |
| 117 | +
|
| 118 | + Example: |
| 119 | + ``` |
| 120 | + (define-constructor-spec-form 'make-foo 'foo ['bar 'baz] ['foo-bar 'foo-baz]) |
| 121 | + => (clojure.spec.alpha/fdef make-foo |
| 122 | + :args (clojure.spec.alpha/cat :bar ::foo-bar :baz ::foo-baz) |
| 123 | + :ret ::foo) |
| 124 | + ```" |
| 125 | + [the-name the-ret-type the-args-list the-specs-list] |
| 126 | + (let [key-args-list (map keyword the-args-list) |
| 127 | + ns-spec-list (map ns-keyword the-specs-list) |
| 128 | + the-args-entry (apply concat (map (fn [l r] [l r]) key-args-list ns-spec-list))] |
| 129 | + `(s/fdef ~the-name |
| 130 | + :args (s/cat ~@the-args-entry) |
| 131 | + :ret ~(ns-keyword the-ret-type)))) |
| 132 | + |
| 133 | + |
| 134 | +(defn define-accessor-spec-form |
| 135 | + "Takes the name of a constructor `the-name`, a seq of arguments and a list of |
| 136 | + specs and returns a spec-form for the constructor. |
| 137 | +
|
| 138 | + Example: |
| 139 | + ``` |
| 140 | + (define-accessor-spec-form 'make-foo ['bar 'baz] ['foo-bar 'foo-baz]) |
| 141 | + => (clojure.spec.alpha/fdef make-foo |
| 142 | + :args (clojure.spec.alpha/cat :bar ::foo-bar :baz ::foo-baz) |
| 143 | + :ret ::foo) |
| 144 | + ```" |
| 145 | + [the-accessor-name the-type-name] |
| 146 | + `(s/fdef ~the-accessor-name |
| 147 | + :args (s/cat ~(keyword the-type-name) ~(ns-keyword the-type-name)) |
| 148 | + :res ~boolean?)) |
| 149 | + |
| 150 | + |
| 151 | +#?(:clj |
| 152 | +(defmacro define-record-type |
| 153 | + "Attach doc properties to the type and the field names to get reasonable docstrings." |
| 154 | + [?type ?constructor-call ?predicate ?field-specs & ?opt+specs] |
| 155 | + (when-not (and (list? ?constructor-call) |
| 156 | + (not (empty? ?constructor-call))) |
| 157 | + (throw (IllegalArgumentException. (str "constructor call must be a list in " *ns* " " (meta &form))))) |
| 158 | + (when-not (vector? ?field-specs) |
| 159 | + (throw (IllegalArgumentException. (str "field specs must be a vector in " *ns* " " (meta &form))))) |
| 160 | + (when-not (even? (count (remove seq? ?field-specs))) |
| 161 | + (throw (IllegalArgumentException. (str "odd number of elements in field specs in " *ns* " " (meta &form))))) |
| 162 | + (when-not (every? true? (map #(= 3 (count %)) (filter seq? ?field-specs))) |
| 163 | + (do |
| 164 | + (println (every? true? (map #(= 3 (count %)) (filter seq? ?field-specs)))) |
| 165 | + (throw (IllegalArgumentException. (str "wrong number of elements in field specs with lens in " *ns* " " (meta &form)))))) |
| 166 | + |
| 167 | + (let [?field-triples (field-triples ?field-specs &form) |
| 168 | + ?constructor (first ?constructor-call) |
| 169 | + ?constructor-args (rest ?constructor-call) |
| 170 | + ?constructor-args-set (set ?constructor-args) |
| 171 | + document (fn [n doc] |
| 172 | + (vary-meta n |
| 173 | + (fn [m] |
| 174 | + (if (contains? m :doc) |
| 175 | + m |
| 176 | + (assoc m :doc doc))))) |
| 177 | + document-with-arglist (fn [n arglist doc] |
| 178 | + (vary-meta n |
| 179 | + (fn [m] |
| 180 | + (let [m (if (contains? m :doc) |
| 181 | + m |
| 182 | + (assoc m :doc doc))] |
| 183 | + (if (contains? m :arglists) |
| 184 | + m |
| 185 | + (assoc m :arglists `'(~arglist))))))) |
| 186 | + name-doc (fn [field] |
| 187 | + (if-let [doc (:doc (meta field))] |
| 188 | + (str " (" doc ")") |
| 189 | + "")) |
| 190 | + |
| 191 | + ?field-names (map first ?field-triples) |
| 192 | + reference (fn [name] |
| 193 | + (str "[[" (ns-name *ns*) "/" name "]]")) |
| 194 | + ?docref (str "See " (reference ?constructor) ".")] |
| 195 | + (let [?field-names-set (set ?field-names)] |
| 196 | + (doseq [?constructor-arg ?constructor-args] |
| 197 | + (when-not (contains? ?field-names-set ?constructor-arg) |
| 198 | + (throw (IllegalArgumentException. (str "constructor argument " ?constructor-arg " is not a field in " *ns* " " (meta &form))))))) |
| 199 | + |
| 200 | + |
| 201 | + `(do |
| 202 | + (defrecord ~?type |
| 203 | + [~@(map #(->> % first (str ?type "-") symbol) ?field-triples)] |
| 204 | + ~@?opt+specs) |
| 205 | + (def ~(document-with-arglist ?predicate '[thing] (str "Is object a `" ?type "` record? " ?docref)) |
| 206 | + (fn [x#] |
| 207 | + (instance? ~?type x#))) |
| 208 | + (def ~(document-with-arglist ?constructor |
| 209 | + (vec ?constructor-args) |
| 210 | + (str "Construct a `" ?type "`" |
| 211 | + (name-doc ?type) |
| 212 | + " record.\n" |
| 213 | + (apply str |
| 214 | + (map (fn [[?field ?accessor ?lens+spec]] |
| 215 | + (str "\n`" ?field "`" (name-doc ?field) ": access via " (reference ?accessor) |
| 216 | + (if (:lens ?lens+spec) |
| 217 | + (str ", lens " (reference (:lens ?lens+spec))) |
| 218 | + ""))) |
| 219 | + ?field-triples)))) |
| 220 | + (fn [~@?constructor-args] |
| 221 | + (new ~?type |
| 222 | + ~@(map (fn [[?field _]] |
| 223 | + (if (contains? ?constructor-args-set ?field) |
| 224 | + `~?field |
| 225 | + `nil)) |
| 226 | + ?field-triples)))) |
| 227 | + (declare ~@(map (fn [[?field ?accessor ?lens+spec]] ?accessor) ?field-triples)) |
| 228 | + ~@(mapcat (fn [[?field ?accessor ?lens+spec]] |
| 229 | + (let [?rec (with-meta `rec# {:tag ?type})] |
| 230 | + `((def ~(document-with-arglist ?accessor (vector ?type) (str "Access `" ?field "` field" |
| 231 | + (name-doc ?field) |
| 232 | + " from a [[" ?type "]] record. " ?docref)) |
| 233 | + (fn [~?rec] |
| 234 | + (check-type ~?type ~?rec ~?accessor) |
| 235 | + (. ~?rec ~(symbol (str ?type "-" ?field))))) |
| 236 | + ~@(when-let [?lens (:lens ?lens+spec)] |
| 237 | + (let [?data `data# |
| 238 | + ?v `v#] |
| 239 | + `((def ~(document ?lens (str "Lens for the `" ?field "` field" |
| 240 | + (name-doc ?field) |
| 241 | + " from a [[" ?type "]] record." ?docref)) |
| 242 | + (active.clojure.lens/lens ~?accessor |
| 243 | + (fn [~?data ~?v] |
| 244 | + (~?constructor ~@(map |
| 245 | + (fn [[?shove-field ?shove-accessor]] |
| 246 | + (if (= ?field ?shove-field) |
| 247 | + ?v |
| 248 | + `(~?shove-accessor ~?data))) |
| 249 | + ?field-triples)))))))) |
| 250 | + ~@(when-let [?spec (:spec ?lens+spec)])))) |
| 251 | + ?field-triples) |
| 252 | + ;; type-spec |
| 253 | + ~(define-type-spec-form ?type ?constructor ?predicate (map second (filter (fn [[_ _ l+s]] (:spec l+s)) ?field-triples))) |
| 254 | + ~(define-constructor-spec-form (first ?constructor-call) ?type (map first ?field-triples) (map second ?field-triples)) |
| 255 | + ;; field-specs |
| 256 | + ~@(for [[_field ?accessor ?lens+spec] ?field-triples :when (:spec ?lens+spec)] |
| 257 | + (define-spec-form ?accessor (:spec ?lens+spec))) |
| 258 | + ~@(for [[_field ?accessor ?lens+spec] ?field-triples :when (:spec ?lens+spec)] |
| 259 | + (define-accessor-spec-form ?accessor ?type)))))) |
0 commit comments