Skip to content

Commit

Permalink
Reimplement macros using spec conform and unform
Browse files Browse the repository at this point in the history 
Fixes #2, fixes #3, fixes #8, fixes #10.
  • Loading branch information
@angusiguess @danielcompton
angusiguess authored and danielcompton committed May 9, 2020
1 parent 99537a4 commit 51af322
Show file tree
Hide file tree
Showing 4 changed files with 394 additions and 233 deletions.
52 changes: 22 additions & 30 deletions src/net/danielcompton/defn_spec_alpha.clj
View file
@@ -1,6 +1,7 @@
(ns net.danielcompton.defn-spec-alpha
(:refer-clojure :exclude [defn])
(:require [clojure.spec.alpha :as s]
[net.danielcompton.defn-spec-alpha.spec :as spec]
[net.danielcompton.defn-spec-alpha.macros :as macros]))

(defmacro defn
Expand Down Expand Up @@ -29,33 +30,24 @@
- & {} is not supported.
- Unlike clojure.core/defn, a final attr-map on multi-arity functions
is not supported."
{:arglists '([name ret-spec? doc-string? attr-map? [params*] prepost-map? body])}
[& defn-args]
(let [[name & more-defn-args] (macros/normalized-defn-args &env defn-args)
{:keys [doc tag] :as standard-meta} (meta name)
{:keys [outer-bindings schema-form fn-body arglists raw-arglists
processed-arities]} (macros/process-fn- &env name more-defn-args)]
`(let ~outer-bindings
(let [ret# (clojure.core/defn ~(with-meta name {})
~(assoc (apply dissoc standard-meta (when (macros/primitive-sym? tag) [:tag]))
:doc (str
(str "Inputs: " (if (= 1 (count raw-arglists))
(first raw-arglists)
(apply list raw-arglists)))
(when-let [ret (when (= (second defn-args) :-) (nth defn-args 2))]
(str "\n Returns: " ret))
(when doc (str "\n\n " doc)))
:raw-arglists (list 'quote raw-arglists)
:arglists (list 'quote arglists)
;; TODO: remove this
:spec schema-form)
~@fn-body)]
;; Only define an fdef if there are specs for the args or return value.
(when (or ~(:spec? (meta name))
~(some true? (map #(:spec? (meta %)) (first arglists))))
(s/fdef ~(with-meta name {})
:ret ~(:spec (meta name))
:args (s/cat ~@(mapcat
#(list (keyword %) (:spec (meta %)))
(first arglists)))))
ret#))))
[& args]
(let [ast (s/conform ::spec/annotated-defn-args args)
defn-form (->> ast
(spec/annotated-defn->defn)
(s/unform ::spec/defn-args))
arg-spec (macros/combine-arg-specs ast)
ret-spec (get-in ast [:ret-annotation :spec])
fn-name (:fn-name ast)]
`(do
(clojure.core/defn ~@defn-form)
~(cond (and arg-spec ret-spec)
`(clojure.spec.alpha/fdef ~fn-name
:args ~arg-spec
:ret ~ret-spec)
arg-spec
`(clojure.spec.alpha/fdef ~fn-name
:args ~arg-spec)
ret-spec
`(clojure.spec.alpha/fdef ~fn-name
:ret ~ret-spec)
:else nil))))
234 changes: 86 additions & 148 deletions src/net/danielcompton/defn_spec_alpha/macros.clj
View file
Expand Up @@ -105,155 +105,93 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Helpers for schematized fn/defn

(defn split-rest-arg [env bind]
(let [[pre-& [_ rest-arg :as post-&]] (split-with #(not= % '&) bind)]
(if (seq post-&)
(do (assert! (= (count post-&) 2) "& must be followed by a single binding" (vec post-&))
(assert! (or (symbol? rest-arg)
(and (vector? rest-arg)
(not-any? #{'&} rest-arg)))
"Bad & binding form: currently only bare symbols and vectors supported" (vec post-&))

[(vec pre-&)
(if (vector? rest-arg)
(with-meta (process-arrow-schematized-args env rest-arg) (meta rest-arg))
rest-arg)])
[bind nil])))

(defn single-arg-schema-form [rest? [index arg]]
`(~(if rest? `schema.core/optional `schema.core/one)
~(extract-schema-form arg)
~(if (symbol? arg)
`'~arg
`'~(symbol (str (if rest? "rest" "arg") index)))))

(defn simple-arglist-schema-form [rest? regular-args]
(mapv (partial single-arg-schema-form rest?) (map-indexed vector regular-args)))

(defn rest-arg-schema-form [arg]
(let [s (extract-schema-form arg)]
(if (= s `schema.core/Any)
(if (vector? arg)
(simple-arglist-schema-form true arg)
[`schema.core/Any])
(do (assert! (vector? s) "Expected seq schema for rest args, got %s" s)
s))))

(defn input-schema-form [regular-args rest-arg]
(let [base (simple-arglist-schema-form false regular-args)]
(if rest-arg
(vec (concat base (rest-arg-schema-form rest-arg)))
base)))

(defn apply-prepost-conditions
"Replicate pre/postcondition logic from clojure.core/fn."
[body]
(let [[conds body] (maybe-split-first #(and (map? %) (next body)) body)]
(concat (map (fn [c] `(assert ~c)) (:pre conds))
(if-let [post (:post conds)]
`((let [~'% (do ~@body)]
~@(map (fn [c] `(assert ~c)) post)
~'%))
body))))

(def ^:dynamic *compile-fn-validation* (atom true))

(defn compile-fn-validation?
"Returns true if validation should be included at compile time, otherwise false.
Validation is elided for any of the following cases:
* function has :never-validate metadata
* *compile-fn-validation* is false
* *assert* is false AND function is not :always-validate"
[env fn-name]
(let [fn-meta (meta fn-name)]
(and
@*compile-fn-validation*
(not (:never-validate fn-meta))
(or (:always-validate fn-meta)
*assert*))))

(defn process-fn-arity
"Process a single (bind & body) form, producing an output tag, schema-form,
and arity-form which has asserts for validation purposes added that are
executed when turned on, and have very low overhead otherwise.
tag? is a prospective tag for the fn symbol based on the output schema.
schema-bindings are bindings to lift eval outwards, so we don't build the schema
every time we do the validation."
[env fn-name output-schema-sym bind-meta [bind & body]]
(assert! (vector? bind) "Got non-vector binding form %s" bind)
(when-let [bad-meta (seq (filter (or (meta bind) {}) [:tag :s? :s :spec]))]
(throw (RuntimeException. (str "Meta not supported on bindings, put on fn name" (vec bad-meta)))))
(let [original-arglist bind
;; this returns symbols with metadata on them
bind (with-meta (process-arrow-schematized-args env bind) bind-meta)
[regular-args rest-arg] (split-rest-arg env bind)
input-schema-sym (gensym "input-schema")
input-checker-sym (gensym "input-checker")
output-checker-sym (gensym "output-checker")
compile-validation (compile-fn-validation? env fn-name)]
{:schema-binding [input-schema-sym (input-schema-form regular-args rest-arg)]
:more-bindings (when compile-validation
[input-checker-sym `(delay (schema.core/checker ~input-schema-sym))
output-checker-sym `(delay (schema.core/checker ~output-schema-sym))])
:arglist bind
:raw-arglist original-arglist
:arity-form (if compile-validation
(let [bind-syms (vec (repeatedly (count regular-args) gensym))
rest-sym (when rest-arg (gensym "rest"))
metad-bind-syms (with-meta (mapv #(with-meta %1 (meta %2)) bind-syms bind) bind-meta)]
(list
(if rest-arg
(into metad-bind-syms ['& rest-sym])
metad-bind-syms)
`(let [o# (loop ~(into (vec (interleave (map #(with-meta % {}) bind) bind-syms))
(when rest-arg [rest-arg rest-sym]))
~@(apply-prepost-conditions body))]
o#)))
(cons (into regular-args (when rest-arg ['& rest-arg]))
body))}))

(defn process-fn-
"Process the fn args into a final tag proposal, schema form, schema bindings, and fn form"
[env name fn-body]
(let [compile-validation (compile-fn-validation? env name)
output-schema (extract-schema-form name)
output-schema-sym (gensym "output-schema")
bind-meta (or (when-let [t (:tag (meta name))]
(when (primitive-sym? t)
{:tag t}))
{})
processed-arities (map (partial process-fn-arity env name output-schema-sym bind-meta)
(if (vector? (first fn-body))
[fn-body]
fn-body))
schema-bindings (map :schema-binding processed-arities)
fn-forms (map :arity-form processed-arities)]
{:outer-bindings (vec (concat
[output-schema-sym output-schema]
(apply concat schema-bindings)
(mapcat :more-bindings processed-arities)))
:arglists (map :arglist processed-arities)
:raw-arglists (map :raw-arglist processed-arities)
:schema-form (if (= 1 (count processed-arities))
`(schema.core/->FnSchema ~output-schema-sym ~[(ffirst schema-bindings)])
`(schema.core/make-fn-schema ~output-schema-sym ~(mapv first schema-bindings)))
:fn-body fn-forms
:processed-arities processed-arities}))
(defn nil->any? [spec]
(if (nil? spec) 'any?
spec))

(defn nils->any? [specs]
(map nil->any? specs))


(defn gen-argument-keys [args]
"Given a list of arguments obtained by conforming the ::annotated-defn-args spec,
generate a list of keywords to label the spec in s/cat. Because map destructures are
sometimes anonymous and seq destructures are always anonymous, we generate unique keys
to annote them and aid in legibility when functions are instrumented."
(let [keys-accumulator
(reduce (fn [acc [type params]]
(case type
:local-symbol (update acc :arg-keys conj (keyword (:local-name params)))
:map-destructure (-> acc
(update :arg-keys
conj
(keyword
(keyword (str "map-destructure-" (:map-destructure-count acc)))))
(update :map-destructure-count inc))
:seq-destructure (-> acc
(update :arg-keys
conj
(keyword (str "seq-destructure-" (:seq-destructure-count acc))))
(update :seq-destructure-count inc))))
{:map-destructure-count 1
:seq-destructure-count 1
:arg-keys []}
args)]
(:arg-keys keys-accumulator)))

(defn arity-labels []
(map (fn [x] (keyword (str "arity-" x))) (iterate inc 1)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Public: helpers for schematized functions

(defn normalized-defn-args
"Helper for defining defn-like macros with schemas. Env is &env
from the macro body. Reads optional docstring, return type and
attribute-map and normalizes them into the metadata of the name,
returning the normalized arglist. Based on
clojure.tools.macro/name-with-attributes."
[env macro-args]
(let [[name macro-args] (extract-arrow-schematized-element env macro-args)
[maybe-docstring macro-args] (maybe-split-first string? macro-args)
[maybe-attr-map macro-args] (maybe-split-first map? macro-args)]
(cons (vary-meta name merge
(or maybe-attr-map {})
(when maybe-docstring {:doc maybe-docstring}))
macro-args)))
(defn combine-arg-specs [{:keys [fn-tail]}]
;; In the event of arity-1, check if anything is specified at all. If not, return nil
;; If so, run through each form, generating either the annotation with label or the
;; label with any?
(case (first fn-tail)
:arity-1
(let [{:keys [args varargs]} (:params (last fn-tail))
arg-specs (into [] (map #(get-in (last %) [:annotation :spec])) args)
arg-names (gen-argument-keys args)
vararg-spec (-> varargs
:form
last
:annotation
:spec)]
;; If no arguments are specced, return nil
(when (some identity (conj arg-specs vararg-spec))
(let [specced-args (vec (interleave arg-names (nils->any? arg-specs)))]
(if varargs
`(s/cat ~@specced-args :vararg (s/* ~(nil->any? vararg-spec)))
`(s/cat ~@specced-args)))))
:arity-n
(let [{:keys [bodies]} (last fn-tail)
params (map :params bodies)
arg-lists (map :args params)
vararg-lists (map :varargs params)
arg-specs (map (fn [arglist]
(map (fn [arg]
(get-in (last arg) [:annotation :spec]))
arglist)) arg-lists)
vararg-specs (map (fn [vararg-list]
(map (fn [vararg]
(-> vararg :form last :annotation :spec)) vararg-list)) vararg-lists)]
;; If no arguments are specced, return nil
(when (some identity (conj (flatten arg-specs) (flatten vararg-specs)))
`(s/or
~@(interleave (arity-labels)
(map (fn [arg-list vararg]
(let [arg-specs (into [] (comp (map #(get-in (last %) [:annotation :spec]))
(map nil->any?)) arg-list)
vararg-spec (-> vararg
:form
last
:annotation
:spec)
arg-names (gen-argument-keys arg-list)]
(let [specced-args (vec (interleave arg-names arg-specs))]
(if vararg
`(s/cat ~@specced-args :varargs (s/* ~(nil->any? vararg-spec)))
`(s/cat ~@specced-args)))))
arg-lists vararg-lists)))))))

0 comments on commit 51af322

Please sign in to comment.