aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/analyser
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/analyser')
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux176
1 files changed, 119 insertions, 57 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index ff4f0f3d6..d4029b15b 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -201,9 +201,7 @@
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))
-(def: (not-object type)
- (-> Type Text)
- (format "Non-object type: " (%type type)))
+(exception: #export Not-Object-Type)
(def: (check-jvm objectT)
(-> Type (Meta Text))
@@ -214,6 +212,9 @@
(#;Named name unnamed)
(check-jvm unnamed)
+ (#;Var id)
+ (meta/wrap "java.lang.Object")
+
(^template [<tag>]
(<tag> env unquantified)
(check-jvm unquantified))
@@ -226,10 +227,10 @@
(check-jvm outputT)
#;None
- (&;fail (not-object objectT)))
+ (&;throw Not-Object-Type (%type objectT)))
_
- (&;fail (not-object objectT))))
+ (&;throw Not-Object-Type (%type objectT))))
(def: (check-object objectT)
(-> Type (Meta Text))
@@ -627,6 +628,24 @@
#In to
#Out from))
+(def: (correspond-type-params class type)
+ (-> (Class Object) Type (Meta Mappings))
+ (case type
+ (#;Host name params)
+ (let [class-name (Class.getName [] class)
+ class-params (array;to-list (Class.getTypeParameters [] class))]
+ (if (text/= class-name name)
+ (if (n.= (list;size class-params)
+ (list;size params))
+ (meta/wrap (|> params
+ (list;zip2 (list/map (TypeVariable.getName []) class-params))
+ (dict;from-list text;Hash<Text>)))
+ (&;fail (format "Class and host-type parameters do not match: " "class = " class-name " | host type = " name)))
+ (&;fail (format "Class and host-type names do not match: " "class = " class-name " | host type = " name))))
+
+ _
+ (&;fail (format "Not a host type: " (%type type)))))
+
(def: (cast direction to from)
(-> Direction Type Type (Meta [Text Type]))
(do meta;Monad<Meta>
@@ -661,7 +680,7 @@
(do @
[class-name (java-type-to-class java-type)
class (load-class class-name)]
- (wrap [java-type (Class.isAssignableFrom [from-class] to-class)])))
+ (wrap [java-type (Class.isAssignableFrom [class] to-class)])))
(list& (Class.getGenericSuperclass [] from-class)
(array;to-list (Class.getGenericInterfaces [] from-class))))]
(case (|> candiate-parents
@@ -669,13 +688,23 @@
(list/map product;left))
(#;Cons parent _)
(do @
- [parentT (java-type-to-lux-type fresh-mappings parent)
+ [mapping (correspond-type-params from-class from)
+ parentT (java-type-to-lux-type mapping parent)
[_ castT] (cast direction to parentT)]
(wrap [(choose direction to-name from-name) castT]))
#;Nil
(&;fail (format "No valid path between " (%type from) "and " (%type to) ".")))))))
+(def: (infer-out outputT)
+ (-> Type (Meta [Text Type]))
+ (do meta;Monad<Meta>
+ [expectedT meta;expected-type
+ [unboxed castT] (cast #Out expectedT outputT)
+ _ (&;with-type-env
+ (tc;check expectedT castT))]
+ (wrap [unboxed castT])))
+
(def: (find-field class-name field-name)
(-> Text Text (Meta [(Class Object) Field]))
(do meta;Monad<Meta>
@@ -771,10 +800,7 @@
[[_ (#;Text class)] [_ (#;Text field)]]
(do meta;Monad<Meta>
[[fieldT final?] (static-field class field)
- expectedT meta;expected-type
- [unboxed castT] (cast #Out expectedT fieldT)
- _ (&;with-type-env
- (tc;check expectedT castT))]
+ [unboxed castT] (infer-out fieldT)]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed)))))
_
@@ -816,10 +842,7 @@
(do meta;Monad<Meta>
[[objectT objectA] (analyse-object class analyse objectC)
[fieldT final?] (virtual-field class field objectT)
- expectedT meta;expected-type
- [unboxed castT] (cast #Out expectedT fieldT)
- _ (&;with-type-env
- (tc;check expectedT castT))]
+ [unboxed castT] (infer-out fieldT)]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) objectA))))
_
@@ -864,6 +887,11 @@
(host;instance? WildcardType type))
(meta/wrap "java.lang.Object")
+ (host;instance? GenericArrayType type)
+ (do meta;Monad<Meta>
+ [componentP (java-type-to-parameter (GenericArrayType.getGenericComponentType [] (:! GenericArrayType type)))]
+ (wrap (format componentP "[]")))
+
## else
(&;throw Cannot-Convert-To-Parameter (type-descriptor type))))
@@ -921,6 +949,13 @@
(-> Nat Type)
(|>. (n.* +2) n.inc #;Bound))
+(def: (type-vars amount offset)
+ (-> Nat Nat (List Type))
+ (if (n.= +0 amount)
+ (list)
+ (|> (list;n.range offset (|> amount n.dec (n.+ offset)))
+ (list/map idx-to-bound))))
+
(def: (method-to-type method-type method)
(-> Method-Type Method (Meta [Type (List Type)]))
(let [owner (Method.getDeclaringClass [] method)
@@ -937,10 +972,11 @@
array;to-list
(list/map (TypeVariable.getName [])))
num-owner-tvars (list;size owner-tvars)
+ num-method-tvars (list;size method-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))
+ owner-tvarsT (type-vars num-owner-tvars +0)
+ method-tvarsT (type-vars num-method-tvars num-owner-tvars)
mappings (: Mappings
(if (list;empty? all-tvars)
fresh-mappings
@@ -951,11 +987,11 @@
(do meta;Monad<Meta>
[inputsT (|> (Method.getGenericParameterTypes [] method)
array;to-list
- (monad;map @ (java-type-to-lux-type fresh-mappings)))
+ (monad;map @ (java-type-to-lux-type 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)))
+ (monad;map @ (java-type-to-lux-type mappings)))
#let [methodT (<| (type;univ-q num-all-tvars)
(type;function (case method-type
#Static
@@ -1004,8 +1040,8 @@
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))
+ owner-tvarsT (type-vars num-owner-tvars +0)
+ constructor-tvarsT (type-vars num-all-tvars num-owner-tvars)
mappings (: Mappings
(if (list;empty? all-tvars)
fresh-mappings
@@ -1016,10 +1052,10 @@
(do meta;Monad<Meta>
[inputsT (|> (Constructor.getGenericParameterTypes [] constructor)
array;to-list
- (monad;map @ (java-type-to-lux-type fresh-mappings)))
+ (monad;map @ (java-type-to-lux-type mappings)))
exceptionsT (|> (Constructor.getGenericExceptionTypes [] constructor)
array;to-list
- (monad;map @ (java-type-to-lux-type fresh-mappings)))
+ (monad;map @ (java-type-to-lux-type mappings)))
#let [objectT (#;Host owner-name (list;reverse owner-tvarsT))
constructorT (<| (type;univ-q num-all-tvars)
(type;function inputsT)
@@ -1042,7 +1078,7 @@
(wrap [passes? constructor])))))]
(case (list;filter product;left candidates)
#;Nil
- (&;throw No-Candidate-Constructor class-name)
+ (&;throw No-Candidate-Constructor (format class-name "(" (text;join-with ", " arg-classes) ")"))
(#;Cons candidate #;Nil)
(|> candidate product;right constructor-to-type)
@@ -1050,17 +1086,35 @@
_
(&;throw Too-Many-Candidate-Constructors class-name))))
+(def: (decorate-inputs typesT inputsA)
+ (-> (List Text) (List la;Analysis) (List la;Analysis))
+ (|> inputsA
+ (list;zip2 (list/map (|>. #la;Text) typesT))
+ (list/map (|>. #la;Product))))
+
+(def: (sub-type-analyser analyse)
+ (-> &;Analyser &;Analyser)
+ (function [argC]
+ (do meta;Monad<Meta>
+ [[argT argA] (&common;with-unknown-type
+ (analyse argC))
+ expectedT meta;expected-type
+ [unboxed castT] (cast #In expectedT argT)]
+ (wrap argA))))
+
(def: (invoke//static proc)
(-> Text @;Proc)
(function [analyse args]
- (case (: (e;Error [(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!)))
- (#e;Success [_ [class method argsTC _]])
+ (case (: (e;Error [Text Text (List [Text Code])])
+ (s;run args ($_ p;seq s;text s;text (p;some (s;tuple (p;seq s;text s;any))))))
+ (#e;Success [class method argsTC])
(do meta;Monad<Meta>
- [[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))))
+ [#let [argsT (list/map product;left argsTC)]
+ [methodT exceptionsT] (methods class method #Static argsT)
+ [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
+ (#la;Text unboxed) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1068,14 +1122,16 @@
(def: (invoke//virtual proc)
(-> Text @;Proc)
(function [analyse args]
- (case (: (e;Error [(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!)))
- (#e;Success [_ [class method objectC argsTC _]])
+ (case (: (e;Error [Text Text Code (List [Text Code])])
+ (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))))))
+ (#e;Success [class method objectC argsTC])
(do meta;Monad<Meta>
- [[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))))
+ [#let [argsT (list/map product;left argsTC)]
+ [methodT exceptionsT] (methods class method #Virtual argsT)
+ [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
+ (#la;Text unboxed) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1087,10 +1143,12 @@
(p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!)))
(#e;Success [_ [class method objectC argsTC _]])
(do meta;Monad<Meta>
- [[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))))
+ [#let [argsT (list/map product;left argsTC)]
+ [methodT exceptionsT] (methods class method #Special argsT)
+ [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
+ (#la;Text unboxed) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1100,17 +1158,19 @@
(def: (invoke//interface proc)
(-> Text @;Proc)
(function [analyse args]
- (case (: (e;Error [(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!)))
- (#e;Success [_ [class-name method objectC argsTC _]])
+ (case (: (e;Error [Text Text Code (List [Text Code])])
+ (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))))))
+ (#e;Success [class-name method objectC argsTC])
(do meta;Monad<Meta>
- [class (load-class class-name)
+ [#let [argsT (list/map product;left argsTC)]
+ 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))))
+ [methodT exceptionsT] (methods class-name method #Interface argsT)
+ [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (#la;Procedure proc (list& (#la;Text class-name) (#la;Text method)
+ (#la;Text unboxed) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1118,14 +1178,16 @@
(def: (invoke//constructor proc)
(-> Text @;Proc)
(function [analyse args]
- (case (: (e;Error [(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!)))
- (#e;Success [_ [class argsTC _]])
+ (case (: (e;Error [Text (List [Text Code])])
+ (s;run args ($_ p;seq s;text (p;some (s;tuple (p;seq s;text s;any))))))
+ (#e;Success [class argsTC])
(do meta;Monad<Meta>
- [[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))))
+ [#let [argsT (list/map product;left argsTC)]
+ [methodT exceptionsT] (constructor-methods class argsT)
+ [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (#la;Procedure proc (list& (#la;Text class)
+ (#la;Text unboxed) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 02:21:02 +0000