aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux231
1 files changed, 127 insertions, 104 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index 2a02ed6b2..8cb21e80c 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -5,6 +5,7 @@
["ex" exception #+ exception:])
(concurrency ["A" atom])
(data ["R" result]
+ [product]
[text "text/" Eq<Text>]
(text format
["l" lexer])
@@ -13,7 +14,7 @@
["d" dict]))
[macro "lux/" Monad<Lux>]
[type]
- (type ["TC" check])
+ (type ["tc" check])
[host])
(luxc ["&" base]
["&;" host]
@@ -22,6 +23,8 @@
["@" ../common]
)
+(def: null-class Text "#Null")
+
(do-template [<name> <class>]
[(def: #export <name> Type (#;Host <class> (list)))]
@@ -259,7 +262,7 @@
[arrayA (&;with-expected-type (type (Array varT))
(analyse arrayC))
elemT (&;within-type-env
- (TC;read-var var-id))
+ (tc;read-var var-id))
[elemT elem-class] (box-array-element-type elemT)
idxA (&;with-expected-type Nat
(analyse idxC))
@@ -280,7 +283,7 @@
[arrayA (&;with-expected-type (type (Array varT))
(analyse arrayC))
elemT (&;within-type-env
- (TC;read-var var-id))
+ (tc;read-var var-id))
[valueT elem-class] (box-array-element-type elemT)
idxA (&;with-expected-type Nat
(analyse idxC))
@@ -326,7 +329,7 @@
[objectA (&;with-expected-type varT
(analyse objectC))
objectT (&;within-type-env
- (TC;read-var var-id))
+ (tc;read-var var-id))
_ (check-object objectT)
_ (&;infer Bool)]
(wrap (#la;Procedure proc (list objectA))))
@@ -345,7 +348,7 @@
[monitorA (&;with-expected-type varT
(analyse monitorC))
monitorT (&;within-type-env
- (TC;read-var var-id))
+ (tc;read-var var-id))
_ (check-object monitorT)
exprA (analyse exprC)]
(wrap (#la;Procedure proc (list monitorA exprA))))
@@ -424,7 +427,7 @@
[exceptionA (&;with-expected-type varT
(analyse exceptionC))
exceptionT (&;within-type-env
- (TC;read-var var-id))
+ (tc;read-var var-id))
exception-class (check-object exceptionT)
? (sub-class? "java.lang.Throwable" exception-class)
_ (: (Lux Unit)
@@ -470,7 +473,7 @@
[objectA (&;with-expected-type varT
(analyse objectC))
objectT (&;within-type-env
- (TC;read-var var-id))
+ (tc;read-var var-id))
object-class (check-object objectT)
? (sub-class? class object-class)]
(if ?
@@ -497,73 +500,87 @@
(@;install "instance?" object-instance?)
)))
+(exception: #export Final-Field)
+
+(exception: #export Cannot-Convert-To-Class)
+(exception: #export Cannot-Convert-To-Lux-Type)
+(exception: #export Cannot-Cast-To-Primitive)
+(exception: #export Cannot-Cast-From-Primitive)
+
(def: type-descriptor
(-> java.lang.reflect.Type Text)
(java.lang.reflect.Type.getTypeName []))
-(exception: #export Cannot-Convert-To-Class)
-
-(def: (type-to-class type)
+(def: (java-type-to-class type)
(-> java.lang.reflect.Type (Lux Text))
(cond (host;instance? Class type)
(lux/wrap (Class.getName [] (:! Class type)))
(host;instance? ParameterizedType type)
- (type-to-class (ParameterizedType.getRawType [] (:! ParameterizedType type)))
+ (java-type-to-class (ParameterizedType.getRawType [] (:! ParameterizedType type)))
## else
(&;throw Cannot-Convert-To-Class (type-descriptor type))))
-(def: (adjust parent type)
- (-> java.lang.reflect.Type Type (Lux Type))
- (&;fail "UNIMPLEMENTED"))
-
-(exception: #export Cannot-Find-Lineage)
-
-(def: (up-cast super-class sub-class type)
- (-> Text Text Type (Lux Type))
- (if (text/= super-class sub-class)
- (lux/wrap type)
- (do macro;Monad<Lux>
- [super (load-class super-class)
- sub (load-class sub-class)
- parent (case (|> (list& (Class.getGenericSuperclass [] sub)
- (array;to-list (Class.getGenericInterfaces [] sub)))
- (list;filter (function check [class]
- (cond (host;instance? Class class)
- (Class.isAssignableFrom [(:! Class class)] super)
-
- (host;instance? ParameterizedType class)
- (check (ParameterizedType.getRawType [] (:! ParameterizedType class)))
-
- ## else
- false)))
- list;head)
- (#;Some parent)
- (wrap parent)
-
- #;None
- (&;throw Cannot-Find-Lineage (format "from: " sub-class "\n"
- " to: " super-class)))
- parent-class (type-to-class parent)
- upped (adjust parent type)]
- (up-cast super-class parent-class type))))
-
-(def: (with-super-type super-class analysis)
- (All [a] (-> Text (Lux a) (Lux [Type Type a])))
- (&common;with-var
- (function [[var-id varT]]
- (do macro;Monad<Lux>
- [output (&;with-expected-type varT
- analysis)
- subT (&;within-type-env
- (TC;read-var var-id))
- sub-class (check-object subT)
- ? (sub-class? super-class sub-class)
- _ (&;assert (format "'" sub-class "' is not a sub-class of '" sub-class "'.")
- ?)
- superT (up-cast super-class sub-class subT)]
- (wrap [superT subT output])))))
+(def: (java-type-to-lux-type java-type)
+ (-> java.lang.reflect.Type (Lux Type))
+ (cond (host;instance? Class java-type)
+ (let [class-name (Class.getName [] (:! (Class Object) java-type))]
+ (lux/wrap (#;Host class-name (list))))
+
+ (host;instance? ParameterizedType java-type)
+ (java-type-to-lux-type (ParameterizedType.getRawType [] (:! ParameterizedType java-type)))
+
+ (host;instance? GenericArrayType java-type)
+ (do macro;Monad<Lux>
+ [#let [innerJT (GenericArrayType.getGenericComponentType [] (:! GenericArrayType java-type))]
+ innerT (java-type-to-lux-type innerJT)]
+ (wrap (#;Host "#Array" (list innerT))))
+
+ ## else
+ (&;throw Cannot-Convert-To-Lux-Type (type-descriptor java-type))))
+
+(def: (up-cast super sub)
+ (-> Type Type (Lux Type))
+ (do macro;Monad<Lux>
+ [super-name (check-object super)
+ sub-name (check-object sub)]
+ (cond (d;contains? super-name boxes)
+ (&;throw Cannot-Cast-To-Primitive super-name)
+
+ (d;contains? sub-name boxes)
+ (&;throw Cannot-Cast-From-Primitive sub-name)
+
+ (text/= super-name sub-name)
+ (wrap sub)
+
+ (text/= null-class sub-name)
+ (wrap super)
+
+ ## else
+ (do @
+ [super-class (load-class super-name)
+ sub-class (load-class sub-name)
+ _ (&;assert (format "Class '" sub-name "' is not a sub-class of class '" super-name "'.")
+ (Class.isAssignableFrom [sub-class] super-class))
+ candiate-parents (monad;map @
+ (function [java-type]
+ (do @
+ [class-name (java-type-to-class java-type)
+ class (load-class class-name)]
+ (wrap [java-type (Class.isAssignableFrom [sub-class] super-class)])))
+ (list& (Class.getGenericSuperclass [] sub-class)
+ (array;to-list (Class.getGenericInterfaces [] sub-class))))]
+ (case (|> candiate-parents
+ (list;filter product;right)
+ (list/map product;left))
+ (#;Cons parent _)
+ (do @
+ [parentT (java-type-to-lux-type parent)]
+ (up-cast super parentT))
+
+ #;Nil
+ (&;fail (format "No valid path between " (%type sub) "and " (%type super) ".")))))))
(def: (find-field class-name field-name)
(-> Text Text (Lux [(Class Object) Field]))
@@ -580,53 +597,55 @@
(#R;Error _)
(&;fail (format "Unknown field '" field-name "' for class '" class-name "'.")))))
-(def: (translate-type java-type)
- (-> java.lang.reflect.Type (Lux Type))
- (cond (host;instance? Class java-type)
- (lux/wrap (#;Host (Class.getName [] (:! Class java-type)) (list)))
-
- (host;instance? GenericArrayType java-type)
- (do macro;Monad<Lux>
- [#let [innerJT (GenericArrayType.getGenericComponentType [] (:! GenericArrayType java-type))]
- innerT (translate-type innerJT)]
- (wrap (#;Host "#Array" (list innerT))))
-
- (host;instance? ParameterizedType java-type)
- (do macro;Monad<Lux>
- [#let [rawJT (ParameterizedType.getRawType [] (:! ParameterizedType java-type))
- paramsJT+ (array;to-list (ParameterizedType.getActualTypeArguments [] (:! ParameterizedType java-type)))]
- _ (&;assert (format "Expected class, but got something else: " (type-descriptor java-type))
- (host;instance? Class rawJT))
- paramsT+ (monad;map @ translate-type paramsJT+)]
- (wrap (#;Host (Class.getName [] (:! Class rawJT)) paramsT+)))
-
- ## else
- (&;fail (format "Cannot translate type: " (type-descriptor java-type)))))
-
(def: (static-field class-name field-name)
(-> Text Text (Lux [Type Bool]))
(do macro;Monad<Lux>
- [[class field] (find-field class-name field-name)
- #let [modifiers (Field.getModifiers [] field)]]
+ [[class fieldJ] (find-field class-name field-name)
+ #let [modifiers (Field.getModifiers [] fieldJ)]]
(if (Modifier.isStatic [modifiers])
- (let [fieldJT (Field.getGenericType [] field)]
+ (let [fieldJT (Field.getGenericType [] fieldJ)]
(do @
- [fieldT (translate-type fieldJT)]
+ [fieldT (java-type-to-lux-type fieldJT)]
(wrap [fieldT (Modifier.isFinal [modifiers])])))
(&;fail (format "Field '" field-name "' of class '" class-name "' is not static.")))))
(def: (virtual-field class-name field-name objectT)
(-> Text Text Type (Lux [Type Bool]))
(do macro;Monad<Lux>
- [[class field] (find-field class-name field-name)
- #let [modifiers (Field.getModifiers [] field)]]
+ [[class fieldJ] (find-field class-name field-name)
+ #let [modifiers (Field.getModifiers [] fieldJ)]]
(if (not (Modifier.isStatic [modifiers]))
- (let [fieldJT (Field.getGenericType [] field)]
+ (let [fieldJT (Field.getGenericType [] fieldJ)]
(do @
- [fieldT (translate-type fieldJT)]
+ [fieldT (java-type-to-lux-type fieldJT)]
(wrap [fieldT (Modifier.isFinal [modifiers])])))
(&;fail (format "Field '" field-name "' of class '" class-name "' is static.")))))
+(def: (analyse-object class analyse sourceC)
+ (-> Text &;Analyser Code (Lux [Type la;Analysis]))
+ (<| &common;with-var (function [[var-id varT]])
+ (do macro;Monad<Lux>
+ [target-class (load-class class)
+ targetT (java-type-to-lux-type (:! java.lang.reflect.Type
+ target-class))
+ sourceA (&;with-expected-type varT
+ (analyse sourceC))
+ sourceT (&;within-type-env
+ (tc;read-var var-id))
+ castT (up-cast targetT sourceT)]
+ (wrap [castT sourceA]))))
+
+(def: (analyse-input analyse targetT sourceC)
+ (-> &;Analyser Type Code (Lux [Type la;Analysis]))
+ (<| &common;with-var (function [[var-id varT]])
+ (do macro;Monad<Lux>
+ [sourceA (&;with-expected-type varT
+ (analyse sourceC))
+ sourceT (&;within-type-env
+ (tc;read-var var-id))
+ castT (up-cast targetT sourceT)]
+ (wrap [castT sourceA]))))
+
(def: (static-get proc)
(-> Text @;Proc)
(function [analyse args]
@@ -636,7 +655,10 @@
[[_ (#;Text class)] [_ (#;Text field)]]
(do macro;Monad<Lux>
[[fieldT final?] (static-field class field)
- _ (&;infer fieldT)]
+ expectedT macro;expected-type
+ castT (up-cast expectedT fieldT)
+ _ (&;within-type-env
+ (tc;check expectedT castT))]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field)))))
_
@@ -645,8 +667,6 @@
_
(&;fail (@;wrong-arity proc +2 (list;size args))))))
-(exception: #export Final-Field)
-
(def: (static-put proc)
(-> Text @;Proc)
(function [analyse args]
@@ -658,8 +678,9 @@
[[fieldT final?] (static-field class field)
_ (&;assert (Final-Field (format class "#" field))
(not final?))
- valueA (&;with-expected-type fieldT
- (analyse valueC))
+ [valueT valueA] (analyse-input analyse fieldT valueC)
+ _ (&;within-type-env
+ (tc;check fieldT valueT))
_ (&;infer Unit)]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) valueA))))
@@ -677,10 +698,12 @@
(case [classC fieldC]
[[_ (#;Text class)] [_ (#;Text field)]]
(do macro;Monad<Lux>
- [[superT objectT objectA] (with-super-type class
- (analyse objectC))
+ [[objectT objectA] (analyse-object class analyse objectC)
[fieldT final?] (virtual-field class field objectT)
- _ (&;infer fieldT)]
+ expectedT macro;expected-type
+ castT (up-cast expectedT fieldT)
+ _ (&;within-type-env
+ (tc;check expectedT castT))]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) objectA))))
_
@@ -697,13 +720,13 @@
(case [classC fieldC]
[[_ (#;Text class)] [_ (#;Text field)]]
(do macro;Monad<Lux>
- [[superT objectT objectA] (with-super-type class
- (analyse objectC))
+ [[objectT objectA] (analyse-object class analyse objectC)
[fieldT final?] (virtual-field class field objectT)
_ (&;assert (Final-Field (format class "#" field))
(not final?))
- valueA (&;with-expected-type fieldT
- (analyse valueC))
+ [valueT valueA] (analyse-input analyse fieldT valueC)
+ _ (&;within-type-env
+ (tc;check fieldT valueT))
_ (&;infer Unit)]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) valueA objectA))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 07:29:36 +0000