diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/common.lux | 3 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/function.lux | 19 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/inference.lux | 50 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux | 49 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/structure.lux | 4 |
5 files changed, 53 insertions, 72 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux index 1eb2b8b37..b14524559 100644 --- a/new-luxc/source/luxc/lang/analysis/common.lux +++ b/new-luxc/source/luxc/lang/analysis/common.lux @@ -13,8 +13,7 @@ (def: #export (with-unknown-type action) (All [a] (-> (Meta Analysis) (Meta [Type Analysis]))) (do meta;Monad<Meta> - [[var-id var-type] (&;with-type-env - tc;var) + [[var-id var-type] (&;with-type-env tc;var) analysis (&;with-expected-type var-type action) analysis-type (&;with-type-env diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux index 0bb46aba1..2a9826683 100644 --- a/new-luxc/source/luxc/lang/analysis/function.lux +++ b/new-luxc/source/luxc/lang/analysis/function.lux @@ -39,17 +39,14 @@ #;None (&;throw Invalid-Function-Type (%type expectedT))) - - (#;UnivQ _) - (do @ - [[var-id var] (&;with-type-env - tc;existential)] - (recur (maybe;assume (type;apply (list var) expectedT)))) - (#;ExQ _) - (do @ - [[var-id var] (&;with-type-env tc;var)] - (recur (maybe;assume (type;apply (list var) expectedT)))) + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[_ instanceT] (&;with-type-env <instancer>)] + (recur (maybe;assume (type;apply (list instanceT) expectedT))))) + ([#;UnivQ tc;existential] + [#;ExQ tc;var]) (#;Var id) (do @ @@ -106,5 +103,5 @@ (format "\n " (%n idx) " " (%code argC)))) (text;join-with ""))))) (do meta;Monad<Meta> - [[applyT argsA] (&inference;apply-function analyse funcT args)] + [[applyT argsA] (&inference;general analyse funcT args)] (wrap (la;apply argsA funcA))))) diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux index 934ecafa5..5152de0b6 100644 --- a/new-luxc/source/luxc/lang/analysis/inference.lux +++ b/new-luxc/source/luxc/lang/analysis/inference.lux @@ -6,7 +6,7 @@ [text] text/format (coll [list "list/" Functor<List>])) - [meta #+ Monad<Meta>] + [meta "meta/" Monad<Meta>] (meta [type] (type ["tc" check]))) (luxc ["&" base] @@ -95,23 +95,23 @@ ## tagged variants). ## But, so long as the type being used for the inference can be treated ## as a function type, this method of inference should work. -(def: #export (apply-function analyse inferT args) +(def: #export (general analyse inferT args) (-> &;Analyser Type (List Code) (Meta [Type (List Analysis)])) (case args #;Nil - (do Monad<Meta> + (do meta;Monad<Meta> [_ (&;infer inferT)] (wrap [inferT (list)])) (#;Cons argC args') (case inferT (#;Named name unnamedT) - (apply-function analyse unnamedT args) + (general analyse unnamedT args) (#;UnivQ _) - (do Monad<Meta> + (do meta;Monad<Meta> [[var-id varT] (&;with-type-env tc;var) - [outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) inferT)) args)] + [outputT argsA] (general analyse (maybe;assume (type;apply (list varT) inferT)) args)] (do @ [? (&;with-type-env (tc;concrete? var-id)) @@ -124,15 +124,15 @@ (wrap [outputT' argsA]))) (#;ExQ _) - (do Monad<Meta> + (do meta;Monad<Meta> [[ex-id exT] (&;with-type-env tc;existential)] - (apply-function analyse (maybe;assume (type;apply (list exT) inferT)) args)) + (general analyse (maybe;assume (type;apply (list exT) inferT)) args)) (#;Apply inputT transT) (case (type;apply (list inputT) transT) (#;Some outputT) - (apply-function analyse outputT args) + (general analyse outputT args) #;None (&;throw Invalid-Type-Application (%type inferT))) @@ -145,8 +145,8 @@ ## avoided in Lux code, since the inference algorithm can piece ## things together more easily. (#;Function inputT outputT) - (do Monad<Meta> - [[outputT' args'A] (apply-function analyse outputT args') + (do meta;Monad<Meta> + [[outputT' args'A] (general analyse outputT args') argA (&;with-stacked-errors (function [_] (Cannot-Infer-Argument (format "Inferred Type: " (%type inputT) "\n" @@ -174,14 +174,14 @@ (^template [<tag>] (<tag> env bodyT) - (do Monad<Meta> + (do meta;Monad<Meta> [bodyT+ (record bodyT)] (wrap (<tag> env bodyT+)))) ([#;UnivQ] [#;ExQ]) (#;Product _) - (:: Monad<Meta> wrap (type;function (type;flatten-tuple type) type)) + (meta/wrap (type;function (type;flatten-tuple type) type)) _ (&;throw Not-A-Record-Type (%type type)))) @@ -193,13 +193,13 @@ currentT type] (case currentT (#;Named name unnamedT) - (do Monad<Meta> + (do meta;Monad<Meta> [unnamedT+ (recur depth unnamedT)] (wrap unnamedT+)) (^template [<tag>] (<tag> env bodyT) - (do Monad<Meta> + (do meta;Monad<Meta> [bodyT+ (recur (n.inc depth) bodyT)] (wrap (<tag> env bodyT+)))) ([#;UnivQ] @@ -214,11 +214,11 @@ (n.< boundary tag))) (case (list;nth tag cases) (#;Some caseT) - (:: Monad<Meta> wrap (if (n.= +0 depth) - (type;function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] - (type;function (list (replace! caseT)) - (replace! currentT))))) + (meta/wrap (if (n.= +0 depth) + (type;function (list caseT) currentT) + (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] + (type;function (list (replace! caseT)) + (replace! currentT))))) #;None (&common;variant-out-of-bounds-error type expected-size tag)) @@ -230,11 +230,11 @@ (n.= boundary tag) (let [caseT (type;variant (list;drop boundary cases))] - (:: Monad<Meta> wrap (if (n.= +0 depth) - (type;function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] - (type;function (list (replace! caseT)) - (replace! currentT)))))) + (meta/wrap (if (n.= +0 depth) + (type;function (list caseT) currentT) + (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] + (type;function (list (replace! caseT)) + (replace! currentT)))))) ## else (&common;variant-out-of-bounds-error type expected-size tag))) diff --git a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux index fa10a7a1c..39ca0eb43 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux @@ -24,7 +24,7 @@ ["&;" host] (lang ["la" analysis] (analysis ["&;" common] - ["&;" inference]))) + [";A" inference]))) ["@" ../common] ) @@ -367,11 +367,8 @@ (^ (list objectC)) (do meta;Monad<Meta> [_ (&;infer Bool) - [var-id varT] (&;with-type-env tc;var) - objectA (&;with-expected-type varT - (analyse objectC)) - objectT (&;with-type-env - (tc;read var-id)) + [objectT objectA] (&common;with-unknown-type + (analyse objectC)) _ (check-object objectT)] (wrap (la;procedure proc (list objectA)))) @@ -384,11 +381,8 @@ (case args (^ (list monitorC exprC)) (do meta;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - monitorA (&;with-expected-type varT - (analyse monitorC)) - monitorT (&;with-type-env - (tc;read var-id)) + [[monitorT monitorA] (&common;with-unknown-type + (analyse monitorC)) _ (check-object monitorT) exprA (analyse exprC)] (wrap (la;procedure proc (list monitorA exprA)))) @@ -483,11 +477,8 @@ (^ (list exceptionC)) (do meta;Monad<Meta> [_ (&;infer Bottom) - [var-id varT] (&;with-type-env tc;var) - exceptionA (&;with-expected-type varT - (analyse exceptionC)) - exceptionT (&;with-type-env - (tc;read var-id)) + [exceptionT exceptionA] (&common;with-unknown-type + (analyse exceptionC)) exception-class (check-object exceptionT) ? (sub-class? "java.lang.Throwable" exception-class) _ (: (Meta Unit) @@ -793,15 +784,12 @@ (def: (analyse-object class analyse sourceC) (-> Text &;Analyser Code (Meta [Type la;Analysis])) (do meta;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - target-class (load-class class) + [target-class (load-class class) targetT (java-type-to-lux-type fresh-mappings (:! java.lang.reflect.Type target-class)) - sourceA (&;with-expected-type varT - (analyse sourceC)) - sourceT (&;with-type-env - (tc;read var-id)) + [sourceT sourceA] (&common;with-unknown-type + (analyse sourceC)) [unboxed castT] (cast #Out targetT sourceT) _ (&;assert Cannot-Cast (cannot-cast targetT sourceT) (not (dict;contains? unboxed boxes)))] @@ -810,11 +798,8 @@ (def: (analyse-input analyse targetT sourceC) (-> &;Analyser Type Code (Meta [Type Text la;Analysis])) (do meta;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - sourceA (&;with-expected-type varT - (analyse sourceC)) - sourceT (&;with-type-env - (tc;read var-id)) + [[sourceT sourceA] (&common;with-unknown-type + (analyse sourceC)) [unboxed castT] (cast #In targetT sourceT)] (wrap [castT unboxed sourceA]))) @@ -1134,7 +1119,7 @@ (do meta;Monad<Meta> [#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)) + [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC)) [unboxed castT] (infer-out outputT)] (wrap (la;procedure proc (list& (code;text class) (code;text method) (code;text unboxed) (decorate-inputs argsT argsA))))) @@ -1151,7 +1136,7 @@ (do meta;Monad<Meta> [#let [argsT (list/map product;left argsTC)] [methodT exceptionsT] (methods class method #Virtual argsT) - [outputT allA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [outputT allA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) #let [[objectA argsA] (case allA (#;Cons objectA argsA) [objectA argsA] @@ -1174,7 +1159,7 @@ (do meta;Monad<Meta> [#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))) + [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) [unboxed castT] (infer-out outputT)] (wrap (la;procedure proc (list& (code;text class) (code;text method) (code;text unboxed) (decorate-inputs argsT argsA))))) @@ -1194,7 +1179,7 @@ _ (&;assert Non-Interface class-name (Modifier.isInterface [(Class.getModifiers [] class)])) [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))) + [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) [unboxed castT] (infer-out outputT)] (wrap (la;procedure proc (list& (code;text class-name) (code;text method) (code;text unboxed) @@ -1212,7 +1197,7 @@ (do meta;Monad<Meta> [#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)) + [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC)) [unboxed castT] (infer-out outputT)] (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA))))) diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux index b7047e105..e1f4de1d7 100644 --- a/new-luxc/source/luxc/lang/analysis/structure.lux +++ b/new-luxc/source/luxc/lang/analysis/structure.lux @@ -217,7 +217,7 @@ (do @ [#let [case-size (list;size group)] inferenceT (&inference;variant idx case-size variantT) - [inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC)) + [inferredT valueA+] (&inference;general analyse inferenceT (list valueC)) temp &scope;next-local] (wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume)))) @@ -303,7 +303,7 @@ (#;Var _) (do @ [inferenceT (&inference;record recordT) - [inferredT membersA] (&inference;apply-function analyse inferenceT membersC)] + [inferredT membersA] (&inference;general analyse inferenceT membersC)] (wrap (la;product membersA))) _ |