diff options
Diffstat (limited to '')
17 files changed, 518 insertions, 515 deletions
diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux index c7768cd8c..373c6b12b 100644 --- a/new-luxc/source/luxc/base.lux +++ b/new-luxc/source/luxc/base.lux @@ -9,7 +9,8 @@ text/format (coll [list])) [meta] - (meta (type ["tc" check]))) + (meta (type ["tc" check]) + ["s" syntax #+ syntax:])) (luxc (lang ["la" analysis]))) (type: #export Eval @@ -30,16 +31,15 @@ (meta;fail (format message "\n\n" "@ " location)))) -(def: #export (assert message test) - (-> Text Bool (Meta Unit)) - (if test - (:: meta;Monad<Meta> wrap []) - (fail message))) - (def: #export (throw exception message) (All [a] (-> ex;Exception Text (Meta a))) (fail (exception message))) +(syntax: #export (assert exception message test) + (wrap (list (` (if (~ test) + (:: meta;Monad<Meta> (~' wrap) []) + (;;throw (~ exception) (~ message))))))) + (def: #export (with-expected-type expected action) (All [a] (-> Type (Meta a) (Meta a))) (function [compiler] diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux index b0098f7c2..5bf2e8ed1 100644 --- a/new-luxc/source/luxc/lang/analysis/case.lux +++ b/new-luxc/source/luxc/lang/analysis/case.lux @@ -26,13 +26,14 @@ (exception: #export Sum-Type-Has-No-Case) (exception: #export Unrecognized-Pattern-Syntax) (exception: #export Cannot-Simplify-Type-For-Pattern-Matching) -(exception: #export Cannot-Apply-Type) +(exception: #export Cannot-Have-Empty-Branches) +(exception: #export Non-Exhaustive-Pattern-Matching) +(exception: #export Symbols-Must-Be-Unqualified-Inside-Patterns) (def: (pattern-error type pattern) (-> Type Code Text) - (Cannot-Match-Type-With-Pattern - (format " Type: " (%type type) "\n" - "Pattern: " (%code pattern)))) + (format " Type: " (%type type) "\n" + "Pattern: " (%code pattern))) ## Type-checking on the input value is done during the analysis of a ## "case" expression, to ensure that the patterns being used make @@ -73,7 +74,7 @@ [? (tc;concrete? funcT-id)] (if ? (tc;read funcT-id) - (tc;throw Cannot-Apply-Type (%type caseT)))))] + (tc;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))] (simplify-case-type (#;Apply inputT funcT'))) _ @@ -82,7 +83,7 @@ (:: meta;Monad<Meta> wrap outputT) #;None - (&;throw Cannot-Apply-Type (%type caseT)))) + (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) _ (:: meta;Monad<Meta> wrap caseT))) @@ -116,7 +117,7 @@ [cursor (#;Symbol ident)] (&;with-cursor cursor - (&;fail (format "Symbols must be unqualified inside patterns: " (%ident ident)))) + (&;throw Symbols-Must-Be-Unqualified-Inside-Patterns (%ident ident))) (^template [<type> <code-tag>] [cursor (<code-tag> test)] @@ -183,7 +184,7 @@ thenA]))) _ - (&;fail (pattern-error inputT pattern)) + (&;throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern)) ))) [cursor (#;Record record)] @@ -230,7 +231,7 @@ "Type: " (%type inputT))))) _ - (&;fail (pattern-error inputT pattern))))) + (&;throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern))))) (^ [cursor (#;Form (list& [_ (#;Tag tag)] values))]) (&;with-cursor cursor @@ -249,7 +250,7 @@ (-> &;Analyser Code (List [Code Code]) (Meta la;Analysis)) (case branches #;Nil - (&;fail "Cannot have empty branches in pattern-matching expression.") + (&;throw Cannot-Have-Empty-Branches "") (#;Cons [patternH bodyH] branchesT) (do meta;Monad<Meta> @@ -264,9 +265,8 @@ outputTC (monad;map @ (|>. product;left coverageA;determine) outputT) _ (case (monad;fold e;Monad<Error> coverageA;merge outputHC outputTC) (#e;Success coverage) - (if (coverageA;exhaustive? coverage) - (wrap []) - (&;fail "Pattern-matching is not exhaustive.")) + (&;assert Non-Exhaustive-Pattern-Matching "" + (coverageA;exhaustive? coverage)) (#e;Error error) (&;fail error))] diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux index 4d16e4ae6..1eb2b8b37 100644 --- a/new-luxc/source/luxc/lang/analysis/common.lux +++ b/new-luxc/source/luxc/lang/analysis/common.lux @@ -4,7 +4,7 @@ ["ex" exception #+ exception:]) (data text/format [product]) - [meta #+ Monad<Meta>] + [meta] (meta [type] (type ["tc" check]))) (luxc ["&" base] @@ -12,7 +12,7 @@ (def: #export (with-unknown-type action) (All [a] (-> (Meta Analysis) (Meta [Type Analysis]))) - (do Monad<Meta> + (do meta;Monad<Meta> [[var-id var-type] (&;with-type-env tc;var) analysis (&;with-expected-type var-type @@ -21,13 +21,6 @@ (tc;clean var-id var-type))] (wrap [analysis-type analysis]))) -(def: #export (with-var body) - (All [a] (-> (-> [Nat Type] (Meta a)) (Meta a))) - (do Monad<Meta> - [[id var] (&;with-type-env - tc;var)] - (body [id var]))) - (exception: #export Variant-Tag-Out-Of-Bounds) (def: #export (variant-out-of-bounds-error type size tag) diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux index 12256a4bf..248248010 100644 --- a/new-luxc/source/luxc/lang/analysis/expression.lux +++ b/new-luxc/source/luxc/lang/analysis/expression.lux @@ -24,6 +24,7 @@ (exception: #export Macro-Expression-Must-Have-Single-Expansion) (exception: #export Unrecognized-Syntax) +(exception: #export Macro-Expansion-Failed) (def: #export (analyser eval) (-> &;Eval &;Analyser) @@ -96,7 +97,7 @@ (#e;Success [compiler' output]) (#e;Error error) - ((&;fail error) compiler)))] + ((&;throw Macro-Expansion-Failed error) compiler)))] (case expansion (^ (list single)) (analyse single) diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux index 42a021577..0bb46aba1 100644 --- a/new-luxc/source/luxc/lang/analysis/function.lux +++ b/new-luxc/source/luxc/lang/analysis/function.lux @@ -38,7 +38,7 @@ (recur value) #;None - (&;fail (format "Cannot apply type " (%type funT) " to type " (%type argT)))) + (&;throw Invalid-Function-Type (%type expectedT))) (#;UnivQ _) (do @ @@ -47,9 +47,9 @@ (recur (maybe;assume (type;apply (list var) expectedT)))) (#;ExQ _) - (&common;with-var - (function [[var-id var]] - (recur (maybe;assume (type;apply (list var) expectedT))))) + (do @ + [[var-id var] (&;with-type-env tc;var)] + (recur (maybe;assume (type;apply (list var) expectedT)))) (#;Var id) (do @ @@ -61,25 +61,23 @@ (tc;read id))] (recur expectedT')) ## Inference - (&common;with-var - (function [[input-id inputT]] - (&common;with-var - (function [[output-id outputT]] - (do @ - [#let [funT (#;Function inputT outputT)] - funA (recur funT) - funT' (&;with-type-env - (tc;clean output-id funT)) - concrete-input? (&;with-type-env - (tc;concrete? input-id)) - funT'' (if concrete-input? - (&;with-type-env - (tc;clean input-id funT')) - (wrap (type;univ-q +1 (&inference;replace-var input-id +1 funT')))) - _ (&;with-type-env - (tc;check expectedT funT''))] - (wrap funA)) - )))))) + (do @ + [[input-id inputT] (&;with-type-env tc;var) + [output-id outputT] (&;with-type-env tc;var) + #let [funT (#;Function inputT outputT)] + funA (recur funT) + funT' (&;with-type-env + (tc;clean output-id funT)) + concrete-input? (&;with-type-env + (tc;concrete? input-id)) + funT'' (if concrete-input? + (&;with-type-env + (tc;clean input-id funT')) + (wrap (type;univ-q +1 (&inference;replace-var input-id +1 funT')))) + _ (&;with-type-env + (tc;check expectedT funT''))] + (wrap funA)) + )) (#;Function inputT outputT) (<| (:: @ map (function [[scope bodyA]] diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux index e2866ac87..934ecafa5 100644 --- a/new-luxc/source/luxc/lang/analysis/inference.lux +++ b/new-luxc/source/luxc/lang/analysis/inference.lux @@ -109,20 +109,19 @@ (apply-function analyse unnamedT args) (#;UnivQ _) - (&common;with-var - (function [[var-id varT]] - (do Monad<Meta> - [[outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) inferT)) args)] - (do @ - [? (&;with-type-env - (tc;concrete? var-id)) - ## Quantify over the type if genericity/parametricity - ## is discovered. - outputT' (if ? - (&;with-type-env - (tc;clean var-id outputT)) - (wrap (type;univ-q +1 (replace-var var-id +1 outputT))))] - (wrap [outputT' argsA]))))) + (do Monad<Meta> + [[var-id varT] (&;with-type-env tc;var) + [outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) inferT)) args)] + (do @ + [? (&;with-type-env + (tc;concrete? var-id)) + ## Quantify over the type if genericity/parametricity + ## is discovered. + outputT' (if ? + (&;with-type-env + (tc;clean var-id outputT)) + (wrap (type;univ-q +1 (replace-var var-id +1 outputT))))] + (wrap [outputT' argsA]))) (#;ExQ _) (do Monad<Meta> diff --git a/new-luxc/source/luxc/lang/analysis/primitive.lux b/new-luxc/source/luxc/lang/analysis/primitive.lux index c7f7243fd..bb1762f46 100644 --- a/new-luxc/source/luxc/lang/analysis/primitive.lux +++ b/new-luxc/source/luxc/lang/analysis/primitive.lux @@ -12,9 +12,7 @@ [(def: #export (<name> value) (-> <type> (Meta Analysis)) (do meta;Monad<Meta> - [expected meta;expected-type - _ (&;with-type-env - (tc;check expected <type>))] + [_ (&;infer <type>)] (wrap (<tag> value))))] [analyse-bool Bool code;bool] @@ -28,7 +26,5 @@ (def: #export analyse-unit (Meta Analysis) (do meta;Monad<Meta> - [expected meta;expected-type - _ (&;with-type-env - (tc;check expected Unit))] + [_ (&;infer Unit)] (wrap (` [])))) 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 diff --git a/new-luxc/source/luxc/lang/analysis/reference.lux b/new-luxc/source/luxc/lang/analysis/reference.lux index 5bc1f96c9..ef02919f4 100644 --- a/new-luxc/source/luxc/lang/analysis/reference.lux +++ b/new-luxc/source/luxc/lang/analysis/reference.lux @@ -14,9 +14,7 @@ (-> Ident (Meta Analysis)) (do meta;Monad<Meta> [actualT (meta;find-def-type def-name) - expectedT meta;expected-type - _ (&;with-type-env - (tc;check expectedT actualT))] + _ (&;infer actualT)] (wrap (code;symbol def-name)))) (def: (analyse-variable var-name) @@ -26,9 +24,7 @@ (case ?var (#;Some [actualT ref]) (do @ - [expectedT meta;expected-type - _ (&;with-type-env - (tc;check expectedT actualT))] + [_ (&;infer actualT)] (wrap (#;Some (` ((~ (code;int (variableL;from-ref ref)))))))) #;None @@ -41,8 +37,8 @@ (do meta;Monad<Meta> [?var (analyse-variable simple-name)] (case ?var - (#;Some analysis) - (wrap analysis) + (#;Some varA) + (wrap varA) #;None (do @ diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux index 9308fcfef..b7047e105 100644 --- a/new-luxc/source/luxc/lang/analysis/structure.lux +++ b/new-luxc/source/luxc/lang/analysis/structure.lux @@ -26,14 +26,13 @@ (exception: #export Not-Variant-Type) (exception: #export Not-Tuple-Type) -(exception: #export Cannot-Infer-Numeric-Tag) - -(type: Type-Error - (-> Type Text)) +(exception: #export Not-Quantified-Type) -(def: (not-quantified type) - Type-Error - (format "Not a quantified type: " (%type type))) +(exception: #export Cannot-Infer-Numeric-Tag) +(exception: #export Record-Keys-Must-Be-Tags) +(exception: #export Cannot-Repeat-Tag) +(exception: #export Tag-Does-Not-Belong-To-Record) +(exception: #export Record-Size-Mismatch) (def: #export (analyse-sum analyse tag valueC) (-> &;Analyser Nat Code (Meta la;Analysis)) @@ -79,23 +78,19 @@ "Value: " (%code valueC) "\n" " Type: " (%type expectedT))))) - (#;UnivQ _) - (do @ - [[var-id var] (&;with-type-env - tc;existential)] - (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) - (analyse-sum analyse tag valueC))) - - (#;ExQ _) - (&common;with-var - (function [[var-id var]] - (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[instance-id instanceT] (&;with-type-env <instancer>)] + (&;with-expected-type (maybe;assume (type;apply (list instanceT) expectedT)) (analyse-sum analyse tag valueC)))) + ([#;UnivQ tc;existential] + [#;ExQ tc;var]) (#;Apply inputT funT) (case (type;apply (list inputT) funT) #;None - (&;fail (not-quantified funT)) + (&;throw Not-Quantified-Type (%type funT)) (#;Some outputT) (&;with-expected-type outputT @@ -188,23 +183,19 @@ (type;tuple (list/map product;left membersTA))))] (wrap (la;product (list/map product;right membersTA)))))) - (#;UnivQ _) - (do @ - [[var-id var] (&;with-type-env - tc;existential)] - (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) - (analyse-product analyse membersC))) - - (#;ExQ _) - (&common;with-var - (function [[var-id var]] - (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[instance-id instanceT] (&;with-type-env <instancer>)] + (&;with-expected-type (maybe;assume (type;apply (list instanceT) expectedT)) (analyse-product analyse membersC)))) + ([#;UnivQ tc;existential] + [#;ExQ tc;var]) (#;Apply inputT funT) (case (type;apply (list inputT) funT) #;None - (&;fail (not-quantified funT)) + (&;throw Not-Quantified-Type (%type funT)) (#;Some outputT) (&;with-expected-type outputT @@ -248,7 +239,8 @@ (wrap [key val])) _ - (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) + (&;throw Record-Keys-Must-Be-Tags (format " Key: " (%code key) "\n" + "Record: " (%code (code;record record)))))) record)) ## Lux already possesses the means to analyse tuples, so @@ -269,10 +261,10 @@ size-ts (list;size tag-set)] _ (if (n.= size-ts size-record) (wrap []) - (&;fail (format "Record size does not match tag-set size." "\n" - "Expected: " (|> size-ts nat-to-int %i) "\n" - " Actual: " (|> size-record nat-to-int %i) "\n" - "For type: " (%type recordT)))) + (&;throw Record-Size-Mismatch + (format "Expected: " (|> size-ts nat-to-int %i) "\n" + " Actual: " (|> size-record nat-to-int %i) "\n" + " Type: " (%type recordT)))) #let [tuple-range (list;n.range +0 (n.dec size-ts)) tag->idx (dict;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))] idx->val (monad;fold @ @@ -281,12 +273,17 @@ [key (meta;normalize key)] (case (dict;get key tag->idx) #;None - (&;fail (format "Tag " (%code (code;tag key)) - " does not belong to tag-set for type " (%type recordT))) + (&;throw Tag-Does-Not-Belong-To-Record + (format " Tag: " (%code (code;tag key)) "\n" + "Type: " (%type recordT))) (#;Some idx) (if (dict;contains? idx idx->val) - (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key)))) + (&;throw Cannot-Repeat-Tag + (format " Tag: " (%code (code;tag key)) "\n" + "Record: " (%code (code;record (list/map (function [[keyI valC]] + [(code;tag keyI) valC]) + record))))) (wrap (dict;put idx val idx->val)))))) (: (Dict Nat Code) (dict;new number;Hash<Nat>)) diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux index c4ebf3642..cf3137aff 100644 --- a/new-luxc/source/luxc/lang/translation.lux +++ b/new-luxc/source/luxc/lang/translation.lux @@ -32,6 +32,7 @@ (&;Analyser) (expressionA;analyser &eval;eval)) +(exception: #export Macro-Expansion-Failed) (exception: #export Unrecognized-Statement) (def: (translate code) @@ -79,7 +80,7 @@ (#e;Success [compiler' output]) (#e;Error error) - ((&;fail error) compiler))) + ((&;throw Macro-Expansion-Failed error) compiler))) _ (monad;map @ translate expansion)] (wrap [])) (&;throw Unrecognized-Statement (%code code)))) diff --git a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux index 82b7c5d44..733f630d5 100644 --- a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux @@ -21,7 +21,7 @@ (def: #export (translate-procedure translate name args) (-> (-> ls;Synthesis (Meta $;Inst)) Text (List ls;Synthesis) (Meta $;Inst)) - (<| (maybe;default (&;throw Unknown-Procedure name)) + (<| (maybe;default (&;throw Unknown-Procedure (%t name))) (do maybe;Monad<Maybe> [proc (dict;get name procedures)] (wrap (proc translate args))))) diff --git a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux index 7168514c1..a5e06aac3 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux @@ -10,7 +10,7 @@ ["l" lexer]) (coll [list "list/" Functor<List>] [dict #+ Dict])) - [meta #+ with-gensyms "meta/" Monad<Meta>] + [meta "meta/" Monad<Meta>] (meta [code] ["s" syntax #+ syntax:]) [host]) @@ -25,6 +25,15 @@ ["ls" synthesis])) ["@" ../common]) +(exception: #export Wrong-Syntax) +(def: (wrong-syntax procedure args) + (-> Text (List ls;Synthesis) Text) + (format "Procedure: " procedure "\n" + "Arguments: " (%code (code;tuple args)))) + +(exception: #export Invalid-Syntax-For-JVM-Type) +(exception: #export Invalid-Syntax-For-Argument-Generation) + (do-template [<name> <inst>] [(def: <name> $;Inst @@ -295,7 +304,7 @@ ($i;array arrayJT)))) _ - (&;fail (format "Wrong syntax for '" proc "'.")))) + (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) (def: (array//read proc translate inputs) (-> Text @;Proc) @@ -321,7 +330,7 @@ loadI))) _ - (&;fail (format "Wrong syntax for '" proc "'.")))) + (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) (def: (array//write proc translate inputs) (-> Text @;Proc) @@ -350,7 +359,7 @@ storeI))) _ - (&;fail (format "Wrong syntax for '" proc "'.")))) + (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) (def: array-procs @;Bundle @@ -406,7 +415,7 @@ false)))) _ - (&;fail (format "Wrong syntax for '" proc "'.")))) + (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) (def: (object//instance? proc translate inputs) (-> Text @;Proc) @@ -419,7 +428,7 @@ ($i;wrap #$;Boolean)))) _ - (&;fail (format "Wrong syntax for '" proc "'.")))) + (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) (def: object-procs @;Bundle @@ -470,7 +479,7 @@ (wrap ($i;GETSTATIC class field ($t;class unboxed (list)))))) _ - (&;fail (format "Wrong syntax for '" proc "'.")))) + (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) (def: (static//put proc translate inputs) (-> Text @;Proc) @@ -502,7 +511,7 @@ ($i;string hostL;unit))))) _ - (&;fail (format "Wrong syntax for '" proc "'.")))) + (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) (def: (virtual//get proc translate inputs) (-> Text @;Proc) @@ -533,7 +542,7 @@ ($i;GETFIELD class field ($t;class unboxed (list))))))) _ - (&;fail (format "Wrong syntax for '" proc "'.")))) + (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) (def: (virtual//put proc translate inputs) (-> Text @;Proc) @@ -570,9 +579,7 @@ ($i;PUTFIELD class field ($t;class unboxed (list))))))) _ - (&;fail (format "Wrong syntax for '" proc "'.")))) - -(exception: #export Invalid-Syntax-For-Argument-Generation) + (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) (def: base-type (l;Lexer $;Type) @@ -601,7 +608,7 @@ (-> Text (Meta $;Type)) (case (l;run argD java-type) (#e;Error error) - (&;fail error) + (&;throw Invalid-Syntax-For-JVM-Type argD) (#e;Success type) (meta/wrap type))) @@ -647,7 +654,7 @@ (meta/wrap #;None) _ - (:: meta;Monad<Meta> map (|>. #;Some) (translate-type description)))) + (meta/map (|>. #;Some) (translate-type description)))) (def: (prepare-return returnT returnI) (-> (Maybe $;Type) $;Inst $;Inst) @@ -679,7 +686,7 @@ (wrap (prepare-return returnT callI))) _ - (&;fail (format "Wrong syntax for '" proc "'.")))) + (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) (do-template [<name> <invoke> <interface?>] [(def: (<name> proc translate inputs) @@ -700,7 +707,7 @@ (wrap (prepare-return returnT callI))) _ - (&;fail (format "Wrong syntax for '" proc "'."))))] + (&;throw Wrong-Syntax (wrong-syntax proc inputs))))] [invoke//virtual $i;INVOKEVIRTUAL false] [invoke//special $i;INVOKESPECIAL false] @@ -721,7 +728,7 @@ false)))) _ - (&;fail (format "Wrong syntax for '" proc "'.")))) + (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) (def: member-procs @;Bundle @@ -741,8 +748,7 @@ (@;install "virtual" invoke//virtual) (@;install "special" invoke//special) (@;install "interface" invoke//interface) - (@;install "constructor" invoke//constructor) - ))) + (@;install "constructor" invoke//constructor)))) ))) (def: #export procedures diff --git a/new-luxc/source/luxc/lang/translation/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/statement.jvm.lux index feb64c293..2a2173fa9 100644 --- a/new-luxc/source/luxc/lang/translation/statement.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/statement.jvm.lux @@ -21,6 +21,7 @@ [";T" common])))) (exception: #export Invalid-Definition-Value) +(exception: #export Cannot-Evaluate-Definition) (host;import java.lang.Object (toString [] String)) @@ -56,13 +57,16 @@ [field (Class.getField [commonT;value-field] class)] (Field.get [#;None] field)) (#e;Success #;None) - (&;throw Invalid-Definition-Value (format current-module ";" def-name)) + (&;throw Invalid-Definition-Value (%ident [current-module def-name])) (#e;Success (#;Some valueV)) (wrap valueV) (#e;Error error) - (&;fail error))) + (&;throw Cannot-Evaluate-Definition + (format "Definition: " (%ident [current-module def-name]) "\n" + "Error:\n" + error)))) _ (&module;define [current-module def-name] [valueT metaV valueV]) _ (if (meta;type? metaV) (case (meta;declared-tags metaV) @@ -77,6 +81,4 @@ (def: #export (translate-program program-args programI) (-> Text $;Inst (Meta Unit)) - (do meta;Monad<Meta> - [] - (&;fail "'lux program' is unimplemented."))) + (&;fail "\"lux program\" is unimplemented.")) diff --git a/new-luxc/source/luxc/lang/translation/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/structure.jvm.lux index 3ef03ac2c..68219b87c 100644 --- a/new-luxc/source/luxc/lang/translation/structure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/structure.jvm.lux @@ -1,6 +1,7 @@ (;module: lux - (lux (control [monad #+ do]) + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) (data text/format (coll [list])) [meta] @@ -16,13 +17,15 @@ (translation [";T" common]))) [../runtime]) +(exception: #export Not-A-Tuple) + (def: $Object $;Type ($t;class "java.lang.Object" (list))) (def: #export (translate-tuple translate members) (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta $;Inst)) (do meta;Monad<Meta> [#let [size (list;size members)] - _ (&;assert "Cannot translate tuples with less than 2 elements." + _ (&;assert Not-A-Tuple (%code (` [(~@ members)])) (n.>= +2 size)) membersI (|> members list;enumerate diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux index 2bb7eedcd..7b60af8f2 100644 --- a/new-luxc/source/luxc/module.lux +++ b/new-luxc/source/luxc/module.lux @@ -1,14 +1,21 @@ (;module: lux - (lux (control [monad #+ do]) - (data [text "T/" Eq<Text>] + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [text "text/" Eq<Text>] text/format ["e" error] - (coll [list "L/" Fold<List> Functor<List>])) - [meta #+ Monad<Meta>]) + (coll [list "list/" Fold<List> Functor<List>])) + [meta] + (meta [code])) (luxc ["&" base] ["&;" scope])) +(exception: #export Unknown-Module) +(exception: #export Cannot-Declare-Tag-Twice) +(exception: #export Cannot-Declare-Tags-For-Unnamed-Type) +(exception: #export Cannot-Declare-Tags-For-Foreign-Type) + (def: (new-module hash) (-> Nat Module) {#;module-hash hash @@ -54,7 +61,7 @@ (def: #export (with-module hash name action) (All [a] (-> Nat Text (Meta a) (Meta [Module a]))) - (do Monad<Meta> + (do meta;Monad<Meta> [_ (create hash name) output (&;with-current-module name (&scope;with-scope name action)) @@ -107,7 +114,7 @@ (#e;Success [compiler (get@ <tag> module)]) #;None - (meta;run compiler (&;fail (format "Unknown module: " module-name)))) + (meta;run compiler (&;throw Unknown-Module module-name))) ))] [tags-by-module #;tags (List [Text [Nat (List Ident) Bool Type]])] @@ -117,7 +124,7 @@ (def: (ensure-undeclared-tags module-name tags) (-> Text (List Text) (Meta Unit)) - (do Monad<Meta> + (do meta;Monad<Meta> [bindings (tags-by-module module-name) _ (monad;map @ (function [tag] @@ -126,36 +133,41 @@ (wrap []) (#;Some _) - (&;fail (format "Cannot re-declare tag: " tag)))) + (&;throw Cannot-Declare-Tag-Twice (format "Module: " module-name "\n" + " Tag: " tag)))) tags)] (wrap []))) (def: #export (declare-tags tags exported? type) (-> (List Text) Bool Type (Meta Unit)) - (do Monad<Meta> + (do meta;Monad<Meta> [current-module meta;current-module-name [type-module type-name] (case type (#;Named type-ident _) (wrap type-ident) _ - (&;fail (format "Cannot define tags for an unnamed type: " (%type type)))) + (&;throw Cannot-Declare-Tags-For-Unnamed-Type + (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n" + "Type: " (%type type)))) _ (ensure-undeclared-tags current-module tags) - _ (meta;assert (format "Cannot define tags for a type belonging to a foreign module: " (%type type)) - (T/= current-module type-module))] + _ (&;assert Cannot-Declare-Tags-For-Foreign-Type + (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n" + "Type: " (%type type)) + (text/= current-module type-module))] (function [compiler] (case (|> compiler (get@ #;modules) (&;pl-get current-module)) (#;Some module) - (let [namespaced-tags (L/map (|>. [current-module]) tags)] + (let [namespaced-tags (list/map (|>. [current-module]) tags)] (#e;Success [(update@ #;modules (&;pl-update current-module (|>. (update@ #;tags (function [tag-bindings] - (L/fold (function [[idx tag] table] - (&;pl-put tag [idx namespaced-tags exported? type] table)) - tag-bindings - (list;enumerate tags)))) + (list/fold (function [[idx tag] table] + (&;pl-put tag [idx namespaced-tags exported? type] table)) + tag-bindings + (list;enumerate tags)))) (update@ #;types (&;pl-put type-name [namespaced-tags exported? type])))) compiler) []])) #;None - (meta;run compiler (&;fail (format "Unknown module: " current-module))))))) + (meta;run compiler (&;throw Unknown-Module current-module)))))) |