diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/control/exception.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/analysis.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/analysis/function.lux | 11 | ||||
| -rw-r--r-- | stdlib/source/lux/type/check.lux | 70 |
4 files changed, 39 insertions, 50 deletions
diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index c893d2af6..5d241b0c6 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -120,8 +120,8 @@ (list.repeat (n/- (text.size header) largest-header-size)) (text.join-with ""))] - ($_ text@compose padding header ": " message text.new-line)))) - (text.join-with "")))) + ($_ text@compose padding header ": " message)))) + (text.join-with text.new-line)))) (syntax: #export (report {entries (p.many (s.tuple (p.and s.any s.any)))}) (wrap (list (` (report' (list (~+ (|> entries diff --git a/stdlib/source/lux/tool/compiler/phase/analysis.lux b/stdlib/source/lux/tool/compiler/phase/analysis.lux index d21effc00..dd21c8a1e 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis.lux @@ -113,10 +113,10 @@ (compile expansion)) _ - (/function.apply compile functionT functionA argsC+))) + (/function.apply compile functionT functionA functionC argsC+))) _ - (/function.apply compile functionT functionA argsC+))) + (/function.apply compile functionT functionA functionC argsC+))) _ (//.throw unrecognized-syntax [.dummy-cursor code']))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/function.lux b/stdlib/source/lux/tool/compiler/phase/analysis/function.lux index e63a3b8ee..fbaaf2fc5 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/function.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/function.lux @@ -28,8 +28,9 @@ ["Argument" argument] ["Body" (%code body)])) -(exception: #export (cannot-apply {function Type} {arguments (List Code)}) - (ex.report ["Function" (%type function)] +(exception: #export (cannot-apply {functionT Type} {functionC Code} {arguments (List Code)}) + (ex.report ["Function type" (%type functionT)] + ["Function" (%code functionC)] ["Arguments" (|> arguments list.enumerate (list@map (.function (_ [idx argC]) @@ -97,9 +98,9 @@ (/.fail "") ))))) -(def: #export (apply analyse functionT functionA argsC+) - (-> Phase Type Analysis (List Code) (Operation Analysis)) - (<| (/.with-stack cannot-apply [functionT argsC+]) +(def: #export (apply analyse functionT functionA functionC argsC+) + (-> Phase Type Analysis Code (List Code) (Operation Analysis)) + (<| (/.with-stack cannot-apply [functionT functionC argsC+]) (do ///.monad [[applyT argsA+] (//inference.general analyse functionT argsC+)]) (wrap (/.apply [functionA argsA+])))) diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux index 359a0e3b0..c9383696e 100644 --- a/stdlib/source/lux/type/check.lux +++ b/stdlib/source/lux/type/check.lux @@ -5,7 +5,7 @@ [apply (#+ Apply)] ["." monad (#+ Monad do)]] [control - ["ex" exception (#+ exception:)]] + ["." exception (#+ Exception exception:)]] [data ["." maybe] ["." product] @@ -25,23 +25,28 @@ ("lux text =" reference subject)) (exception: #export (unknown-type-var {id Nat}) - (ex.report ["ID" (nat@encode id)])) + (exception.report + ["ID" (nat@encode id)])) (exception: #export (unbound-type-var {id Nat}) - (ex.report ["ID" (nat@encode id)])) + (exception.report + ["ID" (nat@encode id)])) (exception: #export (invalid-type-application {funcT Type} {argT Type}) - (ex.report ["Type function" (//.to-text funcT)] - ["Type argument" (//.to-text argT)])) + (exception.report + ["Type function" (//.to-text funcT)] + ["Type argument" (//.to-text argT)])) (exception: #export (cannot-rebind-var {id Nat} {type Type} {bound Type}) - (ex.report ["Var" (nat@encode id)] - ["Wanted Type" (//.to-text type)] - ["Current Type" (//.to-text bound)])) + (exception.report + ["Var" (nat@encode id)] + ["Wanted Type" (//.to-text type)] + ["Current Type" (//.to-text bound)])) (exception: #export (type-check-failed {expected Type} {actual Type}) - (ex.report ["Expected" (//.to-text expected)] - ["Actual" (//.to-text actual)])) + (exception.report + ["Expected" (//.to-text expected)] + ["Actual" (//.to-text actual)])) (type: #export Var Nat) @@ -160,9 +165,9 @@ (#error.Failure error))) (def: #export (throw exception message) - (All [e a] (-> (ex.Exception e) e (Check a))) + (All [e a] (-> (Exception e) e (Check a))) (function (_ context) - (ex.throw exception message))) + (exception.throw exception message))) (def: #export existential {#.doc "A producer of existential types."} @@ -185,7 +190,7 @@ (#error.Success [context <succeed>]) #.None - (ex.throw unknown-type-var id))))] + (exception.throw unknown-type-var id))))] [bound? Bit #0 #1] [read (Maybe Type) #.None (#.Some bound)] @@ -199,10 +204,10 @@ (#error.Success [context bound]) (#.Some _) - (ex.throw unbound-type-var id) + (exception.throw unbound-type-var id) _ - (ex.throw unknown-type-var id)))) + (exception.throw unknown-type-var id)))) (def: #export (bind type id) (-> Type Var (Check Any)) @@ -213,10 +218,10 @@ []]) (#.Some (#.Some bound)) - (ex.throw cannot-rebind-var [id type bound]) + (exception.throw cannot-rebind-var [id type bound]) _ - (ex.throw unknown-type-var id)))) + (exception.throw unknown-type-var id)))) (def: (update type id) (-> Type Var (Check Any)) @@ -227,7 +232,7 @@ []]) _ - (ex.throw unknown-type-var id)))) + (exception.throw unknown-type-var id)))) (def: #export var (Check [Var Type]) @@ -284,7 +289,7 @@ (#error.Success [context output]) #.None - (ex.throw unknown-type-var current))))) + (exception.throw unknown-type-var current))))) (def: #export fresh-context Type-Context @@ -438,26 +443,6 @@ _ (check' assumptions etype atype)))))) -(def: (with-error-stack on-error check) - (All [a] (-> (-> Any Text) (Check a) (Check a))) - (function (_ context) - (case (check context) - (#error.Failure error) - (#error.Failure (case error - "" - (on-error []) - - _ - ($_ text@compose - (on-error []) - text.new-line text.new-line - "-----------------------------------------" - text.new-line text.new-line - error))) - - output - output))) - ## TODO: "check-apply" can be optimized... (def: (check-apply check' assumptions [eAT eFT] [aAT aFT]) (-> (-> (List Assumption) Type Type (Check (List Assumption))) (List Assumption) @@ -510,14 +495,17 @@ _ (fail ""))) +(def: (with-stack exception parameter check) + (All [e a] (-> (Exception e) e (Check a) (Check a))) + (|>> check (exception.with-stack exception parameter))) + ## TODO: "check'" can be optimized... (def: #export (check' assumptions expected actual) {#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."} (-> (List Assumption) Type Type (Check (List Assumption))) (if (is? expected actual) (check@wrap assumptions) - (with-error-stack - (function (_ _) (ex.construct type-check-failed [expected actual])) + (with-stack type-check-failed [expected actual] (case [expected actual] [(#.Var idE) (#.Var idA)] (check-vars check' assumptions idE idA) |