diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/host.jvm.lux | 322 |
1 files changed, 317 insertions, 5 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index 1592827db..ca4eb762f 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -7,20 +7,23 @@ (data ["R" result] [maybe] [product] + [bool "bool/" Eq<Bool>] [text "text/" Eq<Text>] (text format ["l" lexer]) - (coll [list "list/" Fold<List> Functor<List>] + (coll [list "list/" Fold<List> Functor<List> Monoid<List>] [array #+ Array] [dict #+ Dict])) [macro "lux/" Monad<Lux>] + (macro ["s" syntax]) [type] (type ["tc" check]) [host]) (luxc ["&" base] ["&;" host] (lang ["la" analysis]) - (analyser ["&;" common])) + (analyser ["&;" common] + ["&;" inference])) ["@" ../common] ) @@ -360,7 +363,8 @@ _ (&;fail (@;wrong-arity proc +2 (list;size args)))))))) -(host;import java.lang.Object) +(host;import java.lang.Object + (equals [Object] boolean)) (host;import java.lang.ClassLoader) @@ -384,21 +388,42 @@ (host;import java.lang.reflect.Modifier (#static isStatic [int] boolean) - (#static isFinal [int] boolean)) + (#static isFinal [int] boolean) + (#static isInterface [int] boolean) + (#static isAbstract [int] boolean)) (host;import java.lang.reflect.Field (getDeclaringClass [] (java.lang.Class Object)) (getModifiers [] int) (getGenericType [] java.lang.reflect.Type)) +(host;import java.lang.reflect.Method + (getName [] String) + (getModifiers [] int) + (getDeclaringClass [] (Class Object)) + (getTypeParameters [] (Array (TypeVariable Method))) + (getGenericParameterTypes [] (Array java.lang.reflect.Type)) + (getGenericReturnType [] java.lang.reflect.Type) + (getGenericExceptionTypes [] (Array java.lang.reflect.Type))) + +(host;import (java.lang.reflect.Constructor c) + (getModifiers [] int) + (getDeclaringClass [] (Class c)) + (getTypeParameters [] (Array (TypeVariable (Constructor c)))) + (getGenericParameterTypes [] (Array java.lang.reflect.Type)) + (getGenericExceptionTypes [] (Array java.lang.reflect.Type))) + (host;import (java.lang.Class c) (getName [] String) + (getModifiers [] int) (#static forName [String boolean ClassLoader] #try (Class Object)) (isAssignableFrom [(Class Object)] boolean) (getTypeParameters [] (Array (TypeVariable (Class c)))) (getGenericInterfaces [] (Array java.lang.reflect.Type)) (getGenericSuperclass [] java.lang.reflect.Type) - (getDeclaredField [String] #try Field)) + (getDeclaredField [String] #try Field) + (getConstructors [] (Array (Constructor Object))) + (getDeclaredMethods [] (Array Method))) (def: (load-class name) (-> Text (Lux (Class Object))) @@ -507,6 +532,7 @@ (exception: #export Final-Field) (exception: #export Cannot-Convert-To-Class) +(exception: #export Cannot-Convert-To-Parameter) (exception: #export Cannot-Convert-To-Lux-Type) (exception: #export Cannot-Cast-To-Primitive) (exception: #export JVM-Type-Is-Not-Class) @@ -826,6 +852,284 @@ _ (&;fail (@;wrong-arity proc +4 (list;size args)))))) +(def: (java-type-to-parameter type) + (-> java.lang.reflect.Type (Lux Text)) + (cond (host;instance? Class type) + (lux/wrap (Class.getName [] (:! Class type))) + + (host;instance? ParameterizedType type) + (java-type-to-parameter (ParameterizedType.getRawType [] (:! ParameterizedType type))) + + (or (host;instance? TypeVariable type) + (host;instance? WildcardType type)) + (lux/wrap "java.lang.Object") + + ## else + (&;throw Cannot-Convert-To-Parameter (type-descriptor type)))) + +(type: Method-Type + #Static + #Abstract + #Virtual + #Special + #Interface) + +(def: (check-method class method-name method-type arg-classes method) + (-> (Class Object) Text Method-Type (List Text) Method (Lux Bool)) + (do macro;Monad<Lux> + [parameters (|> (Method.getGenericParameterTypes [] method) + array;to-list + (monad;map @ java-type-to-parameter)) + #let [modifiers (Method.getModifiers [] method)]] + (wrap (and (Object.equals [class] (Method.getDeclaringClass [] method)) + (text/= method-name (Method.getName [] method)) + (case #Static + #Special + (Modifier.isStatic [modifiers]) + + _ + true) + (case method-type + #Special + (not (or (Modifier.isInterface [(Class.getModifiers [] class)]) + (Modifier.isAbstract [modifiers]))) + + _ + true) + (n.= (list;size arg-classes) (list;size parameters)) + (list/fold (function [[expectedJC actualJC] prev] + (and prev + (text/= expectedJC actualJC))) + true + (list;zip2 arg-classes parameters)))))) + +(def: (check-constructor class arg-classes constructor) + (-> (Class Object) (List Text) (Constructor Object) (Lux Bool)) + (do macro;Monad<Lux> + [parameters (|> (Constructor.getGenericParameterTypes [] constructor) + array;to-list + (monad;map @ java-type-to-parameter))] + (wrap (and (Object.equals [class] (Constructor.getDeclaringClass [] constructor)) + (n.= (list;size arg-classes) (list;size parameters)) + (list/fold (function [[expectedJC actualJC] prev] + (and prev + (text/= expectedJC actualJC))) + true + (list;zip2 arg-classes parameters)))))) + +(def: idx-to-bound + (-> Nat Type) + (|>. (n.* +2) n.inc #;Bound)) + +(def: (method-to-type method-type method) + (-> Method-Type Method (Lux [Type (List Type)])) + (let [owner (Method.getDeclaringClass [] method) + owner-name (Class.getName [] owner) + owner-tvars (case method-type + #Static + (list) + + _ + (|> (Class.getTypeParameters [] owner) + array;to-list + (list/map (TypeVariable.getName [])))) + method-tvars (|> (Method.getTypeParameters [] method) + array;to-list + (list/map (TypeVariable.getName []))) + num-owner-tvars (list;size owner-tvars) + all-tvars (list/compose owner-tvars method-tvars) + num-all-tvars (list;size all-tvars) + owner-tvarsT (|> (list;n.range +0 (n.dec num-owner-tvars)) (list/map idx-to-bound)) + method-tvarsT (|> (list;n.range num-owner-tvars (n.dec num-all-tvars)) (list/map idx-to-bound)) + mappings (: Mappings + (if (list;empty? all-tvars) + fresh-mappings + (|> (list/compose owner-tvarsT method-tvarsT) + list;reverse + (list;zip2 all-tvars) + (dict;from-list text;Hash<Text>))))] + (do macro;Monad<Lux> + [inputsT (|> (Method.getGenericParameterTypes [] method) + array;to-list + (monad;map @ (java-type-to-lux-type fresh-mappings))) + outputT (java-type-to-lux-type mappings (Method.getGenericReturnType [] method)) + exceptionsT (|> (Method.getGenericExceptionTypes [] method) + array;to-list + (monad;map @ (java-type-to-lux-type fresh-mappings))) + #let [methodT (<| (type;univ-q num-all-tvars) + (type;function (case method-type + #Static + inputsT + + _ + (list& (#;Host owner-name (list;reverse owner-tvarsT)) + inputsT))) + outputT)]] + (wrap [methodT exceptionsT])))) + +(exception: #export No-Candidate-Method) +(exception: #export Too-Many-Candidate-Methods) + +(def: (methods class-name method-name method-type arg-classes) + (-> Text Text Method-Type (List Text) (Lux [Type (List Type)])) + (do macro;Monad<Lux> + [class (load-class class-name) + candidates (|> class + (Class.getDeclaredMethods []) + array;to-list + (monad;map @ (function [method] + (do @ + [passes? (check-method class method-name method-type arg-classes method)] + (wrap [passes? method])))))] + (case (list;filter product;left candidates) + #;Nil + (&;throw No-Candidate-Method (format class-name "#" method-name)) + + (#;Cons candidate #;Nil) + (|> candidate product;right (method-to-type method-type)) + + _ + (&;throw Too-Many-Candidate-Methods (format class-name "#" method-name))))) + +(def: (constructor-to-type constructor) + (-> (Constructor Object) (Lux [Type (List Type)])) + (let [owner (Constructor.getDeclaringClass [] constructor) + owner-name (Class.getName [] owner) + owner-tvars (|> (Class.getTypeParameters [] owner) + array;to-list + (list/map (TypeVariable.getName []))) + constructor-tvars (|> (Constructor.getTypeParameters [] constructor) + array;to-list + (list/map (TypeVariable.getName []))) + num-owner-tvars (list;size owner-tvars) + all-tvars (list/compose owner-tvars constructor-tvars) + num-all-tvars (list;size all-tvars) + owner-tvarsT (|> (list;n.range +0 (n.dec num-owner-tvars)) (list/map idx-to-bound)) + constructor-tvarsT (|> (list;n.range num-owner-tvars (n.dec num-all-tvars)) (list/map idx-to-bound)) + mappings (: Mappings + (if (list;empty? all-tvars) + fresh-mappings + (|> (list/compose owner-tvarsT constructor-tvarsT) + list;reverse + (list;zip2 all-tvars) + (dict;from-list text;Hash<Text>))))] + (do macro;Monad<Lux> + [inputsT (|> (Constructor.getGenericParameterTypes [] constructor) + array;to-list + (monad;map @ (java-type-to-lux-type fresh-mappings))) + exceptionsT (|> (Constructor.getGenericExceptionTypes [] constructor) + array;to-list + (monad;map @ (java-type-to-lux-type fresh-mappings))) + #let [objectT (#;Host owner-name (list;reverse owner-tvarsT)) + constructorT (<| (type;univ-q num-all-tvars) + (type;function inputsT) + objectT)]] + (wrap [constructorT exceptionsT])))) + +(exception: #export No-Candidate-Constructor) +(exception: #export Too-Many-Candidate-Constructors) + +(def: (constructor-methods class-name arg-classes) + (-> Text (List Text) (Lux [Type (List Type)])) + (do macro;Monad<Lux> + [class (load-class class-name) + candidates (|> class + (Class.getConstructors []) + array;to-list + (monad;map @ (function [constructor] + (do @ + [passes? (check-constructor class arg-classes constructor)] + (wrap [passes? constructor])))))] + (case (list;filter product;left candidates) + #;Nil + (&;throw No-Candidate-Constructor class-name) + + (#;Cons candidate #;Nil) + (|> candidate product;right constructor-to-type) + + _ + (&;throw Too-Many-Candidate-Constructors class-name)))) + +(def: (invoke//static proc) + (-> Text @;Proc) + (function [analyse args] + (case (: (R;Result [(List Code) [Text Text (List [Text Code]) Unit]]) + (p;run args ($_ p;seq s;text s;text (p;some (s;tuple (p;seq s;text s;any))) s;end!))) + (#R;Success [_ [class method argsTC _]]) + (do macro;Monad<Lux> + [[methodT exceptionsT] (methods class method #Static (list/map product;left argsTC)) + [outputT argsA] (&inference;apply-function analyse methodT (list/map product;right argsTC)) + _ (&;infer outputT)] + (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method) argsA)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))))) + +(def: (invoke//virtual proc) + (-> Text @;Proc) + (function [analyse args] + (case (: (R;Result [(List Code) [Text Text Code (List [Text Code]) Unit]]) + (p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!))) + (#R;Success [_ [class method objectC argsTC _]]) + (do macro;Monad<Lux> + [[methodT exceptionsT] (methods class method #Virtual (list/map product;left argsTC)) + [outputT argsA] (&inference;apply-function analyse methodT (list& objectC (list/map product;right argsTC))) + _ (&;infer outputT)] + (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method) argsA)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))))) + +(def: (invoke//special proc) + (-> Text @;Proc) + (function [analyse args] + (case (: (R;Result [(List Code) [Text Text Code (List [Text Code]) Unit]]) + (p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!))) + (#R;Success [_ [class method objectC argsTC _]]) + (do macro;Monad<Lux> + [[methodT exceptionsT] (methods class method #Special (list/map product;left argsTC)) + [outputT argsA] (&inference;apply-function analyse methodT (list& objectC (list/map product;right argsTC))) + _ (&;infer outputT)] + (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method) argsA)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))))) + +(exception: #export Not-Interface) + +(def: (invoke//interface proc) + (-> Text @;Proc) + (function [analyse args] + (case (: (R;Result [(List Code) [Text Text Code (List [Text Code]) Unit]]) + (p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!))) + (#R;Success [_ [class-name method objectC argsTC _]]) + (do macro;Monad<Lux> + [class (load-class class-name) + _ (&;assert (Not-Interface class-name) + (Modifier.isInterface [(Class.getModifiers [] class)])) + [methodT exceptionsT] (methods class-name method #Interface (list/map product;left argsTC)) + [outputT argsA] (&inference;apply-function analyse methodT (list& objectC (list/map product;right argsTC))) + _ (&;infer outputT)] + (wrap (#la;Procedure proc (list& (#la;Text class-name) (#la;Text method) argsA)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))))) + +(def: (invoke//constructor proc) + (-> Text @;Proc) + (function [analyse args] + (case (: (R;Result [(List Code) [Text (List [Text Code]) Unit]]) + (p;run args ($_ p;seq s;text (p;some (s;tuple (p;seq s;text s;any))) s;end!))) + (#R;Success [_ [class argsTC _]]) + (do macro;Monad<Lux> + [[methodT exceptionsT] (constructor-methods class (list/map product;left argsTC)) + [outputT argsA] (&inference;apply-function analyse methodT (list/map product;right argsTC)) + _ (&;infer outputT)] + (wrap (#la;Procedure proc (list& (#la;Text class) argsA)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))))) + (def: member-procs @;Bundle (<| (@;prefix "member") @@ -838,6 +1142,14 @@ (|> (dict;new text;Hash<Text>) (@;install "get" virtual-get) (@;install "put" virtual-put)))) + (dict;merge (<| (@;prefix "invoke") + (|> (dict;new text;Hash<Text>) + (@;install "static" invoke//static) + (@;install "virtual" invoke//virtual) + (@;install "special" invoke//special) + (@;install "interface" invoke//interface) + (@;install "constructor" invoke//constructor) + ))) ))) (def: #export procedures |