(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.jvm
"Resolve source JVM facts without evaluating expressions or running the native
analyzer. Method inference follows the pinned Clojure overload rules."
(:refer-clojure :exclude [methods])
(:require [com.tailrecursion.nanopass :as np]
[com.tailrecursion.blacktide.compiler.languages :as l]
[typed.clojure :as-alias t]))
(np/defpass resolved-class
{:from [l/JVM Raw] :to (t/Option java.lang.Class) :body true}
[name]
(cond (class? name) name
(symbol? name) (let [v (ns-resolve *ns* name)] (when (class? v) v))))
(np/defpass source-tag {:from [l/JVM Raw] :to (t/Option t/Sym) :body true}
[form]
;; Compiler.tagOf ignores all other metadata values, including Class objects.
(let [tag (:tag (meta form))] (cond (symbol? tag) tag (string? tag) (symbol tag))))
(np/defpass tag-class
{:from [l/JVM Raw] :to (t/Option java.lang.Class) :body true}
[tag]
(when (some? tag)
(or (when (and (symbol? tag) (nil? (namespace tag))) (clojure.lang.Compiler$HostExpr/maybeSpecialTag tag))
(when (symbol? tag) (clojure.lang.Compiler$HostExpr/maybeArrayClass tag))
(when (string? tag) (clojure.lang.RT/classForNameNonLoading tag))
(resolved-class tag)
(throw (IllegalArgumentException. (str "Unable to resolve classname: " tag))))))
(np/defpass fact
{:from [l/JVM Type] :to [l/JVM Fact] :args [t/Bool l/JVM-Seed] :body true}
[primitive? seed type]
(assoc seed :type type :primitive? primitive? :hint-error nil))
(np/defpass value-type {:from [l/JVM Fact] :to [l/JVM Type] :body true}
[fact]
(if-let [^String error (:hint-error fact)] (throw (UnsupportedOperationException. error)) (:type fact)))
(np/defpass hint-conflict
{:from [l/JVM Type] :to (t/Option t/Str) :args [(t/Option java.lang.Class)] :body true}
[^Class hint ^Class type]
(when (and hint (class? type) (.isPrimitive hint) (.isPrimitive type) (not= hint type)
(not (and (#{"int" "byte" "short" "char"} (.getName hint))
(#{"int" "byte" "short" "char"} (.getName type)))))
(str "Cannot coerce " type " to " hint ", use a cast instead")))
(np/defpass visible-class
{:from [l/JVM Type] :to [l/JVM Type] :body true}
[^Class class]
(if (and (class? class) (java.lang.reflect.Modifier/isPublic (.getModifiers class))) class :unknown))
(np/defpass literal-type {:from [l/JVM Raw] :to [l/JVM Type] :body true}
[value]
(cond
(nil? value) nil
(or (instance? Long value) (instance? Integer value)) Long/TYPE
(instance? Double value) Double/TYPE
(and (coll? value) (empty? value) (nil? (meta value)))
(cond (vector? value) clojure.lang.IPersistentVector
(map? value) clojure.lang.IPersistentMap
(set? value) clojure.lang.IPersistentSet
:else clojure.lang.IPersistentList)
(instance? clojure.lang.APersistentVector value) clojure.lang.APersistentVector
(instance? clojure.lang.APersistentMap value) clojure.lang.APersistentMap
(instance? clojure.lang.APersistentSet value) clojure.lang.APersistentSet
:else (visible-class (class value))))
(np/defpass join-type {:from [l/JVM Type] :to [l/JVM Type] :args [l/JVM-Type] :body true}
[a b]
(cond (= a b) a
(and (nil? a) (class? b) (not (.isPrimitive ^Class b))) b
(and (nil? b) (class? a) (not (.isPrimitive ^Class a))) a
:else :unknown))
(np/defpass methods
{:from [l/JVM Raw] :to [l/JVM Methods] :args [java.lang.Class t/Int t/Bool] :body true}
[class arity static? member]
;; Reflector's raw Java List is an external API boundary; refine its elements.
(reduce (fn [^{::t/- l/JVM-Methods} out ^{::t/- t/Any} item]
(if (instance? java.lang.reflect.Method item) (conj out item) out))
[] (clojure.lang.Reflector/getMethods class (int arity) (clojure.lang.Compiler/munge (str member)) static?)))
(np/defpass static-method?
{:from [l/JVM Raw] :to t/Bool :args [java.lang.Class] :body true}
[^Class class member]
(let [methods (.getMethods class) name (clojure.lang.Compiler/munge (str member))]
(boolean
(some (fn [^{::t/- t/Int} index]
(let [^java.lang.reflect.Method method (aget methods (int index))]
(and (= name (.getName method)) (java.lang.reflect.Modifier/isStatic (.getModifiers method)))))
(range (alength methods))))))
(np/defpass return-type {:from [l/JVM Method] :to java.lang.Class :body true}
[member]
(if (instance? java.lang.reflect.Method member)
(.getReturnType ^java.lang.reflect.Method member) (.getDeclaringClass ^java.lang.reflect.Constructor member)))
(np/defpass constructors
{:from [l/JVM Raw] :to [l/JVM Methods] :args [java.lang.Class t/Int] :body true}
[^Class class arity _]
(let [constructors (.getConstructors class)]
(filterv (fn [^{::t/- l/JVM-Method :tag java.lang.reflect.Executable} member] (= arity (.getParameterCount member)))
(mapv (fn [^{::t/- t/Int} index] (aget constructors (int index))) (range (alength constructors))))))
(np/defpass parameters
{:from [l/JVM Method] :to (t/Vec java.lang.Class) :body true}
[^java.lang.reflect.Executable method]
(let [params (.getParameterTypes method)]
(mapv (fn [^{::t/- t/Int} index] (aget params (int index))) (range (alength params)))))
(np/defpass select-method
{:from [l/JVM Methods] :to (t/Option l/JVM-Method) :args [l/JVM-Types l/JVM-Tags] :body true}
[types tags methods]
(if tags
(let [tags (mapv #(when-not (= '_ %) (tag-class %)) tags)
matches (filter (fn [^{::t/- l/JVM-Method} method]
(and (not (.isSynthetic ^java.lang.reflect.Executable method)) (= (count tags) (.getParameterCount ^java.lang.reflect.Executable method))
(every? true? (map #(or (nil? %1) (= %1 %2)) tags (parameters method))))) methods)]
(if (= 1 (count matches)) (first matches)
(throw (IllegalArgumentException. "param-tags do not resolve a single method"))))
(if (= 1 (count methods))
(first methods)
(let [result
(reduce
(fn [^{::t/- l/JVM-Selection} selection ^{::t/- l/JVM-Method} method]
(let [params (parameters method)
exact? (= types params)
match? (every? true? (map (fn [^{::t/- Class :tag Class} p ^{::t/- l/JVM-Type} a]
(if (nil? a) (not (.isPrimitive p))
(clojure.lang.Reflector/paramArgTypeMatch p (if (= a :unknown) Object a)))) params types))
previous (:method selection)]
(cond
exact? (if (or (not (:exact? selection)) (nil? previous)
(.isAssignableFrom ^Class (return-type previous) (return-type method)))
{:method method :exact? true :tied? false}
(assoc selection :tied? false))
(and match? (not (:exact? selection)))
(cond (nil? previous) (assoc selection :method method)
(clojure.lang.Compiler/subsumes (.getParameterTypes ^java.lang.reflect.Executable method) (.getParameterTypes ^java.lang.reflect.Executable previous))
(assoc selection :method method :tied? false)
(= params (parameters previous))
(if (.isAssignableFrom ^Class (return-type previous) (return-type method))
(assoc selection :method method) selection)
(not (clojure.lang.Compiler/subsumes (.getParameterTypes ^java.lang.reflect.Executable previous) (.getParameterTypes ^java.lang.reflect.Executable method)))
(assoc selection :tied? true)
:else selection)
:else selection))) {:method nil :exact? false :tied? false} methods)]
(if (:tied? result) (throw (IllegalArgumentException. "More than one matching method found")) (:method result))))))
(np/defpass public-member
{:from [l/JVM Raw] :to (t/Option l/JVM-Method) :body true}
[member]
(cond
(instance? java.lang.reflect.Constructor member) member
(instance? java.lang.reflect.Method member)
(let [class (.getDeclaringClass ^java.lang.reflect.Method member)]
(if (java.lang.reflect.Modifier/isPublic (.getModifiers ^Class class)) member
(clojure.lang.Reflector/getAsMethodOfPublicBase class member)))))
(np/defpass host-type
{:from [l/JVM Operation] :to [l/JVM Type] :args [l/JVM-Types]}
[types operation]
:keyword :unknown
:protocol Object
:direct (:return operation)
:instanceof Boolean/TYPE
:adapt (:class operation)
:constructor (:class operation)
:method-value clojure.lang.AFn
:static-field (when-let [field (clojure.lang.Reflector/getField (:class operation) (name (:member operation)) true)]
(.getType field))
:static (if-let [method (select-method types (:tags operation)
(methods (:class operation) (count types) true (:member operation)))]
(return-type method) :unknown)
:instance
(let [class (or (:class operation) (when (class? (first types)) (first types)))
args (subvec types 1)]
(if (class? class)
(let [methods (methods class (count args) false (:member operation))
field? (and (empty? args) (or (= :field (:mode operation))
(and (= :member (:mode operation)) (empty? methods))))]
(if field?
(if-let [field (clojure.lang.Reflector/getField class (name (:member operation)) false)] (.getType field) :unknown)
(if-let [method (public-member (select-method args (:tags operation) methods))] (return-type method) :unknown)))
:unknown)))
(np/defpass prepare-call
{:from [l/JVM Operation] :to [l/JVM Plan] :args [l/JVM-Types] :body true}
[types operation]
(let [unchanged {:operation operation :conversions (mapv (fn [_] nil) types)}]
(case (:op operation)
(:adapt :instanceof :method-value :static-field :protocol :keyword) unchanged
:direct (let [params (:parameters operation)
fixed (if (:variadic? operation) (pop params) params)]
{:operation operation
:conversions (into (mapv (fn [type] {:type type :parameter? true}) fixed)
(repeat (- (count types) (count fixed)) nil))})
:constructor
(if-let [member (select-method types (:tags operation) (constructors (:class operation) (count types) nil))]
{:operation (cond-> operation (:tags operation) (assoc :tags (parameters member)))
:conversions (mapv (fn [type] {:type type :parameter? true}) (parameters member))} unchanged)
:static
(if-let [member (select-method types (:tags operation) (methods (:class operation) (count types) true (:member operation)))]
{:operation (cond-> operation (:tags operation) (assoc :tags (parameters member)))
:conversions (mapv (fn [type] {:type type :parameter? true}) (parameters member))} unchanged)
:instance
(let [class (or (:class operation) (when (class? (first types)) (first types))) args (subvec types 1)]
(if (class? class)
(let [members (methods class (count args) false (:member operation))
field? (and (empty? args) (or (= :field (:mode operation))
(and (= :member (:mode operation)) (empty? members))))]
(if field? unchanged
(if-let [member (public-member (select-method args (:tags operation) members))]
(let [class (.getDeclaringClass ^java.lang.reflect.Executable member)]
{:operation (cond-> (assoc operation :class class :mode :method) (:tags operation) (assoc :tags (parameters member)))
:conversions (into [{:type class :parameter? false}]
(mapv (fn [type] {:type type :parameter? true}) (parameters member)))}) unchanged))) unchanged)))))