diff options
Diffstat (limited to '')
7 files changed, 191 insertions, 97 deletions
diff --git a/stdlib/source/lux/compiler/default/phase/analysis.lux b/stdlib/source/lux/compiler/default/phase/analysis.lux index dde9f4e9a..8ef8324ae 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis.lux @@ -132,6 +132,16 @@ (do-template [<name> <tag>] [(template: #export (<name> content) + (.<| #..Reference + <tag> + content))] + + [variable #reference.Variable] + [constant #reference.Constant] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> content) (.<| #Complex <tag> content))] diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case.lux b/stdlib/source/lux/compiler/default/phase/analysis/case.lux index 0d3536db3..2081ceb61 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis/case.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis/case.lux @@ -22,7 +22,7 @@ ["/." // ["." extension]]] [/ - ["." coverage]]) + ["." coverage (#+ Coverage)]]) (exception: #export (cannot-match-with-pattern {type Type} {pattern Code}) (ex.report ["Type" (%type type)] @@ -32,19 +32,19 @@ (ex.report ["Case" (%n case)] ["Type" (%type type)])) -(exception: #export (unrecognized-pattern-syntax {pattern Code}) - (%code pattern)) +(exception: #export (not-a-pattern {code Code}) + (ex.report ["Code" (%code code)])) (exception: #export (cannot-simplify-for-pattern-matching {type Type}) - (%type type)) + (ex.report ["Type" (%type type)])) -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] +(exception: #export (non-exhaustive-pattern-matching {input Code} {branches (List [Code Code])} {coverage Coverage}) + (ex.report ["Input" (%code input)] + ["Branches" (%code (code.record branches))] + ["Coverage" (coverage.%coverage coverage)])) - [cannot-have-empty-branches] - [non-exhaustive-pattern-matching] - ) +(exception: #export (cannot-have-empty-branches {message Text}) + message) (def: (re-quantify envs baseT) (-> (List (List Type)) Type Type) @@ -270,7 +270,7 @@ (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next))) _ - (///.throw unrecognized-pattern-syntax pattern) + (///.throw not-a-pattern pattern) )) (def: #export (case analyse inputC branches) @@ -292,7 +292,7 @@ outputTC (monad.map @ (|>> product.left coverage.determine) outputT) _ (.case (monad.fold error.Monad<Error> coverage.merge outputHC outputTC) (#error.Success coverage) - (///.assert non-exhaustive-pattern-matching "" + (///.assert non-exhaustive-pattern-matching [inputC branches coverage] (coverage.exhaustive? coverage)) (#error.Error error) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux index 6b2f307ac..1f90bdcff 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux @@ -7,13 +7,13 @@ [data [bit ("bit/." Equivalence<Bit>)] ["." number] - ["e" error ("error/." Monad<Error>)] + ["." error (#+ Error) ("error/." Monad<Error>)] ["." maybe] - [text + ["." text format] [collection - ["." list ("list/." Fold<List>)] - ["dict" dictionary (#+ Dictionary)]]]] + ["." list ("list/." Functor<List> Fold<List>)] + ["." dictionary (#+ Dictionary)]]]] ["." //// ("operation/." Monad<Operation>)] ["." /// (#+ Pattern Variant Operation)]) @@ -24,6 +24,10 @@ (-> (Maybe Nat) Nat) (|>> (maybe.default 0))) +(def: known-cases? + (-> Nat Bit) + (n/> 0)) + ## The coverage of a pattern-matching expression summarizes how well ## all the possible values of an input are being covered by the ## different patterns involved. @@ -53,6 +57,36 @@ _ #0)) +(def: #export (%coverage value) + (Format Coverage) + (case value + #Partial + "#Partial" + + (#Bit value') + (|> value' + %b + (text.enclose ["(#Bit " ")"])) + + (#Variant ?max-cases cases) + (|> cases + dictionary.entries + (list/map (function (_ [idx coverage]) + (format (%n idx) " " (%coverage coverage)))) + (text.join-with " ") + (text.enclose ["{" "}"]) + (format (%n (..cases ?max-cases)) " ") + (text.enclose ["(#Variant " ")"])) + + (#Seq left right) + (format "(#Seq " (%coverage left) " " (%coverage right) ")") + + (#Alt left right) + (format "(#Alt " (%coverage left) " " (%coverage right) ")") + + #Exhaustive + "#Exhaustive")) + (def: #export (determine pattern) (-> Pattern (Operation Coverage)) (case pattern @@ -110,8 +144,8 @@ (wrap (#Variant (if right? (#.Some idx) #.None) - (|> (dict.new number.Hash<Nat>) - (dict.put idx value-coverage))))))) + (|> (dictionary.new number.Hash<Nat>) + (dictionary.put idx value-coverage))))))) (def: (xor left right) (-> Bit Bit Bit) @@ -124,9 +158,8 @@ ## always be a pattern prior to them that would match the input. ## Because of that, the presence of redundant patterns is assumed to ## be a bug, likely due to programmer carelessness. -(def: redundant-pattern - (e.Error Coverage) - (e.fail "Redundant pattern.")) +(exception: #export (redundant-pattern) + "") (def: (flatten-alt coverage) (-> Coverage (List Coverage)) @@ -149,7 +182,7 @@ [(#Variant allR casesR) (#Variant allS casesS)] (and (n/= (cases allR) (cases allS)) - (:: (dict.Equivalence<Dictionary> =) = casesR casesS)) + (:: (dictionary.Equivalence<Dictionary> =) = casesR casesS)) [(#Seq leftR rightR) (#Seq leftS rightS)] (and (= leftR leftS) @@ -168,16 +201,20 @@ (open: "coverage/." Equivalence<Coverage>) +(exception: #export (variants-do-not-match {addition-cases Nat} {so-far-cases Nat}) + (ex.report ["So-far Cases" (%n so-far-cases)] + ["Addition Cases" (%n addition-cases)])) + ## After determining the coverage of each individual pattern, it is ## necessary to merge them all to figure out if the entire ## pattern-matching expression is exhaustive and whether it contains ## redundant patterns. (def: #export (merge addition so-far) - (-> Coverage Coverage (e.Error Coverage)) + (-> Coverage Coverage (Error Coverage)) (case [addition so-far] ## The addition cannot possibly improve the coverage. [_ #Exhaustive] - redundant-pattern + (ex.throw redundant-pattern []) ## The addition completes the coverage. [#Exhaustive _] @@ -192,36 +229,46 @@ (error/wrap #Exhaustive) [(#Variant allA casesA) (#Variant allSF casesSF)] - (cond (not (n/= (cases allSF) (cases allA))) - (e.fail "Variants do not match.") - - (:: (dict.Equivalence<Dictionary> Equivalence<Coverage>) = casesSF casesA) - redundant-pattern - - ## else - (do e.Monad<Error> - [casesM (monad.fold @ - (function (_ [tagA coverageA] casesSF') - (case (dict.get tagA casesSF') - (#.Some coverageSF) - (do @ - [coverageM (merge coverageA coverageSF)] - (wrap (dict.put tagA coverageM casesSF'))) - - #.None - (wrap (dict.put tagA coverageA casesSF')))) - casesSF (dict.entries casesA))] - (wrap (if (let [case-coverages (dict.values casesM)] - (and (n/= (cases allSF) (list.size case-coverages)) - (list.every? exhaustive? case-coverages))) - #Exhaustive - (#Variant allSF casesM))))) + (let [addition-cases (cases allSF) + so-far-cases (cases allA)] + (cond (and (known-cases? addition-cases) + (known-cases? so-far-cases) + (not (n/= addition-cases so-far-cases))) + (ex.throw variants-do-not-match [addition-cases so-far-cases]) + + (:: (dictionary.Equivalence<Dictionary> Equivalence<Coverage>) = casesSF casesA) + (ex.throw redundant-pattern []) + + ## else + (do error.Monad<Error> + [casesM (monad.fold @ + (function (_ [tagA coverageA] casesSF') + (case (dictionary.get tagA casesSF') + (#.Some coverageSF) + (do @ + [coverageM (merge coverageA coverageSF)] + (wrap (dictionary.put tagA coverageM casesSF'))) + + #.None + (wrap (dictionary.put tagA coverageA casesSF')))) + casesSF (dictionary.entries casesA))] + (wrap (if (and (n/= (inc (n/max addition-cases so-far-cases)) + (dictionary.size casesM)) + (list.every? exhaustive? (dictionary.values casesM))) + #Exhaustive + (#Variant (case allSF + (#.Some _) + allSF + + _ + allA) + casesM)))))) [(#Seq leftA rightA) (#Seq leftSF rightSF)] (case [(coverage/= leftSF leftA) (coverage/= rightSF rightA)] ## There is nothing the addition adds to the coverage. [#1 #1] - redundant-pattern + (ex.throw redundant-pattern []) ## The 2 sequences cannot possibly be merged. [#0 #0] @@ -229,7 +276,7 @@ ## Same prefix [#1 #0] - (do e.Monad<Error> + (do error.Monad<Error> [rightM (merge rightA rightSF)] (if (exhaustive? rightM) ## If all that follows is exhaustive, then it can be safely dropped @@ -240,14 +287,14 @@ ## Same suffix [#0 #1] - (do e.Monad<Error> + (do error.Monad<Error> [leftM (merge leftA leftSF)] (wrap (#Seq leftM rightA)))) ## The left part will always match, so the addition is redundant. (^multi [(#Seq left right) single] (coverage/= left single)) - redundant-pattern + (ex.throw redundant-pattern []) ## The right part is not necessary, since it can always match the left. (^multi [single (#Seq left right)] @@ -264,10 +311,10 @@ ## This process must be repeated until no further productive ## merges can be done. [_ (#Alt leftS rightS)] - (do e.Monad<Error> + (do error.Monad<Error> [#let [fuse-once (: (-> Coverage (List Coverage) - (e.Error [(Maybe Coverage) - (List Coverage)])) + (Error [(Maybe Coverage) + (List Coverage)])) (function (_ coverage possibilities) (loop [alts possibilities] (case alts @@ -276,7 +323,7 @@ (#.Cons alt alts') (case (merge coverage alt) - (#e.Success altM) + (#error.Success altM) (case altM (#Alt _) (do @ @@ -286,8 +333,8 @@ _ (wrap [(#.Some altM) alts'])) - (#e.Error error) - (e.fail error)) + (#error.Error error) + (error.fail error)) ))))] [success possibilities] (fuse-once addition (flatten-alt so-far))] (loop [success success @@ -311,6 +358,6 @@ _ (if (coverage/= so-far addition) ## The addition cannot possibly improve the coverage. - redundant-pattern + (ex.throw redundant-pattern []) ## There are now 2 alternative paths. (error/wrap (#Alt so-far addition))))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/expression.lux b/stdlib/source/lux/compiler/default/phase/analysis/expression.lux index c3c3ee619..0f01b48da 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis/expression.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis/expression.lux @@ -5,8 +5,10 @@ ["ex" exception (#+ exception:)]] [data ["." error] - [text - format]] + ["." text + format] + [collection + [list ("list/." Functor<List>)]]] ["." macro]] ["." // (#+ Analysis Operation Phase) ["." type] @@ -21,16 +23,32 @@ [// ["." reference]]]]) -(exception: #export (macro-expansion-failed {message Text}) - message) - -(do-template [<name>] - [(exception: #export (<name> {code Code}) - (%code code))] - - [macro-call-must-have-single-expansion] - [unrecognized-syntax] - ) +(exception: #export (macro-expansion-failed {macro Name} {inputs (List Code)} {error Text}) + (ex.report ["Macro" (%name macro)] + ["Inputs" (|> inputs + (list/map (|>> %code (format "\n\t"))) + (text.join-with ""))] + ["Error" error])) + +(exception: #export (macro-call-must-have-single-expansion {macro Name} {inputs (List Code)}) + (ex.report ["Macro" (%name macro)] + ["Inputs" (|> inputs + (list/map (|>> %code (format "\n\t"))) + (text.join-with ""))])) + +(exception: #export (unrecognized-syntax {code Code}) + (ex.report ["Code" (%code code)])) + +(def: #export (expand-macro name macro inputs) + (-> Name Macro (List Code) (Operation (List Code))) + (extension.lift + (function (_ state) + (case (//macro.expand macro inputs state) + (#error.Error error) + ((///.throw macro-expansion-failed [name inputs error]) state) + + output + output)))) (def: #export (compile code) Phase @@ -103,23 +121,13 @@ (case ?macro (#.Some macro) (do @ - [#let [_ (log! (format (%name def-name) " @@@ " - (%list %code argsC+)))] - expansion (: (Operation (List Code)) - (extension.lift - (function (_ state) - (case (//macro.expand macro argsC+ state) - (#error.Error error) - ((///.throw macro-expansion-failed error) state) - - output - output))))] + [expansion (expand-macro def-name macro argsC+)] (case expansion (^ (list single)) (compile single) _ - (///.throw macro-call-must-have-single-expansion code))) + (///.throw macro-call-must-have-single-expansion [def-name argsC+]))) _ (function.apply compile functionT functionA argsC+))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/macro.lux b/stdlib/source/lux/compiler/default/phase/analysis/macro.lux index c37375805..a674dde07 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis/macro.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis/macro.lux @@ -5,7 +5,7 @@ [data ["." error (#+ Error)] [collection - ["." array (#+ Array)]]] + [array (#+ Array)]]] ["." host (#+ import:)]]) (import: java/lang/reflect/Method @@ -29,7 +29,7 @@ (def: #export (expand macro inputs) (-> Macro (List Code) (Meta (List Code))) - (function (_ compiler) + (function (_ state) (do error.Monad<Error> [apply-method (|> macro (:coerce Object) @@ -38,7 +38,7 @@ output (Method::invoke [(:coerce Object macro) (|> (host.array Object 2) (host.array-write 0 (:coerce Object inputs)) - (host.array-write 1 (:coerce Object compiler)))] + (host.array-write 1 (:coerce Object state)))] apply-method)] (:coerce (Error [Lux (List Code)]) output)))) diff --git a/stdlib/source/lux/compiler/default/phase/statement/total.lux b/stdlib/source/lux/compiler/default/phase/statement/total.lux index d2b046f5f..967f07294 100644 --- a/stdlib/source/lux/compiler/default/phase/statement/total.lux +++ b/stdlib/source/lux/compiler/default/phase/statement/total.lux @@ -1,27 +1,56 @@ (.module: [lux #* [control - [monad (#+ do)] + ["." monad (#+ do)] ["ex" exception (#+ exception:)]] [data [text - format]]] + format]] + ["." macro]] ["." // (#+ Phase) ["/." // + ["." analysis + ["." expression] + ["." type] + [macro (#+ expand)]] ["." extension]]]) -(do-template [<name>] - [(exception: #export (<name> {code Code}) - (ex.report ["Statement" (%code code)]))] +(exception: #export (not-a-statement {code Code}) + (ex.report ["Statement" (%code code)])) - [unrecognized-statement] - ) +(exception: #export (not-a-macro {code Code}) + (ex.report ["Code" (%code code)])) + +(exception: #export (macro-was-not-found {name Name}) + (ex.report ["Name" (%name name)])) (def: #export (phase code) Phase (case code - (^ [_ (#.Form (list& [_ (#.Text extension-name)] extension-args))]) - (extension.apply phase [extension-name extension-args]) + (^ [_ (#.Form (list& [_ (#.Text name)] inputs))]) + (extension.apply phase [name inputs]) + + (^ [_ (#.Form (list& macro inputs))]) + (do ///.Monad<Operation> + [expansion (//.lift-analysis + (do @ + [macroA (type.with-type Macro + (expression.compile macro))] + (case macroA + (^ (analysis.constant macro-name)) + (do @ + [?macro (extension.lift (macro.find-macro macro-name)) + macro (case ?macro + (#.Some macro) + (wrap macro) + + #.None + (///.throw macro-was-not-found macro-name))] + (expression.expand-macro macro-name macro inputs)) + + _ + (///.throw not-a-macro code))))] + (monad.map @ phase expansion)) _ - (///.throw unrecognized-statement code))) + (///.throw not-a-statement code))) diff --git a/stdlib/source/lux/interpreter.lux b/stdlib/source/lux/interpreter.lux index 2feb4b81c..36cef324d 100644 --- a/stdlib/source/lux/interpreter.lux +++ b/stdlib/source/lux/interpreter.lux @@ -131,7 +131,7 @@ (#error.Success [state' output]) (#error.Error error) - (if (ex.match? total.unrecognized-statement error) + (if (ex.match? total.not-a-statement error) (<| (phase.run' state) (:share [anchor expression statement] {(State+ anchor expression statement) |