(annotate-host-info {:keys [op methods interfaces class env], :as ast})
Adds a :methods key to reify/deftype :methods info representing
the reflected informations for the required methods, replaces
(catch :default ..) forms with (catch Throwable ..)
Source
(defn annotate-host-info
"Adds a :methods key to reify/deftype :methods info representing
the reflected informations for the required methods, replaces
(catch :default ..) forms with (catch Throwable ..)"
{:pass-info {:walk :pre :depends #{} :after #{#'elide-meta}}}
[{:keys [op methods interfaces class env] :as ast}]
(case op
(:reify :deftype)
(let [all-methods
(into #{}
(mapcat (fn [class]
(mapv (fn [method]
(dissoc method :exception-types))
(filter (fn [{:keys [flags return-type]}]
(and return-type (not-any? #{:final :static} flags)))
(members class))))
(conj interfaces Object)))]
(assoc ast :methods (mapv (fn [ast]
(let [name (:name ast)
argc (count (:params ast))]
(assoc ast :methods
(filter #(and ((name-matches? name) (:name %))
(= argc (count (:parameter-types %))))
all-methods)))) methods)))
:catch
(let [the-class (cond
(and (= :const (:op class))
(= :default (:form class)))
Throwable
(= :maybe-class (:op class))
(u/maybe-class-literal (:class class)))
ast (if the-class
(-> ast
(assoc :class (assoc (ana/analyze-const the-class env :class)
:form (:form class)
:tag Class
:o-tag Class)))
ast)]
(assoc-in ast [:local :tag] (-> ast :class :val)))
:method
;; this should actually be in validate but it's here since it needs to be prewalked
;; for infer-tag purposes
(let [{:keys [name class tag form params fixed-arity env]} ast]
(if interfaces
(let [tags (mapv (comp u/maybe-class :tag meta :form) params)
methods-set (set (mapv (fn [x] (dissoc x :declaring-class :flags)) methods))]
(let [[m & rest :as matches] (try-best-match tags methods)]
(if m
(let [ret-tag (u/maybe-class (:return-type m))
i-tag (u/maybe-class (:declaring-class m))
arg-tags (mapv u/maybe-class (:parameter-types m))
params (mapv (fn [{:keys [atom] :as arg} tag]
(assoc arg :tag tag :o-tag tag)) params arg-tags)]
(if (or (empty? rest)
(every? (fn [{:keys [return-type parameter-types]}]
(and (= (u/maybe-class return-type) ret-tag)
(= arg-tags (mapv u/maybe-class parameter-types)))) rest))
(assoc (dissoc ast :interfaces :methods)
:bridges (filter #(and (= arg-tags (mapv u/maybe-class (:parameter-types %)))
(.isAssignableFrom (u/maybe-class (:return-type %)) ret-tag))
(disj methods-set (dissoc m :declaring-class :flags)))
:methods methods
:interface i-tag
:tag ret-tag
:o-tag ret-tag
:params params)
(throw (ex-info (str "Ambiguous method signature for method: " name)
(merge {:method name
:interfaces interfaces
:form form
:params (mapv (fn [x] (prewalk x cleanup)) params)
:matches matches}
(source-info env))))))
(throw (ex-info (str "No such method found: " name " with given signature in any of the"
" provided interfaces: " interfaces)
(merge {:method name
:methods methods
:interfaces interfaces
:form form
:params params}
(source-info env)))))))
ast))
ast))