diff options
| -rw-r--r-- | source/lux/host/jvm.lux | 35 | ||||
| -rw-r--r-- | src/lux/analyser.clj | 10 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 75 | ||||
| -rw-r--r-- | src/lux/base.clj | 12 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 15 | ||||
| -rw-r--r-- | src/lux/compiler/io.clj | 2 | ||||
| -rw-r--r-- | src/lux/host.clj | 77 | ||||
| -rw-r--r-- | src/lux/lib/loader.clj | 17 | ||||
| -rw-r--r-- | src/lux/type.clj | 38 | ||||
| -rw-r--r-- | src/lux/type/host.clj | 162 |
10 files changed, 321 insertions, 122 deletions
diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index bbb396874..57d0e9c5d 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -332,32 +332,29 @@ (let [(~@ var-rebinds)] (~ new-expr))))))))) -(do-template [<name> <op>] +(do-template [<name> <op> <use-self?>] [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] - [expected-output exp-output^]) + [expected-output exp-output^] [unsafe? (tag?^ ["" "unsafe"])]) (do Lux/Monad [[vars var-types var-rebinds arg-classes] (prepare-args args) g!self (gensym "self") - #let [[body return-type] (gen-expected-output expected-output - (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~ g!self) [(~@ vars)])))]] + #let [included-self (: (List AST) + (if <use-self?> + (@list g!self) + (@list))) + [body return-type] (gen-expected-output expected-output + (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~@ included-self) [(~@ vars)]))) + [body return-type] (if unsafe? + [(` (try (~ body))) (` (Either Text (~ return-type)))] + [body return-type])]] (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type)) - (lambda [[(~@ vars)] (~ g!self)] + (lambda [[(~@ vars)] (~@ included-self)] (let [(~@ var-rebinds)] (~ body))))))) ))] - [invoke-virtual$ ;_jvm_invokevirtual] - [invoke-interface$ ;_jvm_invokeinterface] + [invoke-virtual$ ;_jvm_invokevirtual true] + [invoke-interface$ ;_jvm_invokeinterface true] + [invoke-special$ ;_jvm_invokespecial true] + [invoke-static$ ;_jvm_invokestatic false] ) - -(defsyntax #export (invoke-static$ [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] - [expected-output exp-output^]) - (do Lux/Monad - [[vars var-types var-rebinds arg-classes] (prepare-args args) - #let [[body return-type] (gen-expected-output expected-output - (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] [(~@ vars)])))]] - (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type)) - (lambda [[(~@ vars)]] - (let [(~@ var-rebinds)] - (~ body))))))) - )) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 5659a066e..0aa883c23 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -68,7 +68,7 @@ (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) ))) -(defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] +(defn ^:private aba8 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons ?length (&/$Nil)))) @@ -155,6 +155,12 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) (&&host/analyse-jvm-arraylength analyse ?array) + _ + (do (prn 'aba8 (&/adt->text token)) + (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&&/|meta (&/T "" -1 -1) token)))))))) + +(defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] + (|case token ;; Classes & interfaces (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] (&/$Cons [_ (&/$TextS ?name)] @@ -191,7 +197,7 @@ (&&host/analyse-jvm-program analyse compile-token ?args ?body) _ - (fail ""))) + (aba8 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 5208b2883..9490c37c8 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -11,10 +11,12 @@ [parser :as &parser] [type :as &type] [host :as &host]) + [lux.type.host :as &host-type] (lux.analyser [base :as &&] [lambda :as &&lambda] [env :as &&env]) - [lux.compiler.base :as &c!base])) + [lux.compiler.base :as &c!base]) + (:import (java.lang.reflect TypeVariable))) ;; [Utils] (defn ^:private extract-text [ast] @@ -80,7 +82,7 @@ "(-> Type Type)" (|case type (&/$DataT class params) - (&type/Data$ (&type/as-obj class) params) + (&type/Data$ (&host-type/as-obj class) params) _ type)) @@ -279,19 +281,68 @@ (&/V &&/$jvm-null? =object)))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ &host/null-data-tag &/Nil$)] + (|do [:let [output-type (&type/Data$ &host-type/null-data-tag &/Nil$)] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor (&/V &&/$jvm-null nil)))))) +(defn ^:private clean-gtype-var [idx gtype-var] + (|let [(&/$VarT id) gtype-var] + (|do [? (&type/bound? id)] + (if ? + (|do [real-type (&type/deref id)] + (return (&/T idx real-type))) + (return (&/T (+ 2 idx) (&type/Bound$ idx))))))) + +(defn ^:private clean-gtype-vars [gtype-vars] + (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] + (|do [:let [[idx types] idx+types] + [idx* real-type] (clean-gtype-var idx gtype-var)] + (return (&/T idx* (&/Cons$ real-type types))))) + (&/T 0 (&/|list)) + gtype-vars)] + (return clean-types))) + +(defn ^:private make-gtype [class-name type-args] + "(-> Text (List Type) Type)" + (&/fold (fn [base-type type-arg] + (|case type-arg + (&/$BoundT _) + (&type/Univ$ &type/empty-env base-type) + + _ + base-type)) + (&type/Data$ class-name type-args) + type-args)) + +(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + ;; :let [_ (prn 'analyse-jvm-new-helper/_0 gtype) + ;; _ (prn 'analyse-jvm-new-helper/_1 gtype (->> arg-types (&/|map &type/show-type) &/->seq)) + ;; _ (prn 'analyse-jvm-new-helper/_2 gtype (->> args (&/|map &/show-ast) &/->seq))] + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] + (return (&/T (make-gtype gtype gtype-vars*) + =args))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + ;; (prn 'analyse-jvm-new-helper gtype gtv $var (&/|length gtype-vars) (&/|length gtype-args)) + (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)] + (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args)))) + )) + (defn analyse-jvm-new [analyse exo-type class classes args] (|do [class-loader &/loader - [=return exceptions] (&host/lookup-constructor class-loader class classes) - =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) - classes args) + [exceptions gvars gargs] (&host/lookup-constructor class-loader class classes) + ;; :let [_ (prn 'analyse-jvm-new class (&/->seq gvars) (&/->seq gargs))] _ (ensure-catching exceptions) - :let [output-type (&type/Data$ class &/Nil$)] + [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) + ;; :let [_ (prn 'analyse-jvm-new/POST class (->> classes &/->seq vec) (&type/show-type output-type))] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor @@ -299,7 +350,7 @@ (do-template [<class> <new-name> <new-tag> <load-name> <load-tag> <store-name> <store-tag>] (let [elem-type (&type/Data$ <class> &/Nil$) - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type)) + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type)) length-type &type/Int idx-type &type/Int] (defn <new-name> [analyse length] @@ -338,7 +389,7 @@ idx-type &type/Int] (defn analyse-jvm-anewarray [analyse class length] (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=length (&&/analyse-1 analyse length-type length) _cursor &/cursor] (return (&/|list (&&/|meta array-type _cursor @@ -346,7 +397,7 @@ (defn analyse-jvm-aaload [analyse class array idx] (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) _cursor &/cursor] @@ -355,7 +406,7 @@ (defn analyse-jvm-aastore [analyse class array idx elem] (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) =elem (&&/analyse-1 analyse elem-type elem) @@ -368,7 +419,7 @@ (&type/with-var (fn [$var] (let [elem-type $var - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) _cursor &/cursor] (return (&/|list (&&/|meta length-type _cursor diff --git a/src/lux/base.clj b/src/lux/base.clj index d8bce5f87..d76348b9a 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -987,3 +987,15 @@ flag-compiled-module compiled-module? $Compiled flag-cached-module cached-module? $Cached ) + +(do-template [<name> <default> <op>] + (defn <name> [p xs] + (|case xs + ($Nil) + <default> + + ($Cons x xs*) + (<op> (p x) (|every? p xs*)))) + + |every? true and + |any? false or) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index afb3c9a49..7f7509998 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -15,6 +15,7 @@ [parser :as &parser] [analyser :as &analyser] [host :as &host]) + [lux.type.host :as &host-type] [lux.analyser.base :as &a] [lux.compiler.base :as &&] :reload) @@ -208,13 +209,13 @@ (return ret))) ?classes ?args) :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&type/as-obj ?class)) ?method method-sig) + (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&host-type/as-obj ?class)) ?method method-sig) (prepare-return! ?output-type))]] (return nil))) (do-template [<name> <op>] (defn <name> [compile ?class ?method ?classes ?object ?args ?output-type] - (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + (|do [:let [?class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) @@ -235,7 +236,7 @@ ) (defn compile-jvm-invokespecial [compile ?class ?method ?classes ?object ?args ?output-type] - (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + (|do [:let [?class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) @@ -378,12 +379,12 @@ (defn compile-jvm-getstatic [compile ?class ?field ?output-type] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig ?output-type)) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&host-type/as-obj ?class)) ?field (&host/->java-sig ?output-type)) (prepare-return! ?output-type))]] (return nil))) (defn compile-jvm-getfield [compile ?class ?field ?object ?output-type] - (|do [:let [class* (&host/->class (&type/as-obj ?class))] + (|do [:let [class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [_ (doto *writer* @@ -395,12 +396,12 @@ (defn compile-jvm-putstatic [compile ?class ?field ?value ?output-type] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?value) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig ?output-type))] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&host-type/as-obj ?class)) ?field (&host/->java-sig ?output-type))] :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] (return nil))) (defn compile-jvm-putfield [compile ?class ?field ?object ?value ?output-type] - (|do [:let [class* (&host/->class (&type/as-obj ?class))] + (|do [:let [class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [_ (.visitInsn *writer* Opcodes/DUP)] diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index d83ec1404..4cd6284b7 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -15,7 +15,7 @@ (not (nil? @!libs))) (defn ^:private init-libs! [] - (reset! !libs (&lib/load &/lib-dir))) + (reset! !libs (&lib/load))) ;; [Resources] (defn read-file [^String file-name] diff --git a/src/lux/host.clj b/src/lux/host.clj index b05c30ad3..74a8af66a 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -9,7 +9,8 @@ clojure.core.match clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail* |let |case]] - [type :as &type])) + [type :as &type]) + [lux.type.host :as &host-type]) (:import (java.lang.reflect Field Method Constructor Modifier) java.util.regex.Pattern (org.objectweb.asm Opcodes @@ -23,30 +24,10 @@ (def module-separator "/") (def class-name-separator ".") (def class-separator "/") -(def array-data-tag "#Array") -(def null-data-tag "#Null") ;; [Utils] (def class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))") -(comment - (let [class (class (to-array []))] - (str (if-let [pkg (.getPackage class)] - (str (.getName pkg) ".") - "") - (.getSimpleName class))) - - (.getName String) "java.lang.String" - - (.getName (class (to-array []))) "[Ljava.lang.Object;" - - (re-find class-name-re "java.lang.String") - ["java.lang.String" "java.lang.String" nil nil "java.lang.String"] - - (re-find class-name-re "[Ljava.lang.Object;") - ["[Ljava.lang.Object;" "[Ljava.lang.Object;" "[" "java.lang.Object" nil] - ) - (defn ^:private class->type [^Class class] "(-> Class Type)" (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) @@ -55,7 +36,7 @@ ;; (prn 'class->type/_1 class base arr-brackets) (let [output-type (if (.equals "void" base) &type/Unit - (reduce (fn [inner _] (&type/Data$ array-data-tag (&/|list inner))) + (reduce (fn [inner _] (&type/Data$ &host-type/array-data-tag (&/|list inner))) (&type/Data$ base &/Nil$) (range (count (or arr-brackets "")))) )] @@ -113,16 +94,16 @@ "(-> Type Text)" (|case type (&/$DataT ?name params) - (cond (= array-data-tag ?name) (|let [[level base] (unfold-array type) - base-sig (|case base - (&/$DataT base-class _) - (->class base-class) - - _ - (->java-sig base))] - (str (->> (&/|repeat level "[") (&/fold str "")) - "L" base-sig ";")) - (= null-data-tag ?name) (->type-signature "java.lang.Object") + (cond (= &host-type/array-data-tag ?name) (|let [[level base] (unfold-array type) + base-sig (|case base + (&/$DataT base-class _) + (->class base-class) + + _ + (->java-sig base))] + (str (->> (&/|repeat level "[") (&/fold str "")) + "L" base-sig ";")) + (= &host-type/null-data-tag ?name) (->type-signature "java.lang.Object") :else (->type-signature ?name)) (&/$LambdaT _ _) @@ -140,7 +121,7 @@ (do-template [<name> <static?>] (defn <name> [class-loader target field] - (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&type/as-obj target) true class-loader)) + (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&host-type/as-obj target) true class-loader)) :when (and (.equals ^Object field (.getName =field)) (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =field))))] (.getType =field)))] @@ -154,7 +135,7 @@ (do-template [<name> <static?>] (defn <name> [class-loader target method-name args] ;; (prn '<name> target method-name) - (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj target) true class-loader)) + (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader)) :when (and (.equals ^Object method-name (.getName =method)) (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method))) (let [param-types (&/->list (seq (.getParameterTypes =method)))] @@ -172,20 +153,24 @@ ) (defn lookup-constructor [class-loader target args] - ;; (prn 'lookup-constructor class-loader target (&type/as-obj target)) - (if-let [ctor (first (for [^Constructor =method (.getDeclaredConstructors (Class/forName (&type/as-obj target) true class-loader)) - :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] - (and (= (&/|length args) (&/|length param-types)) - (&/fold2 #(and %1 (.equals ^Object %2 %3)) - true - args - (&/|map #(.getName ^Class %) param-types))))] - =method))] - (return (&/T &type/Unit (->> ctor .getExceptionTypes &/->list (&/|map #(.getName %))))) - (fail (str "[Host Error] Constructor does not exist: " target)))) + ;; (prn 'lookup-constructor class-loader target (&host-type/as-obj target)) + (let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] + (if-let [^Constructor ctor (first (for [^Constructor =method (.getDeclaredConstructors target-class) + :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types))))] + =method))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list) + gargs (->> ctor .getGenericParameterTypes seq &/->list) + exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName %)))] + (return (&/T exs gvars gargs))) + (fail (str "[Host Error] Constructor does not exist: " target))))) (defn abstract-methods [class-loader class] - (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj class) true class-loader)) + (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj class) true class-loader)) :when (.equals true (Modifier/isAbstract (.getModifiers =method)))] (&/T (.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))))) diff --git a/src/lux/lib/loader.clj b/src/lux/lib/loader.clj index 6326fb835..13810238a 100644 --- a/src/lux/lib/loader.clj +++ b/src/lux/lib/loader.clj @@ -16,8 +16,13 @@ TarArchiveInputStream))) ;; [Utils] -(defn ^:private fetch-libs [from] - (seq (.listFiles (new File from)))) +(defn ^:private fetch-libs [] + (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader) + (.getURLs) + seq + (map #(.getFile ^java.net.URL %)) + (filter #(.endsWith ^String % ".tar.gz")) + (map #(new File ^String %)))) (let [init-capacity (* 100 1024) buffer-size 1024] @@ -45,10 +50,10 @@ ;; [Exports] (def lib-ext ".tar.gz") -(defn load [from] - (reduce merge {} - (for [lib (fetch-libs from)] - (unpackage lib)))) +(defn load [] + (->> (fetch-libs) + (map unpackage) + (reduce merge {}))) (comment (->> &/lib-dir load keys) diff --git a/src/lux/type.clj b/src/lux/type.clj index 0495e6b02..723e169c4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -7,7 +7,8 @@ (:refer-clojure :exclude [deref apply merge bound?]) (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let |case]])) + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]]) + [lux.type.host :as &&host])) (declare show-type) @@ -23,7 +24,7 @@ _ false)) -(def ^:private empty-env &/Nil$) +(def empty-env &/Nil$) (defn Data$ [name params] (&/V &/$DataT (&/T name params))) (defn Bound$ [idx] @@ -463,21 +464,6 @@ _ (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) -(defn as-obj [class] - (case class - "boolean" "java.lang.Boolean" - "byte" "java.lang.Byte" - "short" "java.lang.Short" - "int" "java.lang.Integer" - "long" "java.lang.Long" - "float" "java.lang.Float" - "double" "java.lang.Double" - "char" "java.lang.Character" - ;; else - class)) - -(def ^:private primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}) - (def ^:private init-fixpoints &/Nil$) (defn ^:private check* [class-loader fixpoints invariant?? expected actual] @@ -665,7 +651,7 @@ [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] (cond (= "#Null" a!name) - (if (not (contains? primitive-types e!name)) + (if (not (&&host/primitive-type? e!name)) (return (&/T fixpoints nil)) (fail (check-error expected actual))) @@ -675,22 +661,16 @@ (fail (check-error expected actual))) :else - (let [e!name (as-obj e!name) - a!name (as-obj a!name)] + (let [e!name (&&host/as-obj e!name) + a!name (&&host/as-obj a!name)] (cond (and (.equals ^Object e!name a!name) (= (&/|length e!params) (&/|length a!params))) (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] (return (&/T fixpoints nil))) - (and (not invariant??) - ;; (do (println '[Data Data] [e!name a!name] - ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") - ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) - ;; true) - (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) - (catch Exception e - (prn 'FAILED_HERE e!name a!name)))) - (return (&/T fixpoints nil)) + (not invariant??) + (|do [actual& (&&host/->super-type existential class-loader e!name a!name a!params)] + (check* class-loader fixpoints invariant?? expected actual&)) :else (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj new file mode 100644 index 000000000..486205494 --- /dev/null +++ b/src/lux/type/host.clj @@ -0,0 +1,162 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.type.host + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]])) + (:import (java.lang.reflect GenericArrayType + ParameterizedType + TypeVariable + WildcardType))) + +;; [Exports] +(def array-data-tag "#Array") +(def null-data-tag "#Null") + +;; [Utils] +(defn ^:private Data$ [name params] + (&/V &/$DataT (&/T name params))) + +(defn ^:private trace-lineage* [^Class super-class ^Class sub-class] + "(-> Class Class (List Class))" + ;; Either they're both interfaces, of they're both classes + (cond (.isInterface sub-class) + (let [interface<=interface? #(if (or (= super-class %) + (.isAssignableFrom super-class %)) + % + nil)] + (loop [sub-class sub-class + stack (&/|list)] + (let [super-interface (some interface<=interface? + (.getInterfaces sub-class))] + (if (= super-class super-interface) + (&/Cons$ super-interface stack) + (let [super* (.getSuperclass sub-class)] + (recur super* (&/Cons$ super* stack))))))) + + (.isInterface super-class) + (let [class<=interface? #(if (= super-class %) % nil)] + (loop [sub-class sub-class + stack (&/|list)] + (if-let [super-interface (some class<=interface? (.getInterfaces sub-class))] + (&/Cons$ super-interface stack) + (let [super* (.getSuperclass sub-class)] + (recur super* (&/Cons$ super* stack)))))) + + :else + (loop [sub-class sub-class + stack (&/|list)] + (let [super* (.getSuperclass sub-class)] + (if (= super* super-class) + (&/Cons$ super* stack) + (recur super* (&/Cons$ super* stack))))))) + +(defn ^:private trace-lineage [^Class sub-class ^Class super-class] + "(-> Class Class (List Class))" + (&/|reverse (trace-lineage* super-class sub-class))) + +(let [matcher (fn [m ^TypeVariable jt lt] (&/Cons$ (&/T (.getName jt) lt) m))] + (defn ^:private match-params [sub-type-params params] + (assert (and (= (&/|length sub-type-params) (&/|length params)) + (&/|every? (partial instance? TypeVariable) sub-type-params))) + (&/fold2 matcher (&/|table) sub-type-params params))) + +;; [Exports] +(defn instance-param [existential matchings refl-type] + "(-> (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" + ;; (prn 'instance-param refl-type (class refl-type)) + (cond (instance? Class refl-type) + (return (Data$ (.getName ^Class refl-type) (&/|list))) + + (instance? GenericArrayType refl-type) + (let [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] + (return (Data$ array-data-tag (&/|list inner-type)))) + + (instance? ParameterizedType refl-type) + (|do [:let [refl-type* ^ParameterizedType refl-type] + params* (->> refl-type* + .getActualTypeArguments + seq &/->list + (&/map% (partial instance-param existential matchings)))] + (return (Data$ (->> refl-type* ^Class (.getRawType) .getName) + params*))) + + (instance? TypeVariable refl-type) + (let [gvar (.getName ^TypeVariable refl-type)] + (if-let [m-type (&/|get gvar matchings)] + (return m-type) + (fail (str "[Type Error] Unknown generic type variable: " gvar)))) + + (instance? WildcardType refl-type) + (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] + (instance-param existential matchings bound) + existential))) + +;; [Utils] +(defn ^:private translate-params [existential super-type-params sub-type-params params] + "(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))" + (|let [matchings (match-params sub-type-params params)] + (&/map% (partial instance-param existential matchings) super-type-params))) + +(defn ^:private raise* [existential sub+params super] + "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))" + (|let [[^Class sub params] sub+params] + (if (.isInterface super) + (|do [:let [super-params (->> sub + .getGenericInterfaces + (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %))) + (if (instance? Class %) (&/|list) (->> % .getActualTypeArguments seq &/->list)) + nil)))] + params* (translate-params existential + super-params + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T super params*))) + (let [super* (.getGenericSuperclass sub)] + (cond (instance? Class super*) + (return (&/T super* (&/|list))) + + (instance? ParameterizedType super*) + (|do [params* (translate-params existential + (->> ^ParameterizedType super* .getActualTypeArguments seq &/->list) + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T super params*))) + + :else + (assert false (prn-str super* (class super*) [sub super]))))))) + +(defn ^:private raise [existential lineage class params] + "(-> (List Class) Class (List Type) (Lux (, Class (List Type))))" + (&/fold% (partial raise* existential) (&/T class params) lineage)) + +;; [Exports] +(defn ->super-type [existential class-loader super-class sub-class sub-params] + "(-> Text Text (List Type) (Lux Type))" + (let [super-class+ (Class/forName super-class true class-loader) + sub-class+ (Class/forName sub-class true class-loader)] + (if (.isAssignableFrom super-class+ sub-class+) + (let [lineage (trace-lineage sub-class+ super-class+)] + (|do [[sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] + (return (Data$ (.getName sub-class*) sub-params*)))) + (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class " </=" super-class))))) + +(defn as-obj [class] + (case class + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + class)) + +(let [primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}] + (defn primitive-type? [type-name] + (contains? primitive-types type-name))) |