aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux/host/jvm.lux35
-rw-r--r--src/lux/analyser.clj10
-rw-r--r--src/lux/analyser/host.clj75
-rw-r--r--src/lux/base.clj12
-rw-r--r--src/lux/compiler/host.clj15
-rw-r--r--src/lux/compiler/io.clj2
-rw-r--r--src/lux/host.clj77
-rw-r--r--src/lux/lib/loader.clj17
-rw-r--r--src/lux/type.clj38
-rw-r--r--src/lux/type/host.clj162
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)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-22 23:40:37 +0000