diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/analysis/procedure')
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/procedure/common.lux | 183 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux | 514 |
2 files changed, 348 insertions, 349 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux index 778e57b94..fff5de504 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux @@ -1,6 +1,7 @@ (;module: lux - (lux (control [monad #+ do]) + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) (concurrency [atom #+ Atom]) (data [text] text/format @@ -18,6 +19,8 @@ [";A" case] [";A" type])))) +(exception: #export Incorrect-Procedure-Arity) + ## [Utils] (type: #export Proc (-> &;Analyser &;Eval (List Code) (Meta la;Analysis))) @@ -39,27 +42,25 @@ (def: #export (wrong-arity proc expected actual) (-> Text Nat Nat Text) - (format "Wrong arity for " (%t proc) "\n" - "Expected: " (|> expected nat-to-int %i) "\n" - " Actual: " (|> actual nat-to-int %i))) + (format " Procedure: " (%t proc) "\n" + " Expected Arity: " (|> expected nat-to-int %i) "\n" + " Actual Arity: " (|> actual nat-to-int %i))) -(def: (simple proc input-types output-type) +(def: (simple proc inputsT+ outputT) (-> Text (List Type) Type Proc) - (let [num-expected (list;size input-types)] + (let [num-expected (list;size inputsT+)] (function [analyse eval args] (let [num-actual (list;size args)] (if (n.= num-expected num-actual) (do meta;Monad<Meta> - [argsA (monad;map @ + [_ (&;infer outputT) + argsA (monad;map @ (function [[argT argC]] (&;with-expected-type argT (analyse argC))) - (list;zip2 input-types args)) - expected meta;expected-type - _ (&;with-type-env - (tc;check expected output-type))] + (list;zip2 inputsT+ args))] (wrap (la;procedure proc argsA))) - (&;fail (wrong-arity proc num-expected num-actual))))))) + (&;throw Incorrect-Procedure-Arity (wrong-arity proc num-expected num-actual))))))) (def: #export (nullary valueT proc) (-> Type Text Proc) @@ -82,71 +83,60 @@ (def: (lux-is proc) (-> Text Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - ((binary varT varT Bool proc) - analyse eval args))))) + (do meta;Monad<Meta> + [[var-id varT] (&;with-type-env tc;var)] + ((binary varT varT Bool proc) + analyse eval args)))) ## "lux try" provides a simple way to interact with the host platform's ## error-handling facilities. (def: (lux-try proc) (-> Text Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list opC)) - (do meta;Monad<Meta> - [opA (&;with-expected-type (type (io;IO varT)) - (analyse opC)) - outputT (&;with-type-env - (tc;clean var-id (type (Either Text varT)))) - expected meta;expected-type - _ (&;with-type-env - (tc;check expected outputT))] - (wrap (la;procedure proc (list opA)))) - - _ - (&;fail (wrong-arity proc +1 (list;size args)))))))) + (case args + (^ (list opC)) + (do meta;Monad<Meta> + [[var-id varT] (&;with-type-env tc;var) + _ (&;infer (type (Either Text varT))) + opA (&;with-expected-type (type (io;IO varT)) + (analyse opC))] + (wrap (la;procedure proc (list opA)))) + + _ + (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args)))))) (def: (lux//function proc) (-> Text Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list [_ (#;Symbol ["" func-name])] - [_ (#;Symbol ["" arg-name])] - body)) - (functionA;analyse-function analyse func-name arg-name body) - - _ - (&;fail (wrong-arity proc +3 (list;size args)))))))) + (case args + (^ (list [_ (#;Symbol ["" func-name])] + [_ (#;Symbol ["" arg-name])] + body)) + (functionA;analyse-function analyse func-name arg-name body) + + _ + (&;throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list;size args)))))) (def: (lux//case proc) (-> Text Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list input [_ (#;Record branches)])) - (caseA;analyse-case analyse input branches) - - _ - (&;fail (wrong-arity proc +2 (list;size args)))))))) + (case args + (^ (list input [_ (#;Record branches)])) + (caseA;analyse-case analyse input branches) + + _ + (&;throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list;size args)))))) (do-template [<name> <analyser>] [(def: (<name> proc) (-> Text Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list typeC valueC)) - (<analyser> analyse eval typeC valueC) - - _ - (&;fail (wrong-arity proc +2 (list;size args))))))))] + (case args + (^ (list typeC valueC)) + (<analyser> analyse eval typeC valueC) + + _ + (&;throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list;size args))))))] [lux//check typeA;analyse-check] [lux//coerce typeA;analyse-coerce]) @@ -193,15 +183,13 @@ (case args (^ (list valueC)) (do meta;Monad<Meta> - [valueA (&;with-expected-type Type - (analyse valueC)) - expected meta;expected-type - _ (&;with-type-env - (tc;check expected Type))] + [_ (&;infer (type Type)) + valueA (&;with-expected-type Type + (analyse valueC))] (wrap valueA)) _ - (&;fail (wrong-arity proc +1 (list;size args)))))) + (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args)))))) (def: lux-procs Bundle @@ -326,26 +314,26 @@ (def: (array-get proc) (-> Text Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - ((binary Nat (type (Array varT)) varT proc) - analyse eval args))))) + (do meta;Monad<Meta> + [[var-id varT] (&;with-type-env tc;var)] + ((binary Nat (type (Array varT)) varT proc) + analyse eval args)))) (def: (array-put proc) (-> Text Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc) - analyse eval args))))) + (do meta;Monad<Meta> + [[var-id varT] (&;with-type-env tc;var)] + ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc) + analyse eval args)))) (def: (array-remove proc) (-> Text Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - ((binary Nat (type (Array varT)) (type (Array varT)) proc) - analyse eval args))))) + (do meta;Monad<Meta> + [[var-id varT] (&;with-type-env tc;var)] + ((binary Nat (type (Array varT)) (type (Array varT)) proc) + analyse eval args)))) (def: array-procs Bundle @@ -385,38 +373,33 @@ (def: (atom-new proc) (-> Text Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list initC)) - (do meta;Monad<Meta> - [initA (&;with-expected-type varT - (analyse initC)) - outputT (&;with-type-env - (tc;clean var-id (type (Atom varT)))) - expected meta;expected-type - _ (&;with-type-env - (tc;check expected outputT))] - (wrap (la;procedure proc (list initA)))) - - _ - (&;fail (wrong-arity proc +1 (list;size args)))))))) + (case args + (^ (list initC)) + (do meta;Monad<Meta> + [[var-id varT] (&;with-type-env tc;var) + _ (&;infer (type (Atom varT))) + initA (&;with-expected-type varT + (analyse initC))] + (wrap (la;procedure proc (list initA)))) + + _ + (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args)))))) (def: (atom-read proc) (-> Text Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - ((unary (type (Atom varT)) varT proc) - analyse eval args))))) + (do meta;Monad<Meta> + [[var-id varT] (&;with-type-env tc;var)] + ((unary (type (Atom varT)) varT proc) + analyse eval args)))) (def: (atom-compare-and-swap proc) (-> Text Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - ((trinary varT varT (type (Atom varT)) Bool proc) - analyse eval args))))) + (do meta;Monad<Meta> + [[var-id varT] (&;with-type-env tc;var)] + ((trinary varT varT (type (Atom varT)) Bool proc) + analyse eval args)))) (def: atom-procs Bundle 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 3ba7713ac..fa10a7a1c 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux @@ -28,6 +28,49 @@ ["@" ../common] ) +(exception: #export Wrong-Syntax) +(def: (wrong-syntax procedure args) + (-> Text (List Code) Text) + (format "Procedure: " procedure "\n" + "Arguments: " (%code (code;tuple args)))) + +(exception: #export JVM-Type-Is-Not-Class) + +(exception: #export Non-Interface) +(exception: #export Non-Object) +(exception: #export Non-Array) +(exception: #export Non-Throwable) +(exception: #export Non-JVM-Type) + +(exception: #export Unknown-Class) +(exception: #export Primitives-Cannot-Have-Type-Parameters) +(exception: #export Primitives-Are-Not-Objects) +(exception: #export Invalid-Type-For-Array-Element) + +(exception: #export Unknown-Field) +(exception: #export Mistaken-Field-Owner) +(exception: #export Not-Virtual-Field) +(exception: #export Not-Static-Field) +(exception: #export Cannot-Set-Final-Field) + +(exception: #export No-Candidates) +(exception: #export Too-Many-Candidates) + +(exception: #export Cannot-Cast) +(def: (cannot-cast to from) + (-> Type Type Text) + (format "From: " (%type from) "\n" + " To: " (%type to))) + +(exception: #export Cannot-Possibly-Be-Instance) + +(exception: #export Cannot-Convert-To-Class) +(exception: #export Cannot-Convert-To-Parameter) +(exception: #export Cannot-Convert-To-Lux-Type) +(exception: #export Unknown-Type-Var) +(exception: #export Type-Parameter-Mismatch) +(exception: #export Cannot-Correspond-Type-With-Class) + (def: #export null-class Text "#Null") (do-template [<name> <class>] @@ -149,22 +192,17 @@ (def: (array-length proc) (-> Text @;Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list arrayC)) - (do meta;Monad<Meta> - [arrayA (&;with-expected-type (type (Array varT)) - (analyse arrayC)) - _ (&;infer Nat)] - (wrap (la;procedure proc (list arrayA)))) - - _ - (&;fail (@;wrong-arity proc +1 (list;size args)))))))) - -(def: (invalid-array-type arrayT) - (-> Type Text) - (format "Invalid type for array: " (%type arrayT))) + (case args + (^ (list arrayC)) + (do meta;Monad<Meta> + [_ (&;infer Nat) + [var-id varT] (&;with-type-env tc;var) + arrayA (&;with-expected-type (type (Array varT)) + (analyse arrayC))] + (wrap (la;procedure proc (list arrayA)))) + + _ + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) (def: (array-new proc) (-> Text @;Proc) @@ -185,7 +223,7 @@ (recur outputT level) #;None - (&;fail (invalid-array-type expectedT))) + (&;throw Non-Array (%type expectedT))) (^ (#;Primitive "#Array" (list elemT))) (recur elemT (n.inc level)) @@ -194,15 +232,14 @@ (wrap [level class]) _ - (&;fail (invalid-array-type expectedT))))) - _ (&;assert "Must have at least 1 level of nesting in array type." - (n.> +0 level))] + (&;throw Non-Array (%type expectedT))))) + _ (if (n.> +0 level) + (wrap []) + (&;throw Non-Array (%type expectedT)))] (wrap (la;procedure proc (list (code;nat (n.dec level)) (code;text elem-class) lengthA)))) _ - (&;fail (@;wrong-arity proc +1 (list;size args)))))) - -(exception: #export Not-Object-Type) + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) (def: (check-jvm objectT) (-> Type (Meta Text)) @@ -228,81 +265,77 @@ (check-jvm outputT) #;None - (&;throw Not-Object-Type (%type objectT))) + (&;throw Non-Object (%type objectT))) _ - (&;throw Not-Object-Type (%type objectT)))) + (&;throw Non-Object (%type objectT)))) (def: (check-object objectT) (-> Type (Meta Text)) (do meta;Monad<Meta> [name (check-jvm objectT)] (if (dict;contains? name boxes) - (&;fail (format "Primitives are not objects: " name)) - (:: meta;Monad<Meta> wrap name)))) + (&;throw Primitives-Are-Not-Objects name) + (meta/wrap name)))) (def: (box-array-element-type elemT) (-> Type (Meta [Type Text])) - (do meta;Monad<Meta> - [] - (case elemT - (#;Primitive name #;Nil) - (let [boxed-name (|> (dict;get name boxes) - (maybe;default name))] - (wrap [(#;Primitive boxed-name #;Nil) - boxed-name])) - - (#;Primitive name _) - (if (dict;contains? name boxes) - (&;fail (format "Primitives cannot be parameterized: " name)) - (:: meta;Monad<Meta> wrap [elemT name])) + (case elemT + (#;Primitive name #;Nil) + (let [boxed-name (|> (dict;get name boxes) + (maybe;default name))] + (meta/wrap [(#;Primitive boxed-name #;Nil) + boxed-name])) - _ - (&;fail (format "Invalid type for array element: " (%type elemT)))))) + (#;Primitive name _) + (if (dict;contains? name boxes) + (&;throw Primitives-Cannot-Have-Type-Parameters name) + (meta/wrap [elemT name])) + + _ + (&;throw Invalid-Type-For-Array-Element (%type elemT)))) (def: (array-read proc) (-> Text @;Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list arrayC idxC)) - (do meta;Monad<Meta> - [arrayA (&;with-expected-type (type (Array varT)) - (analyse arrayC)) - elemT (&;with-type-env - (tc;read var-id)) - [elemT elem-class] (box-array-element-type elemT) - idxA (&;with-expected-type Nat - (analyse idxC)) - _ (&;infer elemT)] - (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA)))) - - _ - (&;fail (@;wrong-arity proc +2 (list;size args)))))))) + (case args + (^ (list arrayC idxC)) + (do meta;Monad<Meta> + [[var-id varT] (&;with-type-env tc;var) + _ (&;infer varT) + arrayA (&;with-expected-type (type (Array varT)) + (analyse arrayC)) + elemT (&;with-type-env + (tc;read var-id)) + [elemT elem-class] (box-array-element-type elemT) + idxA (&;with-expected-type Nat + (analyse idxC))] + (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA)))) + + _ + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) (def: (array-write proc) (-> Text @;Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list arrayC idxC valueC)) - (do meta;Monad<Meta> - [arrayA (&;with-expected-type (type (Array varT)) - (analyse arrayC)) - elemT (&;with-type-env - (tc;read var-id)) - [valueT elem-class] (box-array-element-type elemT) - idxA (&;with-expected-type Nat - (analyse idxC)) - valueA (&;with-expected-type valueT - (analyse valueC)) - _ (&;infer (type (Array elemT)))] - (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA)))) - - _ - (&;fail (@;wrong-arity proc +3 (list;size args)))))))) + (case args + (^ (list arrayC idxC valueC)) + (do meta;Monad<Meta> + [[var-id varT] (&;with-type-env tc;var) + _ (&;infer (type (Array varT))) + arrayA (&;with-expected-type (type (Array varT)) + (analyse arrayC)) + elemT (&;with-type-env + (tc;read var-id)) + [valueT elem-class] (box-array-element-type elemT) + idxA (&;with-expected-type Nat + (analyse idxC)) + valueA (&;with-expected-type valueT + (analyse valueC))] + (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA)))) + + _ + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args)))))) (def: array-procs @;Bundle @@ -325,45 +358,43 @@ (wrap (la;procedure proc (list)))) _ - (&;fail (@;wrong-arity proc +0 (list;size args)))))) + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +0 (list;size args)))))) (def: (object-null? proc) (-> Text @;Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list objectC)) - (do meta;Monad<Meta> - [objectA (&;with-expected-type varT - (analyse objectC)) - objectT (&;with-type-env - (tc;read var-id)) - _ (check-object objectT) - _ (&;infer Bool)] - (wrap (la;procedure proc (list objectA)))) - - _ - (&;fail (@;wrong-arity proc +1 (list;size args)))))))) + (case args + (^ (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)) + _ (check-object objectT)] + (wrap (la;procedure proc (list objectA)))) + + _ + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) (def: (object-synchronized proc) (-> Text @;Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list monitorC exprC)) - (do meta;Monad<Meta> - [monitorA (&;with-expected-type varT - (analyse monitorC)) - monitorT (&;with-type-env - (tc;read var-id)) - _ (check-object monitorT) - exprA (analyse exprC)] - (wrap (la;procedure proc (list monitorA exprA)))) - - _ - (&;fail (@;wrong-arity proc +2 (list;size args)))))))) + (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)) + _ (check-object monitorT) + exprA (analyse exprC)] + (wrap (la;procedure proc (list monitorA exprA)))) + + _ + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) (host;import java.lang.Object (equals [Object] boolean)) @@ -436,7 +467,7 @@ (wrap class) (#e;Error error) - (&;fail (format "Unknown class: " name))))) + (&;throw Unknown-Class name)))) (def: (sub-class? super sub) (-> Text Text (Meta Bool)) @@ -445,31 +476,28 @@ sub (load-class sub)] (wrap (Class.isAssignableFrom [sub] super)))) -(exception: #export Not-Throwable) - (def: (object-throw proc) (-> Text @;Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list exceptionC)) - (do meta;Monad<Meta> - [exceptionA (&;with-expected-type varT - (analyse exceptionC)) - exceptionT (&;with-type-env - (tc;read var-id)) - exception-class (check-object exceptionT) - ? (sub-class? "java.lang.Throwable" exception-class) - _ (: (Meta Unit) - (if ? - (wrap []) - (&;throw Not-Throwable exception-class))) - _ (&;infer Bottom)] - (wrap (la;procedure proc (list exceptionA)))) - - _ - (&;fail (@;wrong-arity proc +1 (list;size args)))))))) + (case args + (^ (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)) + exception-class (check-object exceptionT) + ? (sub-class? "java.lang.Throwable" exception-class) + _ (: (Meta Unit) + (if ? + (wrap []) + (&;throw Non-Throwable exception-class)))] + (wrap (la;procedure proc (list exceptionA)))) + + _ + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) (def: (object-class proc) (-> Text @;Proc) @@ -479,45 +507,38 @@ (case classC [_ (#;Text class)] (do meta;Monad<Meta> - [_ (load-class class) - _ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))] + [_ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list))))) + _ (load-class class)] (wrap (la;procedure proc (list (code;text class))))) _ - (&;fail (format "Wrong syntax for '" proc "'."))) + (&;throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;fail (@;wrong-arity proc +1 (list;size args)))))) - -(exception: #export Cannot-Be-Instance) + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) (def: (object-instance? proc) (-> Text @;Proc) (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list classC objectC)) - (case classC - [_ (#;Text class)] - (do meta;Monad<Meta> - [objectA (&;with-expected-type varT - (analyse objectC)) - objectT (&;with-type-env - (tc;read var-id)) - object-class (check-object objectT) - ? (sub-class? class object-class)] - (if ? - (do @ - [_ (&;infer Bool)] - (wrap (la;procedure proc (list (code;text class))))) - (&;throw Cannot-Be-Instance (format object-class " !<= " class)))) + (case args + (^ (list classC objectC)) + (case classC + [_ (#;Text class)] + (do meta;Monad<Meta> + [_ (&;infer Bool) + [objectT objectA] (&common;with-unknown-type + (analyse objectC)) + object-class (check-object objectT) + ? (sub-class? class object-class)] + (if ? + (wrap (la;procedure proc (list (code;text class)))) + (&;throw Cannot-Possibly-Be-Instance (format object-class " !<= " class)))) - _ - (&;fail (format "Wrong syntax for '" proc "'."))) + _ + (&;throw Wrong-Syntax (wrong-syntax proc args))) - _ - (&;fail (@;wrong-arity proc +2 (list;size args)))))))) + _ + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) (def: object-procs @;Bundle @@ -531,14 +552,6 @@ (@;install "instance?" object-instance?) ))) -(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) - (def: type-descriptor (-> java.lang.reflect.Type Text) (java.lang.reflect.Type.getTypeName [])) @@ -554,8 +567,6 @@ ## else (&;throw Cannot-Convert-To-Class (type-descriptor type)))) -(exception: #export Unknown-Type-Var) - (type: Mappings (Dict Text Type)) @@ -634,18 +645,29 @@ (case type (#;Primitive 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)))) + class-params (array;to-list (Class.getTypeParameters [] class)) + num-class-params (list;size class-params) + num-type-params (list;size params)] + (cond (not (text/= class-name name)) + (&;throw Cannot-Correspond-Type-With-Class + (format "Class = " class-name "\n" + "Type = " (%type type))) + + (not (n.= num-class-params num-type-params)) + (&;throw Type-Parameter-Mismatch + (format "Expected: " (%i (nat-to-int num-class-params)) "\n" + " Actual: " (%i (nat-to-int num-type-params)) "\n" + " Class: " class-name "\n" + " Type: " (%type type))) + + ## else + (meta/wrap (|> params + (list;zip2 (list/map (TypeVariable.getName []) class-params)) + (dict;from-list text;Hash<Text>))) + )) _ - (&;fail (format "Not a host type: " (%type type))))) + (&;throw Non-JVM-Type (%type type)))) (def: (cast direction to from) (-> Direction Type Type (Meta [Text Type])) @@ -656,7 +678,7 @@ (let [box (maybe;assume (dict;get to-name boxes))] (if (text/= box from-name) (wrap [(choose direction to-name from-name) (#;Primitive to-name (list))]) - (&;throw Cannot-Cast-To-Primitive (format from-name " => " to-name)))) + (&;throw Cannot-Cast (cannot-cast to from)))) (dict;contains? from-name boxes) (let [box (maybe;assume (dict;get from-name boxes))] @@ -674,7 +696,7 @@ (do @ [to-class (load-class to-name) from-class (load-class from-name) - _ (&;assert (format "Class '" from-name "' is not a sub-class of class '" to-name "'.") + _ (&;assert Cannot-Cast (cannot-cast to from) (Class.isAssignableFrom [from-class] to-class)) candiate-parents (monad;map @ (function [java-type] @@ -695,7 +717,7 @@ (wrap [(choose direction to-name from-name) castT])) #;Nil - (&;fail (format "No valid path between " (%type from) "and " (%type to) "."))))))) + (&;throw Cannot-Cast (cannot-cast to from))))))) (def: (infer-out outputT) (-> Type (Meta [Text Type])) @@ -715,11 +737,13 @@ (let [owner (Field.getDeclaringClass [] field)] (if (is owner class) (wrap [class field]) - (&;fail (format "Field '" field-name "' does not belong to class '" class-name "'.\n" - "Belongs to '" (Class.getName [] owner) "'.")))) + (&;throw Mistaken-Field-Owner + (format " Field: " field-name "\n" + " Owner Class: " (Class.getName [] owner) "\n" + "Target Class: " class-name "\n")))) (#e;Error _) - (&;fail (format "Unknown field '" field-name "' for class '" class-name "'."))))) + (&;throw Unknown-Field (format class-name "#" field-name))))) (def: (static-field class-name field-name) (-> Text Text (Meta [Type Bool])) @@ -731,9 +755,7 @@ (do @ [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] (wrap [fieldT (Modifier.isFinal [modifiers])]))) - (&;fail (format "Field '" field-name "' of class '" class-name "' is not static."))))) - -(exception: #export Non-Object-Type) + (&;throw Not-Static-Field (format class-name "#" field-name))))) (def: (virtual-field class-name field-name objectT) (-> Text Text Type (Meta [Type Bool])) @@ -753,44 +775,48 @@ (do @ [#let [num-params (list;size _class-params) num-vars (list;size var-names)] - _ (&;assert (format "Number of paremeters in type does not match expected amount (" (%n num-vars) "): " (%type objectT)) + _ (&;assert Type-Parameter-Mismatch + (format "Expected: " (%i (nat-to-int num-params)) "\n" + " Actual: " (%i (nat-to-int num-vars)) "\n" + " Class: " _class-name "\n" + " Type: " (%type objectT)) (n.= num-params num-vars))] (wrap (|> (list;zip2 var-names _class-params) (dict;from-list text;Hash<Text>)))) _ - (&;throw Non-Object-Type (%type objectT)))) + (&;throw Non-Object (%type objectT)))) fieldT (java-type-to-lux-type mappings fieldJT)] (wrap [fieldT (Modifier.isFinal [modifiers])])) - (&;fail (format "Field '" field-name "' of class '" class-name "' is static."))))) + (&;throw Not-Virtual-Field (format class-name "#" field-name))))) (def: (analyse-object class analyse sourceC) (-> Text &;Analyser Code (Meta [Type la;Analysis])) - (<| &common;with-var (function [[var-id varT]]) - (do meta;Monad<Meta> - [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)) - [unboxed castT] (cast #Out targetT sourceT) - _ (&;assert (format "Object cannot be a primitive: " unboxed) - (not (dict;contains? unboxed boxes)))] - (wrap [castT sourceA])))) + (do meta;Monad<Meta> + [[var-id varT] (&;with-type-env tc;var) + 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)) + [unboxed castT] (cast #Out targetT sourceT) + _ (&;assert Cannot-Cast (cannot-cast targetT sourceT) + (not (dict;contains? unboxed boxes)))] + (wrap [castT sourceA]))) (def: (analyse-input analyse targetT sourceC) (-> &;Analyser Type Code (Meta [Type Text la;Analysis])) - (<| &common;with-var (function [[var-id varT]]) - (do meta;Monad<Meta> - [sourceA (&;with-expected-type varT - (analyse sourceC)) - sourceT (&;with-type-env - (tc;read var-id)) - [unboxed castT] (cast #In targetT sourceT)] - (wrap [castT unboxed sourceA])))) + (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)) + [unboxed castT] (cast #In targetT sourceT)] + (wrap [castT unboxed sourceA]))) (def: (static-get proc) (-> Text @;Proc) @@ -806,10 +832,10 @@ (code;text unboxed))))) _ - (&;fail (format "Wrong syntax for '" proc "'."))) + (&;throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;fail (@;wrong-arity proc +2 (list;size args)))))) + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) (def: (static-put proc) (-> Text @;Proc) @@ -819,21 +845,21 @@ (case [classC fieldC] [[_ (#;Text class)] [_ (#;Text field)]] (do meta;Monad<Meta> - [[fieldT final?] (static-field class field) - _ (&;assert (Final-Field (format class "#" field)) + [_ (&;infer Unit) + [fieldT final?] (static-field class field) + _ (&;assert Cannot-Set-Final-Field (format class "#" field) (not final?)) [valueT unboxed valueA] (analyse-input analyse fieldT valueC) _ (&;with-type-env - (tc;check fieldT valueT)) - _ (&;infer Unit)] + (tc;check fieldT valueT))] (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA)))) _ - (&;fail (format "Wrong syntax for '" proc "'."))) + (&;throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;fail (@;wrong-arity proc +3 (list;size args)))))) + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args)))))) (def: (virtual-get proc) (-> Text @;Proc) @@ -850,10 +876,10 @@ (code;text unboxed) objectA)))) _ - (&;fail (format "Wrong syntax for '" proc "'."))) + (&;throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;fail (@;wrong-arity proc +3 (list;size args)))))) + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args)))))) (def: (virtual-put proc) (-> Text @;Proc) @@ -864,20 +890,18 @@ [[_ (#;Text class)] [_ (#;Text field)]] (do meta;Monad<Meta> [[objectT objectA] (analyse-object class analyse objectC) + _ (&;infer objectT) [fieldT final?] (virtual-field class field objectT) - _ (&;assert (Final-Field (format class "#" field)) + _ (&;assert Cannot-Set-Final-Field (format class "#" field) (not final?)) - [valueT unboxed valueA] (analyse-input analyse fieldT valueC) - _ (&;with-type-env - (tc;check fieldT valueT)) - _ (&;infer objectT)] + [valueT unboxed valueA] (analyse-input analyse fieldT valueC)] (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA)))) _ - (&;fail (format "Wrong syntax for '" proc "'."))) + (&;throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;fail (@;wrong-arity proc +4 (list;size args)))))) + (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +4 (list;size args)))))) (def: (java-type-to-parameter type) (-> java.lang.reflect.Type (Meta Text)) @@ -1007,9 +1031,6 @@ 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) (Meta [Type (List Type)])) (do meta;Monad<Meta> @@ -1023,13 +1044,13 @@ (wrap [passes? method])))))] (case (list;filter product;left candidates) #;Nil - (&;throw No-Candidate-Method (format class-name "#" method-name)) + (&;throw No-Candidates (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))))) + (&;throw Too-Many-Candidates (format class-name "#" method-name))))) (def: (constructor-to-type constructor) (-> (Constructor Object) (Meta [Type (List Type)])) @@ -1066,9 +1087,6 @@ 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) (Meta [Type (List Type)])) (do meta;Monad<Meta> @@ -1082,13 +1100,13 @@ (wrap [passes? constructor])))))] (case (list;filter product;left candidates) #;Nil - (&;throw No-Candidate-Constructor (format class-name "(" (text;join-with ", " arg-classes) ")")) + (&;throw No-Candidates (format class-name "(" (text;join-with ", " arg-classes) ")")) (#;Cons candidate #;Nil) (|> candidate product;right constructor-to-type) _ - (&;throw Too-Many-Candidate-Constructors class-name)))) + (&;throw Too-Many-Candidates class-name)))) (def: (decorate-inputs typesT inputsA) (-> (List Text) (List la;Analysis) (List la;Analysis)) @@ -1122,7 +1140,7 @@ (code;text unboxed) (decorate-inputs argsT argsA))))) _ - (&;fail (format "Wrong syntax for '" proc "'."))))) + (&;throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//virtual proc) (-> Text @;Proc) @@ -1145,7 +1163,7 @@ (code;text unboxed) objectA (decorate-inputs argsT argsA))))) _ - (&;fail (format "Wrong syntax for '" proc "'."))))) + (&;throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//special proc) (-> Text @;Proc) @@ -1162,9 +1180,7 @@ (code;text unboxed) (decorate-inputs argsT argsA))))) _ - (&;fail (format "Wrong syntax for '" proc "'."))))) - -(exception: #export Not-Interface) + (&;throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//interface proc) (-> Text @;Proc) @@ -1175,7 +1191,7 @@ (do meta;Monad<Meta> [#let [argsT (list/map product;left argsTC)] class (load-class class-name) - _ (&;assert (Not-Interface class-name) + _ (&;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))) @@ -1185,7 +1201,7 @@ (decorate-inputs argsT argsA))))) _ - (&;fail (format "Wrong syntax for '" proc "'."))))) + (&;throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//constructor proc) (-> Text @;Proc) @@ -1201,7 +1217,7 @@ (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA))))) _ - (&;fail (format "Wrong syntax for '" proc "'."))))) + (&;throw Wrong-Syntax (wrong-syntax proc args))))) (def: member-procs @;Bundle |