diff options
Diffstat (limited to 'new-luxc')
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/host.jvm.lux | 231 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux | 39 |
2 files changed, 164 insertions, 106 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)))) diff --git a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux index b2aad9dd1..c5afe701b 100644 --- a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux @@ -41,7 +41,10 @@ <success> (#R;Error error) - <failure>)))] + (exec (if <success> + (log! error) + []) + <failure>))))] [success true false] [failure false true] @@ -373,13 +376,18 @@ Bool))) )) -(context: "Member [Field]." +(context: "Member [Static Field]." ($_ seq (test "jvm member static get" (success "jvm member static get" (list (code;text "java.lang.System") (code;text "out")) (#;Host "java.io.PrintStream" (list)))) + (test "jvm member static get (inheritance out)" + (success "jvm member static get" + (list (code;text "java.lang.System") + (code;text "out")) + (#;Host "java.lang.Object" (list)))) (test "jvm member static put" (success "jvm member static put" (list (code;text "java.awt.datatransfer.DataFlavor") @@ -394,6 +402,17 @@ (`' (_lux_check (+0 "java.io.PrintStream" (+0)) ("jvm object null")))) Unit)) + (test "jvm member static put (inheritance in)" + (success "jvm member static put" + (list (code;text "java.awt.datatransfer.DataFlavor") + (code;text "allHtmlFlavor") + (`' (_lux_check (+0 "javax.activation.ActivationDataFlavor" (+0)) + ("jvm object null")))) + Unit)) + )) + +(context: "Member [Virtual Field]." + ($_ seq (test "jvm member virtual get" (success "jvm member virtual get" (list (code;text "org.omg.CORBA.ValueMember") @@ -401,6 +420,13 @@ (`' (_lux_check (+0 "org.omg.CORBA.ValueMember" (+0)) ("jvm object null")))) (#;Host "java.lang.String" (list)))) + (test "jvm member virtual get (inheritance out)" + (success "jvm member virtual get" + (list (code;text "org.omg.CORBA.ValueMember") + (code;text "id") + (`' (_lux_check (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (#;Host "java.lang.Object" (list)))) (test "jvm member virtual put" (success "jvm member virtual put" (list (code;text "org.omg.CORBA.ValueMember") @@ -419,4 +445,13 @@ (`' (_lux_check (+0 "javax.swing.text.html.parser.DTD" (+0)) ("jvm object null")))) Unit)) + (test "jvm member virtual put (inheritance in)" + (success "jvm member virtual put" + (list (code;text "java.awt.GridBagConstraints") + (code;text "insets") + (`' (_lux_check (+0 "javax.swing.plaf.InsetsUIResource" (+0)) + ("jvm object null"))) + (`' (_lux_check (+0 "java.awt.GridBagConstraints" (+0)) + ("jvm object null")))) + Unit)) )) |