diff options
Diffstat (limited to 'stdlib/source/lux/compiler/default/phase/analysis')
11 files changed, 2075 insertions, 0 deletions
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case.lux b/stdlib/source/lux/compiler/default/phase/analysis/case.lux new file mode 100644 index 000000000..e523d86a9 --- /dev/null +++ b/stdlib/source/lux/compiler/default/phase/analysis/case.lux @@ -0,0 +1,296 @@ +(.module: + [lux (#- case) + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." product] + ["." error] + ["." maybe] + [text + format] + [collection + ["." list ("list/." Fold<List> Monoid<List> Functor<List>)]]] + ["." type + ["." check]] + ["." macro + ["." code]]] + ["." // (#+ Pattern Analysis Operation Phase) + ["." scope] + ["//." type] + ["." structure] + ["/." // + ["." extension]]] + [/ + ["." coverage]]) + +(exception: #export (cannot-match-with-pattern {type Type} {pattern Code}) + (ex.report ["Type" (%type type)] + ["Pattern" (%code pattern)])) + +(exception: #export (sum-has-no-case {case Nat} {type Type}) + (ex.report ["Case" (%n case)] + ["Type" (%type type)])) + +(exception: #export (unrecognized-pattern-syntax {pattern Code}) + (%code pattern)) + +(exception: #export (cannot-simplify-for-pattern-matching {type Type}) + (%type type)) + +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [cannot-have-empty-branches] + [non-exhaustive-pattern-matching] + ) + +(def: (re-quantify envs baseT) + (-> (List (List Type)) Type Type) + (.case envs + #.Nil + baseT + + (#.Cons head tail) + (re-quantify tail (#.UnivQ head baseT)))) + +## Type-checking on the input value is done during the analysis of a +## "case" expression, to ensure that the patterns being used make +## sense for the type of the input value. +## Sometimes, that input value is complex, by depending on +## type-variables or quantifications. +## This function makes it easier for "case" analysis to properly +## type-check the input with respect to the patterns. +(def: (simplify-case caseT) + (-> Type (Operation Type)) + (loop [envs (: (List (List Type)) + (list)) + caseT caseT] + (.case caseT + (#.Var id) + (do ///.Monad<Operation> + [?caseT' (//type.with-env + (check.read id))] + (.case ?caseT' + (#.Some caseT') + (recur envs caseT') + + _ + (///.throw cannot-simplify-for-pattern-matching caseT))) + + (#.Named name unnamedT) + (recur envs unnamedT) + + (#.UnivQ env unquantifiedT) + (recur (#.Cons env envs) unquantifiedT) + + (#.ExQ _) + (do ///.Monad<Operation> + [[ex-id exT] (//type.with-env + check.existential)] + (recur envs (maybe.assume (type.apply (list exT) caseT)))) + + (#.Apply inputT funcT) + (.case funcT + (#.Var funcT-id) + (do ///.Monad<Operation> + [funcT' (//type.with-env + (do check.Monad<Check> + [?funct' (check.read funcT-id)] + (.case ?funct' + (#.Some funct') + (wrap funct') + + _ + (check.throw cannot-simplify-for-pattern-matching caseT))))] + (recur envs (#.Apply inputT funcT'))) + + _ + (.case (type.apply (list inputT) funcT) + (#.Some outputT) + (recur envs outputT) + + #.None + (///.throw cannot-simplify-for-pattern-matching caseT))) + + (#.Product _) + (|> caseT + type.flatten-tuple + (list/map (re-quantify envs)) + type.tuple + (:: ///.Monad<Operation> wrap)) + + _ + (:: ///.Monad<Operation> wrap (re-quantify envs caseT))))) + +(def: (analyse-primitive type inputT cursor output next) + (All [a] (-> Type Type Cursor Pattern (Operation a) (Operation [Pattern a]))) + (//.with-cursor cursor + (do ///.Monad<Operation> + [_ (//type.with-env + (check.check inputT type)) + outputA next] + (wrap [output outputA])))) + +## This function handles several concerns at once, but it must be that +## way because those concerns are interleaved when doing +## pattern-matching and they cannot be separated. +## The pattern is analysed in order to get a general feel for what is +## expected of the input value. This, in turn, informs the +## type-checking of the input. +## A kind of "continuation" value is passed around which signifies +## what needs to be done _after_ analysing a pattern. +## In general, this is done to analyse the "body" expression +## associated to a particular pattern _in the context of_ said +## pattern. +## The reason why *context* is important is because patterns may bind +## values to local variables, which may in turn be referenced in the +## body expressions. +## That is why the body must be analysed in the context of the +## pattern, and not separately. +(def: (analyse-pattern num-tags inputT pattern next) + (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) + (.case pattern + [cursor (#.Symbol ["" name])] + (//.with-cursor cursor + (do ///.Monad<Operation> + [outputA (scope.with-local [name inputT] + next) + idx scope.next-local] + (wrap [(#//.Bind idx) outputA]))) + + (^template [<type> <input> <output>] + [cursor <input>] + (analyse-primitive <type> inputT cursor (#//.Simple <output>) next)) + ([Bit (#.Bit pattern-value) (#//.Bit pattern-value)] + [Nat (#.Nat pattern-value) (#//.Nat pattern-value)] + [Int (#.Int pattern-value) (#//.Int pattern-value)] + [Rev (#.Rev pattern-value) (#//.Rev pattern-value)] + [Frac (#.Frac pattern-value) (#//.Frac pattern-value)] + [Text (#.Text pattern-value) (#//.Text pattern-value)] + [Any (#.Tuple #.Nil) #//.Unit]) + + (^ [cursor (#.Tuple (list singleton))]) + (analyse-pattern #.None inputT singleton next) + + [cursor (#.Tuple sub-patterns)] + (//.with-cursor cursor + (do ///.Monad<Operation> + [inputT' (simplify-case inputT)] + (.case inputT' + (#.Product _) + (let [subs (type.flatten-tuple inputT') + num-subs (maybe.default (list.size subs) + num-tags) + num-sub-patterns (list.size sub-patterns) + matches (cond (n/< num-subs num-sub-patterns) + (let [[prefix suffix] (list.split (dec num-sub-patterns) subs)] + (list.zip2 (list/compose prefix (list (type.tuple suffix))) sub-patterns)) + + (n/> num-subs num-sub-patterns) + (let [[prefix suffix] (list.split (dec num-subs) sub-patterns)] + (list.zip2 subs (list/compose prefix (list (code.tuple suffix))))) + + ## (n/= num-subs num-sub-patterns) + (list.zip2 subs sub-patterns))] + (do @ + [[memberP+ thenA] (list/fold (: (All [a] + (-> [Type Code] (Operation [(List Pattern) a]) + (Operation [(List Pattern) a]))) + (function (_ [memberT memberC] then) + (do @ + [[memberP [memberP+ thenA]] ((:coerce (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) + analyse-pattern) + #.None memberT memberC then)] + (wrap [(list& memberP memberP+) thenA])))) + (do @ + [nextA next] + (wrap [(list) nextA])) + (list.reverse matches))] + (wrap [(//.product-pattern memberP+) + thenA]))) + + _ + (///.throw cannot-match-with-pattern [inputT pattern]) + ))) + + [cursor (#.Record record)] + (do ///.Monad<Operation> + [record (structure.normalize record) + [members recordT] (structure.order record) + _ (//type.with-env + (check.check inputT recordT))] + (analyse-pattern (#.Some (list.size members)) inputT [cursor (#.Tuple members)] next)) + + [cursor (#.Tag tag)] + (//.with-cursor cursor + (analyse-pattern #.None inputT (` ((~ pattern))) next)) + + (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))]) + (//.with-cursor cursor + (do ///.Monad<Operation> + [inputT' (simplify-case inputT)] + (.case inputT' + (#.Sum _) + (let [flat-sum (type.flatten-variant inputT') + size-sum (list.size flat-sum) + num-cases (maybe.default size-sum num-tags)] + (.case (list.nth idx flat-sum) + (^multi (#.Some caseT) + (n/< num-cases idx)) + (do ///.Monad<Operation> + [[testP nextA] (if (and (n/> num-cases size-sum) + (n/= (dec num-cases) idx)) + (analyse-pattern #.None + (type.variant (list.drop (dec num-cases) flat-sum)) + (` [(~+ values)]) + next) + (analyse-pattern #.None caseT (` [(~+ values)]) next))] + (wrap [(//.sum-pattern num-cases idx testP) + nextA])) + + _ + (///.throw sum-has-no-case [idx inputT]))) + + _ + (///.throw cannot-match-with-pattern [inputT pattern])))) + + (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) + (//.with-cursor cursor + (do ///.Monad<Operation> + [tag (extension.lift (macro.normalize tag)) + [idx group variantT] (extension.lift (macro.resolve-tag tag)) + _ (//type.with-env + (check.check inputT variantT))] + (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next))) + + _ + (///.throw unrecognized-pattern-syntax pattern) + )) + +(def: #export (case analyse inputC branches) + (-> Phase Code (List [Code Code]) (Operation Analysis)) + (.case branches + #.Nil + (///.throw cannot-have-empty-branches "") + + (#.Cons [patternH bodyH] branchesT) + (do ///.Monad<Operation> + [[inputT inputA] (//type.with-inference + (analyse inputC)) + outputH (analyse-pattern #.None inputT patternH (analyse bodyH)) + outputT (monad.map @ + (function (_ [patternT bodyT]) + (analyse-pattern #.None inputT patternT (analyse bodyT))) + branchesT) + outputHC (|> outputH product.left coverage.determine) + 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 "" + (coverage.exhaustive? coverage)) + + (#error.Error error) + (///.fail error))] + (wrap (#//.Case inputA [outputH outputT]))))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux new file mode 100644 index 000000000..24ded5476 --- /dev/null +++ b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux @@ -0,0 +1,325 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)] + equivalence] + [data + [bit ("bit/." Equivalence<Bit>)] + ["." number] + ["e" error ("error/." Monad<Error>)] + ["." maybe] + [text + format] + [collection + ["." list ("list/." Fold<List>)] + ["dict" dictionary (#+ Dictionary)]]]] + ["." //// ("operation/." Monad<Operation>)] + ["." /// (#+ Pattern Variant Operation)]) + +(def: cases + (-> (Maybe Nat) Nat) + (|>> (maybe.default +0))) + +(def: (variant sum-side) + (-> (Either Pattern Pattern) (Variant Pattern)) + (loop [lefts +0 + variantP sum-side] + (case variantP + (#.Left valueP) + (case valueP + (#///.Complex (#///.Sum value-side)) + (recur (inc lefts) value-side) + + _ + {#///.lefts lefts + #///.right? #0 + #///.value valueP}) + + (#.Right valueP) + {#///.lefts lefts + #///.right? #1 + #///.value valueP}))) + +## 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. +## Ideally, the pattern-matching has "exhaustive" coverage, which just +## means that every possible value can be matched by at least 1 +## pattern. +## Every other coverage is considered partial, and it would be valued +## as insuficient (since it could lead to runtime errors due to values +## not being handled by any pattern). +## The #Partial tag covers arbitrary partial coverages in a general +## way, while the other tags cover more specific cases for bits +## and variants. +(type: #export #rec Coverage + #Partial + (#Bit Bit) + (#Variant (Maybe Nat) (Dictionary Nat Coverage)) + (#Seq Coverage Coverage) + (#Alt Coverage Coverage) + #Exhaustive) + +(def: #export (exhaustive? coverage) + (-> Coverage Bit) + (case coverage + (#Exhaustive _) + #1 + + _ + #0)) + +(def: #export (determine pattern) + (-> Pattern (Operation Coverage)) + (case pattern + (^or (#///.Simple #///.Unit) + (#///.Bind _)) + (operation/wrap #Exhaustive) + + ## Primitive patterns always have partial coverage because there + ## are too many possibilities as far as values go. + (^template [<tag>] + (#///.Simple (<tag> _)) + (operation/wrap #Partial)) + ([#///.Nat] + [#///.Int] + [#///.Rev] + [#///.Frac] + [#///.Text]) + + ## Bits are the exception, since there is only "#1" and + ## "#0", which means it is possible for bit + ## pattern-matching to become exhaustive if complementary parts meet. + (#///.Simple (#///.Bit value)) + (operation/wrap (#Bit value)) + + ## Tuple patterns can be exhaustive if there is exhaustiveness for all of + ## their sub-patterns. + (#///.Complex (#///.Product [left right])) + (do ////.Monad<Operation> + [left (determine left) + right (determine right)] + (case right + (#Exhaustive _) + (wrap left) + + _ + (wrap (#Seq left right)))) + + (#///.Complex (#///.Sum sum-side)) + (let [[variant-lefts variant-right? variant-value] (variant sum-side)] + ## Variant patterns can be shown to be exhaustive if all the possible + ## cases are handled exhaustively. + (do ////.Monad<Operation> + [value-coverage (determine variant-value) + #let [variant-idx (if variant-right? + (inc variant-lefts) + variant-lefts)]] + (wrap (#Variant (if variant-right? + (#.Some variant-idx) + #.None) + (|> (dict.new number.Hash<Nat>) + (dict.put variant-idx value-coverage)))))))) + +(def: (xor left right) + (-> Bit Bit Bit) + (or (and left (not right)) + (and (not left) right))) + +## The coverage checker not only verifies that pattern-matching is +## exhaustive, but also that there are no redundant patterns. +## Redundant patterns will never be executed, since there will +## 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.")) + +(def: (flatten-alt coverage) + (-> Coverage (List Coverage)) + (case coverage + (#Alt left right) + (list& left (flatten-alt right)) + + _ + (list coverage))) + +(structure: _ (Equivalence Coverage) + (def: (= reference sample) + (case [reference sample] + [#Exhaustive #Exhaustive] + #1 + + [(#Bit sideR) (#Bit sideS)] + (bit/= sideR sideS) + + [(#Variant allR casesR) (#Variant allS casesS)] + (and (n/= (cases allR) + (cases allS)) + (:: (dict.Equivalence<Dictionary> =) = casesR casesS)) + + [(#Seq leftR rightR) (#Seq leftS rightS)] + (and (= leftR leftS) + (= rightR rightS)) + + [(#Alt _) (#Alt _)] + (let [flatR (flatten-alt reference) + flatS (flatten-alt sample)] + (and (n/= (list.size flatR) (list.size flatS)) + (list.every? (function (_ [coverageR coverageS]) + (= coverageR coverageS)) + (list.zip2 flatR flatS)))) + + _ + #0))) + +(open: "coverage/." Equivalence<Coverage>) + +## 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)) + (case [addition so-far] + ## The addition cannot possibly improve the coverage. + [_ #Exhaustive] + redundant-pattern + + ## The addition completes the coverage. + [#Exhaustive _] + (error/wrap #Exhaustive) + + [#Partial #Partial] + (error/wrap #Partial) + + ## 2 bit coverages are exhaustive if they complement one another. + (^multi [(#Bit sideA) (#Bit sideSF)] + (xor sideA sideSF)) + (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))))) + + [(#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 + + ## The 2 sequences cannot possibly be merged. + [#0 #0] + (error/wrap (#Alt so-far addition)) + + ## Same prefix + [#1 #0] + (do e.Monad<Error> + [rightM (merge rightA rightSF)] + (if (exhaustive? rightM) + ## If all that follows is exhaustive, then it can be safely dropped + ## (since only the "left" part would influence whether the + ## merged coverage is exhaustive or not). + (wrap leftSF) + (wrap (#Seq leftSF rightM)))) + + ## Same suffix + [#0 #1] + (do e.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 + + ## The right part is not necessary, since it can always match the left. + (^multi [single (#Seq left right)] + (coverage/= left single)) + (error/wrap single) + + ## When merging a new coverage against one based on Alt, it may be + ## that one of the many coverages in the Alt is complementary to + ## the new one, so effort must be made to fuse carefully, to match + ## the right coverages together. + ## If one of the Alt sub-coverages matches the new one, the cycle + ## must be repeated, in case the resulting coverage can now match + ## other ones in the original Alt. + ## This process must be repeated until no further productive + ## merges can be done. + [_ (#Alt leftS rightS)] + (do e.Monad<Error> + [#let [fuse-once (: (-> Coverage (List Coverage) + (e.Error [(Maybe Coverage) + (List Coverage)])) + (function (_ coverage possibilities) + (loop [alts possibilities] + (case alts + #.Nil + (wrap [#.None (list coverage)]) + + (#.Cons alt alts') + (case (merge coverage alt) + (#e.Success altM) + (case altM + (#Alt _) + (do @ + [[success alts+] (recur alts')] + (wrap [success (#.Cons alt alts+)])) + + _ + (wrap [(#.Some altM) alts'])) + + (#e.Error error) + (e.fail error)) + ))))] + [success possibilities] (fuse-once addition (flatten-alt so-far))] + (loop [success success + possibilities possibilities] + (case success + (#.Some coverage') + (do @ + [[success' possibilities'] (fuse-once coverage' possibilities)] + (recur success' possibilities')) + + #.None + (case (list.reverse possibilities) + (#.Cons last prevs) + (wrap (list/fold (function (_ left right) (#Alt left right)) + last + prevs)) + + #.Nil + (undefined))))) + + _ + (if (coverage/= so-far addition) + ## The addition cannot possibly improve the coverage. + 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 new file mode 100644 index 000000000..dd27c87e6 --- /dev/null +++ b/stdlib/source/lux/compiler/default/phase/analysis/expression.lux @@ -0,0 +1,121 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["e" error] + [text + format]] + ["." macro]] + ["." // (#+ Analysis Operation Phase) + ["." type] + ["." primitive] + ["." structure] + ["." reference] + ["/." // + ["." extension] + ["//." // (#+ Eval) + ## [".L" macro] + ]]]) + +(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] + ) + +(def: #export (analyser eval) + (-> Eval Phase) + (function (compile code) + (do ///.Monad<Operation> + [expectedT (extension.lift macro.expected-type)] + (let [[cursor code'] code] + ## The cursor must be set in the state for the sake + ## of having useful error messages. + (//.with-cursor cursor + (case code' + (^template [<tag> <analyser>] + (<tag> value) + (<analyser> value)) + ([#.Bit primitive.bit] + [#.Nat primitive.nat] + [#.Int primitive.int] + [#.Rev primitive.rev] + [#.Frac primitive.frac] + [#.Text primitive.text]) + + (^template [<tag> <analyser>] + (^ (#.Form (list& [_ (<tag> tag)] + values))) + (case values + (#.Cons value #.Nil) + (<analyser> compile tag value) + + _ + (<analyser> compile tag (` [(~+ values)])))) + ([#.Nat structure.sum] + [#.Tag structure.tagged-sum]) + + (#.Tag tag) + (structure.tagged-sum compile tag (' [])) + + (^ (#.Tuple (list))) + primitive.unit + + (^ (#.Tuple (list singleton))) + (compile singleton) + + (^ (#.Tuple elems)) + (structure.product compile elems) + + (^ (#.Record pairs)) + (structure.record compile pairs) + + (#.Symbol reference) + (reference.reference reference) + + (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) + (extension.apply compile [extension-name extension-args]) + + ## (^ (#.Form (list& func args))) + ## (do ///.Monad<Operation> + ## [[funcT funcA] (type.with-inference + ## (compile func))] + ## (case funcA + ## [_ (#.Symbol def-name)] + ## (do @ + ## [?macro (///.with-error-tracking + ## (extension.lift (macro.find-macro def-name)))] + ## (case ?macro + ## (#.Some macro) + ## (do @ + ## [expansion (: (Operation (List Code)) + ## (function (_ state) + ## (case (macroL.expand macro args state) + ## (#e.Error error) + ## ((///.throw macro-expansion-failed error) state) + + ## output + ## output)))] + ## (case expansion + ## (^ (list single)) + ## (compile single) + + ## _ + ## (///.throw macro-call-must-have-single-expansion code))) + + ## _ + ## (functionA.apply compile funcT funcA args))) + + ## _ + ## (functionA.apply compile funcT funcA args))) + + _ + (///.throw unrecognized-syntax code) + )))))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/function.lux b/stdlib/source/lux/compiler/default/phase/analysis/function.lux new file mode 100644 index 000000000..13a377df3 --- /dev/null +++ b/stdlib/source/lux/compiler/default/phase/analysis/function.lux @@ -0,0 +1,102 @@ +(.module: + [lux (#- function) + [control + monad + ["ex" exception (#+ exception:)]] + [data + ["." maybe] + ["." text + format] + [collection + ["." list ("list/." Fold<List> Monoid<List> Monad<List>)]]] + ["." type + ["." check]] + ["." macro]] + ["." // (#+ Analysis Operation Phase) + ["." scope] + ["//." type] + ["." inference] + ["/." // + ["." extension]]]) + +(exception: #export (cannot-analyse {expected Type} {function Text} {argument Text} {body Code}) + (ex.report ["Type" (%type expected)] + ["Function" function] + ["Argument" argument] + ["Body" (%code body)])) + +(exception: #export (cannot-apply {function Type} {arguments (List Code)}) + (ex.report [" Function" (%type function)] + ["Arguments" (|> arguments + list.enumerate + (list/map (.function (_ [idx argC]) + (format "\n " (%n idx) " " (%code argC)))) + (text.join-with ""))])) + +(def: #export (function analyse function-name arg-name body) + (-> Phase Text Text Code (Operation Analysis)) + (do ///.Monad<Operation> + [functionT (extension.lift macro.expected-type)] + (loop [expectedT functionT] + (///.with-stack cannot-analyse [expectedT function-name arg-name body] + (case expectedT + (#.Named name unnamedT) + (recur unnamedT) + + (#.Apply argT funT) + (case (type.apply (list argT) funT) + (#.Some value) + (recur value) + + #.None + (///.fail (ex.construct cannot-analyse [expectedT function-name arg-name body]))) + + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[_ instanceT] (//type.with-env <instancer>)] + (recur (maybe.assume (type.apply (list instanceT) expectedT))))) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (recur expectedT') + + ## Inference + _ + (do @ + [[input-id inputT] (//type.with-env check.var) + [output-id outputT] (//type.with-env check.var) + #let [functionT (#.Function inputT outputT)] + functionA (recur functionT) + _ (//type.with-env + (check.check expectedT functionT))] + (wrap functionA)) + )) + + (#.Function inputT outputT) + (<| (:: @ map (.function (_ [scope bodyA]) + (#//.Function (scope.environment scope) bodyA))) + //.with-scope + ## Functions have access not only to their argument, but + ## also to themselves, through a local variable. + (scope.with-local [function-name expectedT]) + (scope.with-local [arg-name inputT]) + (//type.with-type outputT) + (analyse body)) + + _ + (///.fail "") + ))))) + +(def: #export (apply analyse functionT functionA argsC+) + (-> Phase Type Analysis (List Code) (Operation Analysis)) + (<| (///.with-stack cannot-apply [functionT argsC+]) + (do ///.Monad<Operation> + [[applyT argsA+] (inference.general analyse functionT argsC+)]) + (wrap (//.apply [functionA argsA+])))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/inference.lux b/stdlib/source/lux/compiler/default/phase/analysis/inference.lux new file mode 100644 index 000000000..91e28a4ca --- /dev/null +++ b/stdlib/source/lux/compiler/default/phase/analysis/inference.lux @@ -0,0 +1,259 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." maybe] + ["." text + format] + [collection + ["." list ("list/." Functor<List>)]]] + ["." type + ["." check]] + ["." macro]] + ["." /// ("operation/." Monad<Operation>) + ["." extension]] + [// (#+ Tag Analysis Operation Phase)] + ["." //type]) + +(exception: #export (variant-tag-out-of-bounds {size Nat} {tag Tag} {type Type}) + (ex.report ["Tag" (%n tag)] + ["Variant size" (%i (.int size))] + ["Variant type" (%type type)])) + +(exception: #export (cannot-infer {type Type} {args (List Code)}) + (ex.report ["Type" (%type type)] + ["Arguments" (|> args + list.enumerate + (list/map (function (_ [idx argC]) + (format "\n " (%n idx) " " (%code argC)))) + (text.join-with ""))])) + +(exception: #export (cannot-infer-argument {inferred Type} {argument Code}) + (ex.report ["Inferred Type" (%type inferred)] + ["Argument" (%code argument)])) + +(exception: #export (smaller-variant-than-expected {expected Nat} {actual Nat}) + (ex.report ["Expected" (%i (.int expected))] + ["Actual" (%i (.int actual))])) + +(do-template [<name>] + [(exception: #export (<name> {type Type}) + (%type type))] + + [not-a-variant-type] + [not-a-record-type] + [invalid-type-application] + ) + +(def: (replace parameter-idx replacement type) + (-> Nat Type Type Type) + (case type + (#.Primitive name params) + (#.Primitive name (list/map (replace parameter-idx replacement) params)) + + (^template [<tag>] + (<tag> left right) + (<tag> (replace parameter-idx replacement left) + (replace parameter-idx replacement right))) + ([#.Sum] + [#.Product] + [#.Function] + [#.Apply]) + + (#.Parameter idx) + (if (n/= parameter-idx idx) + replacement + type) + + (^template [<tag>] + (<tag> env quantified) + (<tag> (list/map (replace parameter-idx replacement) env) + (replace (n/+ +2 parameter-idx) replacement quantified))) + ([#.UnivQ] + [#.ExQ]) + + _ + type)) + +(def: (named-type cursor id) + (-> Cursor Nat Type) + (let [name (format "{New Type @ " (.cursor-description cursor) " " (%n id) "}")] + (#.Primitive name (list)))) + +(def: new-named-type + (Operation Type) + (do ///.Monad<Operation> + [cursor (extension.lift macro.cursor) + [ex-id _] (//type.with-env check.existential)] + (wrap (named-type cursor ex-id)))) + +## Type-inference works by applying some (potentially quantified) type +## to a sequence of values. +## Function types are used for this, although inference is not always +## done for function application (alternative uses may be records and +## tagged variants). +## But, so long as the type being used for the inference can be treated +## as a function type, this method of inference should work. +(def: #export (general analyse inferT args) + (-> Phase Type (List Code) (Operation [Type (List Analysis)])) + (case args + #.Nil + (do ///.Monad<Operation> + [_ (//type.infer inferT)] + (wrap [inferT (list)])) + + (#.Cons argC args') + (case inferT + (#.Named name unnamedT) + (general analyse unnamedT args) + + (#.UnivQ _) + (do ///.Monad<Operation> + [[var-id varT] (//type.with-env check.var)] + (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) + + (#.ExQ _) + (do ///.Monad<Operation> + [[var-id varT] (//type.with-env check.var) + output (general analyse + (maybe.assume (type.apply (list varT) inferT)) + args) + bound? (//type.with-env + (check.bound? var-id)) + _ (if bound? + (wrap []) + (do @ + [newT new-named-type] + (//type.with-env + (check.check varT newT))))] + (wrap output)) + + (#.Apply inputT transT) + (case (type.apply (list inputT) transT) + (#.Some outputT) + (general analyse outputT args) + + #.None + (///.throw invalid-type-application inferT)) + + ## Arguments are inferred back-to-front because, by convention, + ## Lux functions take the most important arguments *last*, which + ## means that the most information for doing proper inference is + ## located in the last arguments to a function call. + ## By inferring back-to-front, a lot of type-annotations can be + ## avoided in Lux code, since the inference algorithm can piece + ## things together more easily. + (#.Function inputT outputT) + (do ///.Monad<Operation> + [[outputT' args'A] (general analyse outputT args') + argA (<| (///.with-stack cannot-infer-argument [inputT argC]) + (//type.with-type inputT) + (analyse argC))] + (wrap [outputT' (list& argA args'A)])) + + (#.Var infer-id) + (do ///.Monad<Operation> + [?inferT' (//type.with-env (check.read infer-id))] + (case ?inferT' + (#.Some inferT') + (general analyse inferT' args) + + _ + (///.throw cannot-infer [inferT args]))) + + _ + (///.throw cannot-infer [inferT args])) + )) + +## Turns a record type into the kind of function type suitable for inference. +(def: #export (record inferT) + (-> Type (Operation Type)) + (case inferT + (#.Named name unnamedT) + (record unnamedT) + + (^template [<tag>] + (<tag> env bodyT) + (do ///.Monad<Operation> + [bodyT+ (record bodyT)] + (wrap (<tag> env bodyT+)))) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (record outputT) + + #.None + (///.throw invalid-type-application inferT)) + + (#.Product _) + (operation/wrap (type.function (type.flatten-tuple inferT) inferT)) + + _ + (///.throw not-a-record-type inferT))) + +## Turns a variant type into the kind of function type suitable for inference. +(def: #export (variant tag expected-size inferT) + (-> Nat Nat Type (Operation Type)) + (loop [depth +0 + currentT inferT] + (case currentT + (#.Named name unnamedT) + (do ///.Monad<Operation> + [unnamedT+ (recur depth unnamedT)] + (wrap unnamedT+)) + + (^template [<tag>] + (<tag> env bodyT) + (do ///.Monad<Operation> + [bodyT+ (recur (inc depth) bodyT)] + (wrap (<tag> env bodyT+)))) + ([#.UnivQ] + [#.ExQ]) + + (#.Sum _) + (let [cases (type.flatten-variant currentT) + actual-size (list.size cases) + boundary (dec expected-size)] + (cond (or (n/= expected-size actual-size) + (and (n/> expected-size actual-size) + (n/< boundary tag))) + (case (list.nth tag cases) + (#.Some caseT) + (operation/wrap (if (n/= +0 depth) + (type.function (list caseT) currentT) + (let [replace' (replace (|> depth dec (n/* +2)) inferT)] + (type.function (list (replace' caseT)) + (replace' currentT))))) + + #.None + (///.throw variant-tag-out-of-bounds [expected-size tag inferT])) + + (n/< expected-size actual-size) + (///.throw smaller-variant-than-expected [expected-size actual-size]) + + (n/= boundary tag) + (let [caseT (type.variant (list.drop boundary cases))] + (operation/wrap (if (n/= +0 depth) + (type.function (list caseT) currentT) + (let [replace' (replace (|> depth dec (n/* +2)) inferT)] + (type.function (list (replace' caseT)) + (replace' currentT)))))) + + ## else + (///.throw variant-tag-out-of-bounds [expected-size tag inferT]))) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (variant tag expected-size outputT) + + #.None + (///.throw invalid-type-application inferT)) + + _ + (///.throw not-a-variant-type inferT)))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/module.lux b/stdlib/source/lux/compiler/default/phase/analysis/module.lux new file mode 100644 index 000000000..adc442c1f --- /dev/null +++ b/stdlib/source/lux/compiler/default/phase/analysis/module.lux @@ -0,0 +1,255 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)] + pipe] + [data + ["." text ("text/." Equivalence<Text>) + format] + ["." error] + [collection + ["." list ("list/." Fold<List> Functor<List>)] + [dictionary + ["." plist]]]] + ["." macro]] + ["." // (#+ Operation) + ["/." // + ["." extension]]]) + +(type: #export Tag Text) + +(exception: #export (unknown-module {module Text}) + module) + +(exception: #export (cannot-declare-tag-twice {module Text} {tag Text}) + (ex.report ["Module" module] + ["Tag" tag])) + +(do-template [<name>] + [(exception: #export (<name> {tags (List Text)} {owner Type}) + (ex.report ["Tags" (text.join-with " " tags)] + ["Type" (%type owner)]))] + + [cannot-declare-tags-for-unnamed-type] + [cannot-declare-tags-for-foreign-type] + ) + +(exception: #export (cannot-define-more-than-once {name Ident}) + (%ident name)) + +(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State}) + (ex.report ["Module" module] + ["Desired state" (case state + #.Active "Active" + #.Compiled "Compiled" + #.Cached "Cached")])) + +(exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code}) + (ex.report ["Module" module] + ["Old annotations" (%code old)] + ["New annotations" (%code new)])) + +(def: (new hash) + (-> Nat Module) + {#.module-hash hash + #.module-aliases (list) + #.definitions (list) + #.imports (list) + #.tags (list) + #.types (list) + #.module-annotations #.None + #.module-state #.Active}) + +(def: #export (set-annotations annotations) + (-> Code (Operation Any)) + (do ///.Monad<Operation> + [self-name (extension.lift macro.current-module-name) + self (extension.lift macro.current-module)] + (case (get@ #.module-annotations self) + #.None + (extension.lift + (function (_ state) + (#error.Success [(update@ #.modules + (plist.put self-name (set@ #.module-annotations (#.Some annotations) self)) + state) + []]))) + + (#.Some old) + (///.throw cannot-set-module-annotations-more-than-once [self-name old annotations])))) + +(def: #export (import module) + (-> Text (Operation Any)) + (do ///.Monad<Operation> + [self-name (extension.lift macro.current-module-name)] + (extension.lift + (function (_ state) + (#error.Success [(update@ #.modules + (plist.update self-name (update@ #.imports (|>> (#.Cons module)))) + state) + []]))))) + +(def: #export (alias alias module) + (-> Text Text (Operation Any)) + (do ///.Monad<Operation> + [self-name (extension.lift macro.current-module-name)] + (extension.lift + (function (_ state) + (#error.Success [(update@ #.modules + (plist.update self-name (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text])) + (|>> (#.Cons [alias module]))))) + state) + []]))))) + +(def: #export (exists? module) + (-> Text (Operation Bit)) + (extension.lift + (function (_ state) + (|> state + (get@ #.modules) + (plist.get module) + (case> (#.Some _) #1 #.None #0) + [state] #error.Success)))) + +(def: #export (define name definition) + (-> Text Definition (Operation [])) + (do ///.Monad<Operation> + [self-name (extension.lift macro.current-module-name) + self (extension.lift macro.current-module)] + (extension.lift + (function (_ state) + (case (plist.get name (get@ #.definitions self)) + #.None + (#error.Success [(update@ #.modules + (plist.put self-name + (update@ #.definitions + (: (-> (List [Text Definition]) (List [Text Definition])) + (|>> (#.Cons [name definition]))) + self)) + state) + []]) + + (#.Some already-existing) + ((///.throw cannot-define-more-than-once [self-name name]) state)))))) + +(def: #export (create hash name) + (-> Nat Text (Operation [])) + (extension.lift + (function (_ state) + (let [module (new hash)] + (#error.Success [(update@ #.modules + (plist.put name module) + state) + []]))))) + +(def: #export (with-module hash name action) + (All [a] (-> Nat Text (Operation a) (Operation [Module a]))) + (do ///.Monad<Operation> + [_ (create hash name) + output (//.with-current-module name + action) + module (extension.lift (macro.find-module name))] + (wrap [module output]))) + +(do-template [<setter> <asker> <tag>] + [(def: #export (<setter> module-name) + (-> Text (Operation Any)) + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (let [active? (case (get@ #.module-state module) + #.Active #1 + _ #0)] + (if active? + (#error.Success [(update@ #.modules + (plist.put module-name (set@ #.module-state <tag> module)) + state) + []]) + ((///.throw can-only-change-state-of-active-module [module-name <tag>]) + state))) + + #.None + ((///.throw unknown-module module-name) state))))) + + (def: #export (<asker> module-name) + (-> Text (Operation Bit)) + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (#error.Success [state + (case (get@ #.module-state module) + <tag> #1 + _ #0)]) + + #.None + ((///.throw unknown-module module-name) state)))))] + + [set-active active? #.Active] + [set-compiled compiled? #.Compiled] + [set-cached cached? #.Cached] + ) + +(do-template [<name> <tag> <type>] + [(def: (<name> module-name) + (-> Text (Operation <type>)) + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (#error.Success [state (get@ <tag> module)]) + + #.None + ((///.throw unknown-module module-name) state)))))] + + [tags #.tags (List [Text [Nat (List Ident) Bit Type]])] + [types #.types (List [Text [(List Ident) Bit Type]])] + [hash #.module-hash Nat] + ) + +(def: (ensure-undeclared-tags module-name tags) + (-> Text (List Tag) (Operation Any)) + (do ///.Monad<Operation> + [bindings (..tags module-name) + _ (monad.map @ + (function (_ tag) + (case (plist.get tag bindings) + #.None + (wrap []) + + (#.Some _) + (///.throw cannot-declare-tag-twice [module-name tag]))) + tags)] + (wrap []))) + +(def: #export (declare-tags tags exported? type) + (-> (List Tag) Bit Type (Operation Any)) + (do ///.Monad<Operation> + [self-name (extension.lift macro.current-module-name) + [type-module type-name] (case type + (#.Named type-ident _) + (wrap type-ident) + + _ + (///.throw cannot-declare-tags-for-unnamed-type [tags type])) + _ (ensure-undeclared-tags self-name tags) + _ (///.assert cannot-declare-tags-for-foreign-type [tags type] + (text/= self-name type-module))] + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get self-name)) + (#.Some module) + (let [namespaced-tags (list/map (|>> [self-name]) tags)] + (#error.Success [(update@ #.modules + (plist.update self-name + (|>> (update@ #.tags (function (_ tag-bindings) + (list/fold (function (_ [idx tag] table) + (plist.put tag [idx namespaced-tags exported? type] table)) + tag-bindings + (list.enumerate tags)))) + (update@ #.types (plist.put type-name [namespaced-tags exported? type])))) + state) + []])) + #.None + ((///.throw unknown-module self-name) state)))))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/primitive.lux b/stdlib/source/lux/compiler/default/phase/analysis/primitive.lux new file mode 100644 index 000000000..bd42825d3 --- /dev/null +++ b/stdlib/source/lux/compiler/default/phase/analysis/primitive.lux @@ -0,0 +1,29 @@ +(.module: + [lux (#- nat int rev) + [control + monad]] + ["." // (#+ Analysis Operation) + [".A" type] + ["/." //]]) + +## [Analysers] +(do-template [<name> <type> <tag>] + [(def: #export (<name> value) + (-> <type> (Operation Analysis)) + (do ///.Monad<Operation> + [_ (typeA.infer <type>)] + (wrap (#//.Primitive (<tag> value)))))] + + [bit Bit #//.Bit] + [nat Nat #//.Nat] + [int Int #//.Int] + [rev Rev #//.Rev] + [frac Frac #//.Frac] + [text Text #//.Text] + ) + +(def: #export unit + (Operation Analysis) + (do ///.Monad<Operation> + [_ (typeA.infer Any)] + (wrap (#//.Primitive #//.Unit)))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/reference.lux b/stdlib/source/lux/compiler/default/phase/analysis/reference.lux new file mode 100644 index 000000000..bb78a32fb --- /dev/null +++ b/stdlib/source/lux/compiler/default/phase/analysis/reference.lux @@ -0,0 +1,79 @@ +(.module: + [lux #* + [control + monad + ["ex" exception (#+ exception:)]] + ["." macro] + [data + [text ("text/." Equivalence<Text>) + format]]] + ["." // (#+ Analysis Operation) + ["." scope] + ["." type] + ["/." // + ["." extension] + [// + ["." reference]]]]) + +(exception: #export (foreign-module-has-not-been-imported {current Text} {foreign Text}) + (ex.report ["Current" current] + ["Foreign" foreign])) + +(exception: #export (definition-has-not-been-expored {definition Ident}) + (ex.report ["Definition" (%ident definition)])) + +## [Analysers] +(def: (definition def-name) + (-> Ident (Operation Analysis)) + (with-expansions [<return> (wrap (|> def-name reference.constant #//.Reference))] + (do ///.Monad<Operation> + [[actualT def-anns _] (extension.lift (macro.find-def def-name))] + (case (macro.get-symbol-ann (ident-for #.alias) def-anns) + (#.Some real-def-name) + (definition real-def-name) + + _ + (do @ + [_ (type.infer actualT) + (^@ def-name [::module ::name]) (extension.lift (macro.normalize def-name)) + current (extension.lift macro.current-module-name)] + (if (text/= current ::module) + <return> + (if (macro.export? def-anns) + (do @ + [imported! (extension.lift (macro.imported-by? ::module current))] + (if imported! + <return> + (///.throw foreign-module-has-not-been-imported [current ::module]))) + (///.throw definition-has-not-been-expored def-name)))))))) + +(def: (variable var-name) + (-> Text (Operation (Maybe Analysis))) + (do ///.Monad<Operation> + [?var (scope.find var-name)] + (case ?var + (#.Some [actualT ref]) + (do @ + [_ (type.infer actualT)] + (wrap (#.Some (|> ref reference.variable #//.Reference)))) + + #.None + (wrap #.None)))) + +(def: #export (reference reference) + (-> Ident (Operation Analysis)) + (case reference + ["" simple-name] + (do ///.Monad<Operation> + [?var (variable simple-name)] + (case ?var + (#.Some varA) + (wrap varA) + + #.None + (do @ + [this-module (extension.lift macro.current-module-name)] + (definition [this-module simple-name])))) + + _ + (definition reference))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/scope.lux b/stdlib/source/lux/compiler/default/phase/analysis/scope.lux new file mode 100644 index 000000000..a3f7e926c --- /dev/null +++ b/stdlib/source/lux/compiler/default/phase/analysis/scope.lux @@ -0,0 +1,197 @@ +(.module: + [lux #* + [control + monad] + [data + [text ("text/." Equivalence<Text>) + format] + ["." maybe ("maybe/." Monad<Maybe>)] + ["." product] + ["e" error] + [collection + ["." list ("list/." Functor<List> Fold<List> Monoid<List>)] + [dictionary + ["." plist]]]]] + [// (#+ Operation Phase) + ["/." // + ["." extension] + [// + ["." reference (#+ Register Variable)]]]]) + +(type: Local (Bindings Text [Type Register])) +(type: Foreign (Bindings Text [Type Variable])) + +(def: (local? name scope) + (-> Text Scope Bit) + (|> scope + (get@ [#.locals #.mappings]) + (plist.contains? name))) + +(def: (local name scope) + (-> Text Scope (Maybe [Type Variable])) + (|> scope + (get@ [#.locals #.mappings]) + (plist.get name) + (maybe/map (function (_ [type value]) + [type (#reference.Local value)])))) + +(def: (captured? name scope) + (-> Text Scope Bit) + (|> scope + (get@ [#.captured #.mappings]) + (plist.contains? name))) + +(def: (captured name scope) + (-> Text Scope (Maybe [Type Variable])) + (loop [idx +0 + mappings (get@ [#.captured #.mappings] scope)] + (case mappings + #.Nil + #.None + + (#.Cons [_name [_source-type _source-ref]] mappings') + (if (text/= name _name) + (#.Some [_source-type (#reference.Foreign idx)]) + (recur (inc idx) mappings'))))) + +(def: (reference? name scope) + (-> Text Scope Bit) + (or (local? name scope) + (captured? name scope))) + +(def: (reference name scope) + (-> Text Scope (Maybe [Type Variable])) + (case (..local name scope) + (#.Some type) + (#.Some type) + + _ + (..captured name scope))) + +(def: #export (find name) + (-> Text (Operation (Maybe [Type Variable]))) + (extension.lift + (function (_ state) + (let [[inner outer] (|> state + (get@ #.scopes) + (list.split-with (|>> (reference? name) not)))] + (case outer + #.Nil + (#.Right [state #.None]) + + (#.Cons top-outer _) + (let [[ref-type init-ref] (maybe.default (undefined) + (..reference name top-outer)) + [ref inner'] (list/fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)]) + (function (_ scope ref+inner) + [(#reference.Foreign (get@ [#.captured #.counter] scope)) + (#.Cons (update@ #.captured + (: (-> Foreign Foreign) + (|>> (update@ #.counter inc) + (update@ #.mappings (plist.put name [ref-type (product.left ref+inner)])))) + scope) + (product.right ref+inner))])) + [init-ref #.Nil] + (list.reverse inner)) + scopes (list/compose inner' outer)] + (#.Right [(set@ #.scopes scopes state) + (#.Some [ref-type ref])])) + ))))) + +(def: #export (with-local [name type] action) + (All [a] (-> [Text Type] (Operation a) (Operation a))) + (function (_ [bundle state]) + (case (get@ #.scopes state) + (#.Cons head tail) + (let [old-mappings (get@ [#.locals #.mappings] head) + new-var-id (get@ [#.locals #.counter] head) + new-head (update@ #.locals + (: (-> Local Local) + (|>> (update@ #.counter inc) + (update@ #.mappings (plist.put name [type new-var-id])))) + head)] + (case (///.run' [bundle (set@ #.scopes (#.Cons new-head tail) state)] + action) + (#e.Success [[bundle' state'] output]) + (case (get@ #.scopes state') + (#.Cons head' tail') + (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head') + tail')] + (#e.Success [[bundle' (set@ #.scopes scopes' state')] + output])) + + _ + (error! "Invalid scope alteration.")) + + (#e.Error error) + (#e.Error error))) + + _ + (#e.Error "Cannot create local binding without a scope.")) + )) + +(do-template [<name> <val-type>] + [(def: <name> + (Bindings Text [Type <val-type>]) + {#.counter +0 + #.mappings (list)})] + + [init-locals Nat] + [init-captured Variable] + ) + +(def: (scope parent-name child-name) + (-> (List Text) Text Scope) + {#.name (list& child-name parent-name) + #.inner +0 + #.locals init-locals + #.captured init-captured}) + +(def: #export (with-scope name action) + (All [a] (-> Text (Operation a) (Operation a))) + (function (_ [bundle state]) + (let [parent-name (case (get@ #.scopes state) + #.Nil + (list) + + (#.Cons top _) + (get@ #.name top))] + (case (action [bundle (update@ #.scopes + (|>> (#.Cons (scope parent-name name))) + state)]) + (#e.Error error) + (#e.Error error) + + (#e.Success [[bundle' state'] output]) + (#e.Success [[bundle' (update@ #.scopes + (|>> list.tail (maybe.default (list))) + state')] + output]) + )) + )) + +(def: #export next-local + (Operation Register) + (extension.lift + (function (_ state) + (case (get@ #.scopes state) + #.Nil + (#e.Error "Cannot get next reference when there is no scope.") + + (#.Cons top _) + (#e.Success [state (get@ [#.locals #.counter] top)]))))) + +(def: (ref-to-variable ref) + (-> Ref Variable) + (case ref + (#.Local register) + (#reference.Local register) + + (#.Captured register) + (#reference.Foreign register))) + +(def: #export (environment scope) + (-> Scope (List Variable)) + (|> scope + (get@ [#.captured #.mappings]) + (list/map (function (_ [_ [_ ref]]) (ref-to-variable ref))))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/structure.lux b/stdlib/source/lux/compiler/default/phase/analysis/structure.lux new file mode 100644 index 000000000..c50383eb8 --- /dev/null +++ b/stdlib/source/lux/compiler/default/phase/analysis/structure.lux @@ -0,0 +1,360 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." ident] + ["." number] + ["." product] + ["." maybe] + [text + format] + [collection + ["." list ("list/." Functor<List>)] + ["dict" dictionary (#+ Dictionary)]]] + ["." type + ["." check]] + ["." macro + ["." code]]] + ["." // (#+ Tag Analysis Operation Phase) + ["//." type] + ["." primitive] + ["." inference] + ["/." // + ["." extension] + ["//." //]]]) + +(exception: #export (invalid-variant-type {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%type type)] + ["Tag" (%n tag)] + ["Expression" (%code code)])) + +(do-template [<name>] + [(exception: #export (<name> {type Type} {members (List Code)}) + (ex.report ["Type" (%type type)] + ["Expression" (%code (` [(~+ members)]))]))] + + [invalid-tuple-type] + [cannot-analyse-tuple] + ) + +(exception: #export (not-a-quantified-type {type Type}) + (%type type)) + +(do-template [<name>] + [(exception: #export (<name> {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%type type)] + ["Tag" (%n tag)] + ["Expression" (%code code)]))] + + [cannot-analyse-variant] + [cannot-infer-numeric-tag] + ) + +(exception: #export (record-keys-must-be-tags {key Code} {record (List [Code Code])}) + (ex.report ["Key" (%code key)] + ["Record" (%code (code.record record))])) + +(do-template [<name>] + [(exception: #export (<name> {key Ident} {record (List [Ident Code])}) + (ex.report ["Tag" (%code (code.tag key))] + ["Record" (%code (code.record (list/map (function (_ [keyI valC]) + [(code.tag keyI) valC]) + record)))]))] + + [cannot-repeat-tag] + ) + +(exception: #export (tag-does-not-belong-to-record {key Ident} {type Type}) + (ex.report ["Tag" (%code (code.tag key))] + ["Type" (%type type)])) + +(exception: #export (record-size-mismatch {expected Nat} {actual Nat} {type Type} {record (List [Ident Code])}) + (ex.report ["Expected" (|> expected .int %i)] + ["Actual" (|> actual .int %i)] + ["Type" (%type type)] + ["Expression" (%code (|> record + (list/map (function (_ [keyI valueC]) + [(code.tag keyI) valueC])) + code.record))])) + +(def: #export (sum analyse tag valueC) + (-> Phase Nat Code (Operation Analysis)) + (do ///.Monad<Operation> + [expectedT (extension.lift macro.expected-type)] + (///.with-stack cannot-analyse-variant [expectedT tag valueC] + (case expectedT + (#.Sum _) + (let [flat (type.flatten-variant expectedT) + type-size (list.size flat)] + (case (list.nth tag flat) + (#.Some variant-type) + (do @ + [valueA (//type.with-type variant-type + (analyse valueC))] + (wrap (//.sum-analysis type-size tag valueA))) + + #.None + (///.throw inference.variant-tag-out-of-bounds [type-size tag expectedT]))) + + (#.Named name unnamedT) + (//type.with-type unnamedT + (sum analyse tag valueC)) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (//type.with-type expectedT' + (sum analyse tag valueC)) + + _ + ## Cannot do inference when the tag is numeric. + ## This is because there is no way of knowing how many + ## cases the inferred sum type would have. + (///.throw cannot-infer-numeric-tag [expectedT tag valueC]) + )) + + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[instance-id instanceT] (//type.with-env <instancer>)] + (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + (sum analyse tag valueC)))) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT-id) + (do @ + [?funT' (//type.with-env (check.read funT-id))] + (case ?funT' + (#.Some funT') + (//type.with-type (#.Apply inputT funT') + (sum analyse tag valueC)) + + _ + (///.throw invalid-variant-type [expectedT tag valueC]))) + + _ + (case (type.apply (list inputT) funT) + #.None + (///.throw not-a-quantified-type funT) + + (#.Some outputT) + (//type.with-type outputT + (sum analyse tag valueC)))) + + _ + (///.throw invalid-variant-type [expectedT tag valueC]))))) + +(def: (typed-product analyse membersC+) + (-> Phase (List Code) (Operation Analysis)) + (do ///.Monad<Operation> + [expectedT (extension.lift macro.expected-type)] + (loop [expectedT expectedT + membersC+ membersC+] + (case [expectedT membersC+] + ## If the tuple runs out, whatever expression is the last gets + ## matched to the remaining type. + [tailT (#.Cons tailC #.Nil)] + (//type.with-type tailT + (analyse tailC)) + + ## If the type and the code are still ongoing, match each + ## sub-expression to its corresponding type. + [(#.Product leftT rightT) (#.Cons leftC rightC)] + (do @ + [leftA (//type.with-type leftT + (analyse leftC)) + rightA (recur rightT rightC)] + (wrap (#//.Structure (#//.Product leftA rightA)))) + + ## If, however, the type runs out but there is still enough + ## tail, the remaining elements get packaged into another + ## tuple. + ## The reason for this is that it is assumed that the type of + ## the tuple represents the expectations of the user. + ## If the type is for a 3-tuple, but a 5-tuple is provided, it + ## is assumed that the user intended the following layout: + ## [0, 1, [2, 3, 4]] + ## but that, for whatever reason, it was written in a flat + ## way. + [tailT tailC] + (|> tailC + code.tuple + analyse + (//type.with-type tailT) + (:: @ map (|>> //.no-op))))))) + +(def: #export (product analyse membersC) + (-> Phase (List Code) (Operation Analysis)) + (do ///.Monad<Operation> + [expectedT (extension.lift macro.expected-type)] + (///.with-stack cannot-analyse-tuple [expectedT membersC] + (case expectedT + (#.Product _) + (..typed-product analyse membersC) + + (#.Named name unnamedT) + (//type.with-type unnamedT + (product analyse membersC)) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (//type.with-type expectedT' + (product analyse membersC)) + + _ + ## Must do inference... + (do @ + [membersTA (monad.map @ (|>> analyse //type.with-inference) + membersC) + _ (//type.with-env + (check.check expectedT + (type.tuple (list/map product.left membersTA))))] + (wrap (//.product-analysis (list/map product.right membersTA)))))) + + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[instance-id instanceT] (//type.with-env <instancer>)] + (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + (product analyse membersC)))) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT-id) + (do @ + [?funT' (//type.with-env (check.read funT-id))] + (case ?funT' + (#.Some funT') + (//type.with-type (#.Apply inputT funT') + (product analyse membersC)) + + _ + (///.throw invalid-tuple-type [expectedT membersC]))) + + _ + (case (type.apply (list inputT) funT) + #.None + (///.throw not-a-quantified-type funT) + + (#.Some outputT) + (//type.with-type outputT + (product analyse membersC)))) + + _ + (///.throw invalid-tuple-type [expectedT membersC]) + )))) + +(def: #export (tagged-sum analyse tag valueC) + (-> Phase Ident Code (Operation Analysis)) + (do ///.Monad<Operation> + [tag (extension.lift (macro.normalize tag)) + [idx group variantT] (extension.lift (macro.resolve-tag tag)) + expectedT (extension.lift macro.expected-type)] + (case expectedT + (#.Var _) + (do @ + [#let [case-size (list.size group)] + inferenceT (inference.variant idx case-size variantT) + [inferredT valueA+] (inference.general analyse inferenceT (list valueC))] + (wrap (//.sum-analysis case-size idx (|> valueA+ list.head maybe.assume)))) + + _ + (..sum analyse idx valueC)))) + +## There cannot be any ambiguity or improper syntax when analysing +## records, so they must be normalized for further analysis. +## Normalization just means that all the tags get resolved to their +## canonical form (with their corresponding module identified). +(def: #export (normalize record) + (-> (List [Code Code]) (Operation (List [Ident Code]))) + (monad.map ///.Monad<Operation> + (function (_ [key val]) + (case key + [_ (#.Tag key)] + (do ///.Monad<Operation> + [key (extension.lift (macro.normalize key))] + (wrap [key val])) + + _ + (///.throw record-keys-must-be-tags [key record]))) + record)) + +## Lux already possesses the means to analyse tuples, so +## re-implementing the same functionality for records makes no sense. +## Records, thus, get transformed into tuples by ordering the elements. +(def: #export (order record) + (-> (List [Ident Code]) (Operation [(List Code) Type])) + (case record + ## empty-record = empty-tuple = unit = [] + #.Nil + (:: ///.Monad<Operation> wrap [(list) Any]) + + (#.Cons [head-k head-v] _) + (do ///.Monad<Operation> + [head-k (extension.lift (macro.normalize head-k)) + [_ tag-set recordT] (extension.lift (macro.resolve-tag head-k)) + #let [size-record (list.size record) + size-ts (list.size tag-set)] + _ (if (n/= size-ts size-record) + (wrap []) + (///.throw record-size-mismatch [size-ts size-record recordT record])) + #let [tuple-range (list.n/range +0 (dec size-ts)) + tag->idx (dict.from-list ident.Hash<Ident> (list.zip2 tag-set tuple-range))] + idx->val (monad.fold @ + (function (_ [key val] idx->val) + (do @ + [key (extension.lift (macro.normalize key))] + (case (dict.get key tag->idx) + #.None + (///.throw tag-does-not-belong-to-record [key recordT]) + + (#.Some idx) + (if (dict.contains? idx idx->val) + (///.throw cannot-repeat-tag [key record]) + (wrap (dict.put idx val idx->val)))))) + (: (Dictionary Nat Code) + (dict.new number.Hash<Nat>)) + record) + #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val))) + tuple-range)]] + (wrap [ordered-tuple recordT])) + )) + +(def: #export (record analyse members) + (-> Phase (List [Code Code]) (Operation Analysis)) + (do ///.Monad<Operation> + [members (normalize members) + [membersC recordT] (order members)] + (case membersC + (^ (list)) + primitive.unit + + (^ (list singletonC)) + (analyse singletonC) + + _ + (do @ + [expectedT (extension.lift macro.expected-type)] + (case expectedT + (#.Var _) + (do @ + [inferenceT (inference.record recordT) + [inferredT membersA] (inference.general analyse inferenceT membersC)] + (wrap (//.product-analysis membersA))) + + _ + (..product analyse membersC)))))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/type.lux b/stdlib/source/lux/compiler/default/phase/analysis/type.lux new file mode 100644 index 000000000..3eb574986 --- /dev/null +++ b/stdlib/source/lux/compiler/default/phase/analysis/type.lux @@ -0,0 +1,52 @@ +(.module: + [lux #* + [control + [monad (#+ do)]] + [data + ["." error]] + ["." function] + [type + ["tc" check]] + ["." macro]] + [// (#+ Operation) + ["/." // + ["." extension]]]) + +(def: #export (with-type expected) + (All [a] (-> Type (Operation a) (Operation a))) + (extension.localized (get@ #.expected) (set@ #.expected) + (function.constant (#.Some expected)))) + +(def: #export (with-env action) + (All [a] (-> (tc.Check a) (Operation a))) + (function (_ (^@ stateE [bundle state])) + (case (action (get@ #.type-context state)) + (#error.Error error) + ((///.fail error) stateE) + + (#error.Success [context' output]) + (#error.Success [[bundle (set@ #.type-context context' state)] + output])))) + +(def: #export with-fresh-env + (All [a] (-> (Operation a) (Operation a))) + (extension.localized (get@ #.type-context) (set@ #.type-context) + (function.constant tc.fresh-context))) + +(def: #export (infer actualT) + (-> Type (Operation Any)) + (do ///.Monad<Operation> + [expectedT (extension.lift macro.expected-type)] + (with-env + (tc.check expectedT actualT)))) + +(def: #export (with-inference action) + (All [a] (-> (Operation a) (Operation [Type a]))) + (do ///.Monad<Operation> + [[_ varT] (..with-env + tc.var) + output (with-type varT + action) + knownT (..with-env + (tc.clean varT))] + (wrap [knownT output]))) |