diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis.lux | 40 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/case.lux | 312 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/case/coverage.lux | 106 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/common.lux | 12 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/expression.lux | 106 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/function.lux | 84 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/inference.lux | 188 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/primitive.lux | 22 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/procedure.lux | 20 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/procedure/common.lux | 168 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux | 1130 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/reference.lux | 44 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/structure.lux | 278 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/type.lux | 18 |
14 files changed, 1264 insertions, 1264 deletions
diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux index f6163feb1..107d4979e 100644 --- a/new-luxc/source/luxc/lang/analysis.lux +++ b/new-luxc/source/luxc/lang/analysis.lux @@ -1,9 +1,9 @@ -(;module: +(.module: lux (lux [function] (data (coll [list "list/" Fold<List>])) (macro [code])) - (luxc (lang [";L" variable #+ Variable]))) + (luxc (lang [".L" variable #+ Variable]))) (type: #export Pattern Code) @@ -28,23 +28,23 @@ (def: #export (sum tag size temp value) (-> Nat Nat Nat Analysis Analysis) - (if (n.= (n.dec size) tag) - (if (n.= +1 tag) + (if (n/= (n/dec size) tag) + (if (n/= +1 tag) (sum-right value) - (list/fold (function;const sum-left) + (list/fold (function.const sum-left) (sum-right value) - (list;n.range +0 (n.- +2 tag)))) - (list/fold (function;const sum-left) + (list.n/range +0 (n/- +2 tag)))) + (list/fold (function.const sum-left) (case value (^or (^code ("lux sum left" (~ inner))) (^code ("lux sum right" (~ inner)))) (` ("lux case" (~ value) - {("lux case bind" (~ (code;nat temp))) - ((~ (code;int (local-variable temp))))})) + {("lux case bind" (~ (code.nat temp))) + ((~ (code.int (local-variable temp))))})) _ value) - (list;n.range +0 tag)))) + (list.n/range +0 tag)))) ## Tuples get analysed into binary products for the sake of semantic ## simplicity, since products/pairs can encode tuples of any length @@ -53,13 +53,13 @@ (def: #export (product members) (-> (List Analysis) Analysis) (case members - #;Nil + #.Nil (` []) - (#;Cons singleton #;Nil) + (#.Cons singleton #.Nil) singleton - (#;Cons left right) + (#.Cons left right) (` [(~ left) (~ (product right))]))) ## Function application gets analysed into single-argument @@ -75,17 +75,17 @@ (def: #export (procedure name args) (-> Text (List Analysis) Analysis) - (` ((~ (code;text name)) (~@ args)))) + (` ((~ (code.text name)) (~@ args)))) (def: #export (var idx) (-> Variable Analysis) - (` ((~ (code;int idx))))) + (` ((~ (code.int idx))))) (def: #export (unfold-tuple analysis) (-> Analysis (List Analysis)) (case analysis (^code [(~ left) (~ right)]) - (#;Cons left (unfold-tuple right)) + (#.Cons left (unfold-tuple right)) _ (list analysis))) @@ -99,13 +99,13 @@ (case valueA (^or (^code ("lux sum left" (~ _))) (^code ("lux sum right" (~ _)))) - (recur (n.inc so-far) valueA) + (recur (n/inc so-far) valueA) _ - (#;Some [so-far false valueA])) + (#.Some [so-far false valueA])) (^code ("lux sum right" (~ valueA))) - (#;Some [(n.inc so-far) true valueA]) + (#.Some [(n/inc so-far) true valueA]) _ - #;None))) + #.None))) diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux index 949e18a26..16f775907 100644 --- a/new-luxc/source/luxc/lang/analysis/case.lux +++ b/new-luxc/source/luxc/lang/analysis/case.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:] @@ -16,11 +16,11 @@ (lang [type] (type ["tc" check]))) (luxc ["&" lang] - (lang ["&;" scope] + (lang ["&." scope] ["la" analysis] - (analysis [";A" common] - [";A" structure] - (case [";A" coverage]))))) + (analysis [".A" common] + [".A" structure] + (case [".A" coverage]))))) (exception: #export Cannot-Match-Type-With-Pattern) (exception: #export Sum-Type-Has-No-Case) @@ -38,11 +38,11 @@ (def: (re-quantify envs baseT) (-> (List (List Type)) Type Type) (case envs - #;Nil + #.Nil baseT - (#;Cons head tail) - (re-quantify tail (#;UnivQ head 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 @@ -57,70 +57,70 @@ (list)) caseT caseT] (case caseT - (#;Var id) - (do macro;Monad<Meta> - [?caseT' (&;with-type-env - (tc;read id))] + (#.Var id) + (do macro.Monad<Meta> + [?caseT' (&.with-type-env + (tc.read id))] (case ?caseT' - (#;Some caseT') + (#.Some caseT') (recur envs caseT') _ - (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) + (&.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) - (#;Named name unnamedT) + (#.Named name unnamedT) (recur envs unnamedT) - (#;UnivQ env unquantifiedT) - (recur (#;Cons env envs) unquantifiedT) + (#.UnivQ env unquantifiedT) + (recur (#.Cons env envs) unquantifiedT) ## (^template [<tag> <instancer>] ## (<tag> _) - ## (do macro;Monad<Meta> - ## [[_ instanceT] (&;with-type-env + ## (do macro.Monad<Meta> + ## [[_ instanceT] (&.with-type-env ## <instancer>)] - ## (recur (maybe;assume (type;apply (list instanceT) caseT))))) - ## ([#;UnivQ tc;var] - ## [#;ExQ tc;existential]) + ## (recur (maybe.assume (type.apply (list instanceT) caseT))))) + ## ([#.UnivQ tc.var] + ## [#.ExQ tc.existential]) - (#;ExQ _) - (do macro;Monad<Meta> - [[ex-id exT] (&;with-type-env - tc;existential)] - (recur envs (maybe;assume (type;apply (list exT) caseT)))) + (#.ExQ _) + (do macro.Monad<Meta> + [[ex-id exT] (&.with-type-env + tc.existential)] + (recur envs (maybe.assume (type.apply (list exT) caseT)))) - (#;Apply inputT funcT) + (#.Apply inputT funcT) (case funcT - (#;Var funcT-id) - (do macro;Monad<Meta> - [funcT' (&;with-type-env - (do tc;Monad<Check> - [?funct' (tc;read funcT-id)] + (#.Var funcT-id) + (do macro.Monad<Meta> + [funcT' (&.with-type-env + (do tc.Monad<Check> + [?funct' (tc.read funcT-id)] (case ?funct' - (#;Some funct') + (#.Some funct') (wrap funct') _ - (tc;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))] - (recur envs (#;Apply inputT funcT'))) + (tc.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))] + (recur envs (#.Apply inputT funcT'))) _ - (case (type;apply (list inputT) funcT) - (#;Some outputT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) (recur envs outputT) - #;None - (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) + #.None + (&.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) - (#;Product _) + (#.Product _) (|> caseT - type;flatten-tuple + type.flatten-tuple (list/map (re-quantify envs)) - type;tuple - (:: macro;Monad<Meta> wrap)) + type.tuple + (:: macro.Monad<Meta> wrap)) _ - (:: macro;Monad<Meta> wrap (re-quantify envs caseT))))) + (:: macro.Monad<Meta> wrap (re-quantify envs caseT))))) ## This function handles several concerns at once, but it must be that ## way because those concerns are interleaved when doing @@ -139,169 +139,169 @@ ## 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 (Meta a) (Meta [la;Pattern a]))) + (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a]))) (case pattern - [cursor (#;Symbol ["" name])] - (&;with-cursor cursor - (do macro;Monad<Meta> - [outputA (&scope;with-local [name inputT] + [cursor (#.Symbol ["" name])] + (&.with-cursor cursor + (do macro.Monad<Meta> + [outputA (&scope.with-local [name inputT] next) - idx &scope;next-local] - (wrap [(` ("lux case bind" (~ (code;nat idx)))) outputA]))) + idx &scope.next-local] + (wrap [(` ("lux case bind" (~ (code.nat idx)))) outputA]))) - [cursor (#;Symbol ident)] - (&;with-cursor cursor - (&;throw Symbols-Must-Be-Unqualified-Inside-Patterns (%ident ident))) + [cursor (#.Symbol ident)] + (&.with-cursor cursor + (&.throw Symbols-Must-Be-Unqualified-Inside-Patterns (%ident ident))) (^template [<type> <code-tag>] [cursor (<code-tag> test)] - (&;with-cursor cursor - (do macro;Monad<Meta> - [_ (&;with-type-env - (tc;check inputT <type>)) + (&.with-cursor cursor + (do macro.Monad<Meta> + [_ (&.with-type-env + (tc.check inputT <type>)) outputA next] (wrap [pattern outputA])))) - ([Bool #;Bool] - [Nat #;Nat] - [Int #;Int] - [Deg #;Deg] - [Frac #;Frac] - [Text #;Text]) - - (^ [cursor (#;Tuple (list))]) - (&;with-cursor cursor - (do macro;Monad<Meta> - [_ (&;with-type-env - (tc;check inputT Unit)) + ([Bool #.Bool] + [Nat #.Nat] + [Int #.Int] + [Deg #.Deg] + [Frac #.Frac] + [Text #.Text]) + + (^ [cursor (#.Tuple (list))]) + (&.with-cursor cursor + (do macro.Monad<Meta> + [_ (&.with-type-env + (tc.check inputT Unit)) outputA next] (wrap [(` ("lux case tuple" [])) outputA]))) - (^ [cursor (#;Tuple (list singleton))]) - (analyse-pattern #;None inputT singleton next) + (^ [cursor (#.Tuple (list singleton))]) + (analyse-pattern #.None inputT singleton next) - [cursor (#;Tuple sub-patterns)] - (&;with-cursor cursor - (do macro;Monad<Meta> + [cursor (#.Tuple sub-patterns)] + (&.with-cursor cursor + (do macro.Monad<Meta> [inputT' (simplify-case-type inputT)] (case inputT' - (#;Product _) - (let [sub-types (type;flatten-tuple inputT') - num-sub-types (maybe;default (list;size sub-types) + (#.Product _) + (let [sub-types (type.flatten-tuple inputT') + num-sub-types (maybe.default (list.size sub-types) num-tags) - num-sub-patterns (list;size sub-patterns) - matches (cond (n.< num-sub-types num-sub-patterns) - (let [[prefix suffix] (list;split (n.dec num-sub-patterns) sub-types)] - (list;zip2 (list/compose prefix (list (type;tuple suffix))) sub-patterns)) - - (n.> num-sub-types num-sub-patterns) - (let [[prefix suffix] (list;split (n.dec num-sub-types) sub-patterns)] - (list;zip2 sub-types (list/compose prefix (list (code;tuple suffix))))) + num-sub-patterns (list.size sub-patterns) + matches (cond (n/< num-sub-types num-sub-patterns) + (let [[prefix suffix] (list.split (n/dec num-sub-patterns) sub-types)] + (list.zip2 (list/compose prefix (list (type.tuple suffix))) sub-patterns)) + + (n/> num-sub-types num-sub-patterns) + (let [[prefix suffix] (list.split (n/dec num-sub-types) sub-patterns)] + (list.zip2 sub-types (list/compose prefix (list (code.tuple suffix))))) - ## (n.= num-sub-types num-sub-patterns) - (list;zip2 sub-types sub-patterns) + ## (n/= num-sub-types num-sub-patterns) + (list.zip2 sub-types sub-patterns) )] (do @ [[memberP+ thenA] (list/fold (: (All [a] - (-> [Type Code] (Meta [(List la;Pattern) a]) - (Meta [(List la;Pattern) a]))) + (-> [Type Code] (Meta [(List la.Pattern) a]) + (Meta [(List la.Pattern) a]))) (function [[memberT memberC] then] (do @ - [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la;Pattern a]))) + [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a]))) analyse-pattern) - #;None memberT memberC then)] + #.None memberT memberC then)] (wrap [(list& memberP memberP+) thenA])))) (do @ [nextA next] (wrap [(list) nextA])) - (list;reverse matches))] + (list.reverse matches))] (wrap [(` ("lux case tuple" [(~@ memberP+)])) thenA]))) _ - (&;throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern)) + (&.throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern)) ))) - [cursor (#;Record record)] - (do macro;Monad<Meta> - [record (structureA;normalize record) - [members recordT] (structureA;order record) - _ (&;with-type-env - (tc;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 macro;Monad<Meta> + [cursor (#.Record record)] + (do macro.Monad<Meta> + [record (structureA.normalize record) + [members recordT] (structureA.order record) + _ (&.with-type-env + (tc.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 macro.Monad<Meta> [inputT' (simplify-case-type 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 case-type) - (n.< num-cases idx)) - (if (and (n.> num-cases size-sum) - (n.= (n.dec num-cases) idx)) - (do macro;Monad<Meta> - [[testP nextA] (analyse-pattern #;None - (type;variant (list;drop (n.dec num-cases) flat-sum)) + (#.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 case-type) + (n/< num-cases idx)) + (if (and (n/> num-cases size-sum) + (n/= (n/dec num-cases) idx)) + (do macro.Monad<Meta> + [[testP nextA] (analyse-pattern #.None + (type.variant (list.drop (n/dec num-cases) flat-sum)) (` [(~@ values)]) next)] - (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP))) + (wrap [(` ("lux case variant" (~ (code.nat idx)) (~ (code.nat num-cases)) (~ testP))) nextA])) - (do macro;Monad<Meta> - [[testP nextA] (analyse-pattern #;None case-type (` [(~@ values)]) next)] - (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP))) + (do macro.Monad<Meta> + [[testP nextA] (analyse-pattern #.None case-type (` [(~@ values)]) next)] + (wrap [(` ("lux case variant" (~ (code.nat idx)) (~ (code.nat num-cases)) (~ testP))) nextA]))) _ - (&;throw Sum-Type-Has-No-Case + (&.throw Sum-Type-Has-No-Case (format "Case: " (%n idx) "\n" "Type: " (%type inputT))))) _ - (&;throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern))))) + (&.throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern))))) - (^ [cursor (#;Form (list& [_ (#;Tag tag)] values))]) - (&;with-cursor cursor - (do macro;Monad<Meta> - [tag (macro;normalize tag) - [idx group variantT] (macro;resolve-tag tag) - _ (&;with-type-env - (tc;check inputT variantT))] - (analyse-pattern (#;Some (list;size group)) inputT (` ((~ (code;nat idx)) (~@ values))) next))) + (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) + (&.with-cursor cursor + (do macro.Monad<Meta> + [tag (macro.normalize tag) + [idx group variantT] (macro.resolve-tag tag) + _ (&.with-type-env + (tc.check inputT variantT))] + (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~@ values))) next))) _ - (&;throw Unrecognized-Pattern-Syntax (%code pattern)) + (&.throw Unrecognized-Pattern-Syntax (%code pattern)) )) (def: #export (analyse-case analyse inputC branches) - (-> &;Analyser Code (List [Code Code]) (Meta la;Analysis)) + (-> &.Analyser Code (List [Code Code]) (Meta la.Analysis)) (case branches - #;Nil - (&;throw Cannot-Have-Empty-Branches "") + #.Nil + (&.throw Cannot-Have-Empty-Branches "") - (#;Cons [patternH bodyH] branchesT) - (do macro;Monad<Meta> - [[inputT inputA] (commonA;with-unknown-type + (#.Cons [patternH bodyH] branchesT) + (do macro.Monad<Meta> + [[inputT inputA] (commonA.with-unknown-type (analyse inputC)) - outputH (analyse-pattern #;None inputT patternH (analyse bodyH)) - outputT (monad;map @ + outputH (analyse-pattern #.None inputT patternH (analyse bodyH)) + outputT (monad.map @ (function [[patternT bodyT]] - (analyse-pattern #;None inputT patternT (analyse bodyT))) + (analyse-pattern #.None inputT patternT (analyse bodyT))) branchesT) - outputHC (|> outputH product;left coverageA;determine) - outputTC (monad;map @ (|>. product;left coverageA;determine) outputT) - _ (case (monad;fold e;Monad<Error> coverageA;merge outputHC outputTC) - (#e;Success coverage) - (&;assert Non-Exhaustive-Pattern-Matching "" - (coverageA;exhaustive? coverage)) - - (#e;Error error) - (&;fail error))] - (wrap (` ("lux case" (~ inputA) (~ (code;record (list& outputH outputT))))))))) + outputHC (|> outputH product.left coverageA.determine) + outputTC (monad.map @ (|>> product.left coverageA.determine) outputT) + _ (case (monad.fold e.Monad<Error> coverageA.merge outputHC outputTC) + (#e.Success coverage) + (&.assert Non-Exhaustive-Pattern-Matching "" + (coverageA.exhaustive? coverage)) + + (#e.Error error) + (&.fail error))] + (wrap (` ("lux case" (~ inputA) (~ (code.record (list& outputH outputT))))))))) diff --git a/new-luxc/source/luxc/lang/analysis/case/coverage.lux b/new-luxc/source/luxc/lang/analysis/case/coverage.lux index 283e21d02..5d34387b4 100644 --- a/new-luxc/source/luxc/lang/analysis/case/coverage.lux +++ b/new-luxc/source/luxc/lang/analysis/case/coverage.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:] @@ -45,7 +45,7 @@ (exception: #export Unknown-Pattern) (def: #export (determine pattern) - (-> la;Pattern (Meta Coverage)) + (-> la.Pattern (Meta Coverage)) (case pattern ## Binding amounts to exhaustive coverage because any value can be ## matched that way. @@ -59,14 +59,14 @@ ## Primitive patterns always have partial coverage because there ## are too many possibilities as far as values go. - (^or [_ (#;Nat _)] [_ (#;Int _)] [_ (#;Deg _)] - [_ (#;Frac _)] [_ (#;Text _)]) + (^or [_ (#.Nat _)] [_ (#.Int _)] [_ (#.Deg _)] + [_ (#.Frac _)] [_ (#.Text _)]) (macro/wrap #Partial) ## Bools are the exception, since there is only "true" and ## "false", which means it is possible for boolean ## pattern-matching to become exhaustive if complementary parts meet. - [_ (#;Bool value)] + [_ (#.Bool value)] (macro/wrap (#Bool value)) ## Tuple patterns can be exhaustive if there is exhaustiveness for all of @@ -74,11 +74,11 @@ (^code ("lux case tuple" [(~@ subs)])) (loop [subs subs] (case subs - #;Nil + #.Nil (macro/wrap #Exhaustive) - (#;Cons sub subs') - (do macro;Monad<Meta> + (#.Cons sub subs') + (do macro.Monad<Meta> [pre (determine sub) post (recur subs')] (if (exhaustive? post) @@ -87,15 +87,15 @@ ## Variant patterns can be shown to be exhaustive if all the possible ## cases are handled exhaustively. - (^code ("lux case variant" (~ [_ (#;Nat tag-id)]) (~ [_ (#;Nat num-tags)]) (~ sub))) - (do macro;Monad<Meta> + (^code ("lux case variant" (~ [_ (#.Nat tag-id)]) (~ [_ (#.Nat num-tags)]) (~ sub))) + (do macro.Monad<Meta> [=sub (determine sub)] (wrap (#Variant num-tags - (|> (dict;new number;Hash<Nat>) - (dict;put tag-id =sub))))) + (|> (dict.new number.Hash<Nat>) + (dict.put tag-id =sub))))) _ - (&;throw Unknown-Pattern (%code pattern)))) + (&.throw Unknown-Pattern (%code pattern)))) (def: (xor left right) (-> Bool Bool Bool) @@ -109,8 +109,8 @@ ## 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.")) + (e.Error Coverage) + (e.fail "Redundant pattern.")) (def: (flatten-alt coverage) (-> Coverage (List Coverage)) @@ -131,8 +131,8 @@ (bool/= sideR sideS) [(#Variant allR casesR) (#Variant allS casesS)] - (and (n.= allR allS) - (:: (dict;Eq<Dict> =) = casesR casesS)) + (and (n/= allR allS) + (:: (dict.Eq<Dict> =) = casesR casesS)) [(#Seq leftR rightR) (#Seq leftS rightS)] (and (= leftR leftS) @@ -141,10 +141,10 @@ [(#Alt _) (#Alt _)] (let [flatR (flatten-alt reference) flatS (flatten-alt sample)] - (and (n.= (list;size flatR) (list;size flatS)) - (list;every? (function [[coverageR coverageS]] + (and (n/= (list.size flatR) (list.size flatS)) + (list.every? (function [[coverageR coverageS]] (= coverageR coverageS)) - (list;zip2 flatR flatS)))) + (list.zip2 flatR flatS)))) _ false))) @@ -156,7 +156,7 @@ ## pattern-matching expression is exhaustive and whether it contains ## redundant patterns. (def: #export (merge addition so-far) - (-> Coverage Coverage (e;Error Coverage)) + (-> Coverage Coverage (e.Error Coverage)) (case [addition so-far] ## The addition cannot possibly improve the coverage. [_ #Exhaustive] @@ -175,28 +175,28 @@ (error/wrap #Exhaustive) [(#Variant allA casesA) (#Variant allSF casesSF)] - (cond (not (n.= allSF allA)) - (e;fail "Variants do not match.") + (cond (not (n/= allSF allA)) + (e.fail "Variants do not match.") - (:: (dict;Eq<Dict> Eq<Coverage>) = casesSF casesA) + (:: (dict.Eq<Dict> Eq<Coverage>) = casesSF casesA) redundant-pattern ## else - (do e;Monad<Error> - [casesM (monad;fold @ + (do e.Monad<Error> + [casesM (monad.fold @ (function [[tagA coverageA] casesSF'] - (case (dict;get tagA casesSF') - (#;Some coverageSF) + (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.= allSF (list;size case-coverages)) - (list;every? exhaustive? case-coverages))) + (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/= allSF (list.size case-coverages)) + (list.every? exhaustive? case-coverages))) #Exhaustive (#Variant allSF casesM))))) @@ -212,7 +212,7 @@ ## Same prefix [true false] - (do e;Monad<Error> + (do e.Monad<Error> [rightM (merge rightA rightSF)] (if (exhaustive? rightM) ## If all that follows is exhaustive, then it can be safely dropped @@ -223,7 +223,7 @@ ## Same suffix [false true] - (do e;Monad<Error> + (do e.Monad<Error> [leftM (merge leftA leftSF)] (wrap (#Seq leftM rightA)))) @@ -247,48 +247,48 @@ ## This process must be repeated until no further productive ## merges can be done. [_ (#Alt leftS rightS)] - (do e;Monad<Error> + (do e.Monad<Error> [#let [fuse-once (: (-> Coverage (List Coverage) - (e;Error [(Maybe Coverage) + (e.Error [(Maybe Coverage) (List Coverage)])) (function [coverage possibilities] (loop [alts possibilities] (case alts - #;Nil - (wrap [#;None (list coverage)]) + #.Nil + (wrap [#.None (list coverage)]) - (#;Cons alt alts') + (#.Cons alt alts') (case (merge coverage alt) - (#e;Success altM) + (#e.Success altM) (case altM (#Alt _) (do @ [[success alts+] (recur alts')] - (wrap [success (#;Cons alt alts+)])) + (wrap [success (#.Cons alt alts+)])) _ - (wrap [(#;Some altM) alts'])) + (wrap [(#.Some altM) alts'])) - (#e;Error error) - (e;fail error)) + (#e.Error error) + (e.fail error)) ))))] [success possibilities] (fuse-once addition (flatten-alt so-far))] (loop [success success possibilities possibilities] (case success - (#;Some coverage') + (#.Some coverage') (do @ [[success' possibilities'] (fuse-once coverage' possibilities)] (recur success' possibilities')) - #;None - (case (list;reverse possibilities) - (#;Cons last prevs) + #.None + (case (list.reverse possibilities) + (#.Cons last prevs) (wrap (list/fold (function [left right] (#Alt left right)) last prevs)) - #;Nil + #.Nil (undefined))))) _ diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux index c1a2a4f5b..aeed656a8 100644 --- a/new-luxc/source/luxc/lang/analysis/common.lux +++ b/new-luxc/source/luxc/lang/analysis/common.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad ["ex" exception #+ exception:]) @@ -12,18 +12,18 @@ (def: #export (with-unknown-type action) (All [a] (-> (Meta a) (Meta [Type a]))) - (do macro;Monad<Meta> - [[_ varT] (&;with-type-env tc;var) - analysis (&;with-type varT + (do macro.Monad<Meta> + [[_ varT] (&.with-type-env tc.var) + analysis (&.with-type varT action) - knownT (&;with-type-env (tc;clean varT))] + knownT (&.with-type-env (tc.clean varT))] (wrap [knownT analysis]))) (exception: #export Variant-Tag-Out-Of-Bounds) (def: #export (variant-out-of-bounds-error type size tag) (All [a] (-> Type Nat Nat (Meta a))) - (&;throw Variant-Tag-Out-Of-Bounds + (&.throw Variant-Tag-Out-Of-Bounds (format " Tag: " (%n tag) "\n" "Variant Size: " (%n size) "\n" "Variant Type: " (%type type)))) diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux index b16499c01..0f3cdcf6e 100644 --- a/new-luxc/source/luxc/lang/analysis/expression.lux +++ b/new-luxc/source/luxc/lang/analysis/expression.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -10,94 +10,94 @@ (type ["tc" check])) [host]) (luxc ["&" lang] - (lang ["&;" module] - [";L" host] - [";L" macro] + (lang ["&." module] + [".L" host] + [".L" macro] ["la" analysis] - (translation [";T" common]))) - (// [";A" common] - [";A" function] - [";A" primitive] - [";A" reference] - [";A" structure] - [";A" procedure])) + (translation [".T" common]))) + (// [".A" common] + [".A" function] + [".A" primitive] + [".A" reference] + [".A" structure] + [".A" procedure])) (exception: #export Macro-Expression-Must-Have-Single-Expansion) (exception: #export Unrecognized-Syntax) (exception: #export Macro-Expansion-Failed) (def: #export (analyser eval) - (-> &;Eval &;Analyser) - (: (-> Code (Meta la;Analysis)) + (-> &.Eval &.Analyser) + (: (-> Code (Meta la.Analysis)) (function analyse [code] - (do macro;Monad<Meta> - [expectedT macro;expected-type] + (do macro.Monad<Meta> + [expectedT macro.expected-type] (let [[cursor code'] code] ## The cursor must be set in the compiler for the sake ## of having useful error messages. - (&;with-cursor cursor + (&.with-cursor cursor (case code' (^template [<tag> <analyser>] (<tag> value) (<analyser> value)) - ([#;Bool primitiveA;analyse-bool] - [#;Nat primitiveA;analyse-nat] - [#;Int primitiveA;analyse-int] - [#;Deg primitiveA;analyse-deg] - [#;Frac primitiveA;analyse-frac] - [#;Text primitiveA;analyse-text]) + ([#.Bool primitiveA.analyse-bool] + [#.Nat primitiveA.analyse-nat] + [#.Int primitiveA.analyse-int] + [#.Deg primitiveA.analyse-deg] + [#.Frac primitiveA.analyse-frac] + [#.Text primitiveA.analyse-text]) - (^ (#;Tuple (list))) - primitiveA;analyse-unit + (^ (#.Tuple (list))) + primitiveA.analyse-unit ## Singleton tuples are equivalent to the element they contain. - (^ (#;Tuple (list singleton))) + (^ (#.Tuple (list singleton))) (analyse singleton) - (^ (#;Tuple elems)) - (structureA;analyse-product analyse elems) + (^ (#.Tuple elems)) + (structureA.analyse-product analyse elems) - (^ (#;Record pairs)) - (structureA;analyse-record analyse pairs) + (^ (#.Record pairs)) + (structureA.analyse-record analyse pairs) - (#;Symbol reference) - (referenceA;analyse-reference reference) + (#.Symbol reference) + (referenceA.analyse-reference reference) - (^ (#;Form (list& [_ (#;Text proc-name)] proc-args))) - (procedureA;analyse-procedure analyse eval proc-name proc-args) + (^ (#.Form (list& [_ (#.Text proc-name)] proc-args))) + (procedureA.analyse-procedure analyse eval proc-name proc-args) (^template [<tag> <analyser>] - (^ (#;Form (list& [_ (<tag> tag)] + (^ (#.Form (list& [_ (<tag> tag)] values))) (case values - (#;Cons value #;Nil) + (#.Cons value #.Nil) (<analyser> analyse tag value) _ (<analyser> analyse tag (` [(~@ values)])))) - ([#;Nat structureA;analyse-sum] - [#;Tag structureA;analyse-tagged-sum]) + ([#.Nat structureA.analyse-sum] + [#.Tag structureA.analyse-tagged-sum]) - (#;Tag tag) - (structureA;analyse-tagged-sum analyse tag (' [])) + (#.Tag tag) + (structureA.analyse-tagged-sum analyse tag (' [])) - (^ (#;Form (list& func args))) - (do macro;Monad<Meta> - [[funcT funcA] (commonA;with-unknown-type + (^ (#.Form (list& func args))) + (do macro.Monad<Meta> + [[funcT funcA] (commonA.with-unknown-type (analyse func))] (case funcA - [_ (#;Symbol def-name)] + [_ (#.Symbol def-name)] (do @ - [?macro (&;with-error-tracking - (macro;find-macro def-name))] + [?macro (&.with-error-tracking + (macro.find-macro def-name))] (case ?macro - (#;Some macro) + (#.Some macro) (do @ [expansion (: (Meta (List Code)) (function [compiler] - (case (macroL;expand macro args compiler) - (#e;Error error) - ((&;throw Macro-Expansion-Failed error) compiler) + (case (macroL.expand macro args compiler) + (#e.Error error) + ((&.throw Macro-Expansion-Failed error) compiler) output output)))] @@ -106,14 +106,14 @@ (analyse single) _ - (&;throw Macro-Expression-Must-Have-Single-Expansion (%code code)))) + (&.throw Macro-Expression-Must-Have-Single-Expansion (%code code)))) _ - (functionA;analyse-apply analyse funcT funcA args))) + (functionA.analyse-apply analyse funcT funcA args))) _ - (functionA;analyse-apply analyse funcT funcA args))) + (functionA.analyse-apply analyse funcT funcA args))) _ - (&;throw Unrecognized-Syntax (%code code)) + (&.throw Unrecognized-Syntax (%code code)) ))))))) diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux index b4aa31c90..758acd681 100644 --- a/new-luxc/source/luxc/lang/analysis/function.lux +++ b/new-luxc/source/luxc/lang/analysis/function.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad ["ex" exception #+ exception:]) @@ -11,11 +11,11 @@ (lang [type] (type ["tc" check]))) (luxc ["&" lang] - (lang ["&;" scope] + (lang ["&." scope] ["la" analysis #+ Analysis] - (analysis ["&;" common] - ["&;" inference]) - [";L" variable #+ Variable]))) + (analysis ["&." common] + ["&." inference]) + [".L" variable #+ Variable]))) (exception: #export Cannot-Analyse-Function) (exception: #export Invalid-Function-Type) @@ -23,81 +23,81 @@ ## [Analysers] (def: #export (analyse-function analyse func-name arg-name body) - (-> &;Analyser Text Text Code (Meta Analysis)) - (do macro;Monad<Meta> - [functionT macro;expected-type] + (-> &.Analyser Text Text Code (Meta Analysis)) + (do macro.Monad<Meta> + [functionT macro.expected-type] (loop [expectedT functionT] - (&;with-stacked-errors + (&.with-stacked-errors (function [_] (Cannot-Analyse-Function (format " Type: " (%type expectedT) "\n" "Function: " func-name "\n" "Argument: " arg-name "\n" " Body: " (%code body)))) (case expectedT - (#;Named name unnamedT) + (#.Named name unnamedT) (recur unnamedT) - (#;Apply argT funT) - (case (type;apply (list argT) funT) - (#;Some value) + (#.Apply argT funT) + (case (type.apply (list argT) funT) + (#.Some value) (recur value) - #;None - (&;throw Invalid-Function-Type (%type expectedT))) + #.None + (&.throw Invalid-Function-Type (%type expectedT))) (^template [<tag> <instancer>] (<tag> _) (do @ - [[_ instanceT] (&;with-type-env <instancer>)] - (recur (maybe;assume (type;apply (list instanceT) expectedT))))) - ([#;UnivQ tc;existential] - [#;ExQ tc;var]) + [[_ instanceT] (&.with-type-env <instancer>)] + (recur (maybe.assume (type.apply (list instanceT) expectedT))))) + ([#.UnivQ tc.existential] + [#.ExQ tc.var]) - (#;Var id) + (#.Var id) (do @ - [?expectedT' (&;with-type-env - (tc;read id))] + [?expectedT' (&.with-type-env + (tc.read id))] (case ?expectedT' - (#;Some expectedT') + (#.Some expectedT') (recur expectedT') _ ## Inference (do @ - [[input-id inputT] (&;with-type-env tc;var) - [output-id outputT] (&;with-type-env tc;var) - #let [funT (#;Function inputT outputT)] + [[input-id inputT] (&.with-type-env tc.var) + [output-id outputT] (&.with-type-env tc.var) + #let [funT (#.Function inputT outputT)] funA (recur funT) - _ (&;with-type-env - (tc;check expectedT funT))] + _ (&.with-type-env + (tc.check expectedT funT))] (wrap funA)) )) - (#;Function inputT outputT) + (#.Function inputT outputT) (<| (:: @ map (function [[scope bodyA]] - (` ("lux function" [(~@ (list/map code;int (variableL;environment scope)))] + (` ("lux function" [(~@ (list/map code.int (variableL.environment scope)))] (~ bodyA))))) - &;with-scope + &.with-scope ## Functions have access not only to their argument, but ## also to themselves, through a local variable. - (&scope;with-local [func-name expectedT]) - (&scope;with-local [arg-name inputT]) - (&;with-type outputT) + (&scope.with-local [func-name expectedT]) + (&scope.with-local [arg-name inputT]) + (&.with-type outputT) (analyse body)) _ - (&;fail "") + (&.fail "") ))))) (def: #export (analyse-apply analyse funcT funcA args) - (-> &;Analyser Type Analysis (List Code) (Meta Analysis)) - (&;with-stacked-errors + (-> &.Analyser Type Analysis (List Code) (Meta Analysis)) + (&.with-stacked-errors (function [_] (Cannot-Apply-Function (format " Function: " (%type funcT) "\n" "Arguments:" (|> args - list;enumerate + list.enumerate (list/map (function [[idx argC]] (format "\n " (%n idx) " " (%code argC)))) - (text;join-with ""))))) - (do macro;Monad<Meta> - [[applyT argsA] (&inference;general analyse funcT args)] - (wrap (la;apply argsA funcA))))) + (text.join-with ""))))) + (do macro.Monad<Meta> + [[applyT argsA] (&inference.general analyse funcT args)] + (wrap (la.apply argsA funcA))))) diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux index e89ab2e1e..881eee4a6 100644 --- a/new-luxc/source/luxc/lang/analysis/inference.lux +++ b/new-luxc/source/luxc/lang/analysis/inference.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -11,7 +11,7 @@ (type ["tc" check]))) (luxc ["&" lang] (lang ["la" analysis #+ Analysis] - (analysis ["&;" common])))) + (analysis ["&." common])))) (exception: #export Cannot-Infer) (def: (cannot-infer type args) @@ -19,10 +19,10 @@ (format " Type: " (%type type) "\n" "Arguments:" (|> args - list;enumerate + list.enumerate (list/map (function [[idx argC]] (format "\n " (%n idx) " " (%code argC)))) - (text;join-with "")))) + (text.join-with "")))) (exception: #export Cannot-Infer-Argument) (exception: #export Smaller-Variant-Than-Expected) @@ -33,29 +33,29 @@ (def: (replace-bound bound-idx replacementT type) (-> Nat Type Type Type) (case type - (#;Primitive name params) - (#;Primitive name (list/map (replace-bound bound-idx replacementT) params)) + (#.Primitive name params) + (#.Primitive name (list/map (replace-bound bound-idx replacementT) params)) (^template [<tag>] (<tag> left right) (<tag> (replace-bound bound-idx replacementT left) (replace-bound bound-idx replacementT right))) - ([#;Sum] - [#;Product] - [#;Function] - [#;Apply]) + ([#.Sum] + [#.Product] + [#.Function] + [#.Apply]) - (#;Bound idx) - (if (n.= bound-idx idx) + (#.Bound idx) + (if (n/= bound-idx idx) replacementT type) (^template [<tag>] (<tag> env quantified) (<tag> (list/map (replace-bound bound-idx replacementT) env) - (replace-bound (n.+ +2 bound-idx) replacementT quantified))) - ([#;UnivQ] - [#;ExQ]) + (replace-bound (n/+ +2 bound-idx) replacementT quantified))) + ([#.UnivQ] + [#.ExQ]) _ type)) @@ -68,36 +68,36 @@ ## 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) - (-> &;Analyser Type (List Code) (Meta [Type (List Analysis)])) + (-> &.Analyser Type (List Code) (Meta [Type (List Analysis)])) (case args - #;Nil - (do macro;Monad<Meta> - [_ (&;infer inferT)] + #.Nil + (do macro.Monad<Meta> + [_ (&.infer inferT)] (wrap [inferT (list)])) - (#;Cons argC args') + (#.Cons argC args') (case inferT - (#;Named name unnamedT) + (#.Named name unnamedT) (general analyse unnamedT args) - (#;UnivQ _) - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] - (general analyse (maybe;assume (type;apply (list varT) inferT)) args)) + (#.UnivQ _) + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] + (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) - (#;ExQ _) - (do macro;Monad<Meta> - [[ex-id exT] (&;with-type-env - tc;existential)] - (general analyse (maybe;assume (type;apply (list exT) inferT)) args)) + (#.ExQ _) + (do macro.Monad<Meta> + [[ex-id exT] (&.with-type-env + tc.existential)] + (general analyse (maybe.assume (type.apply (list exT) inferT)) args)) - (#;Apply inputT transT) - (case (type;apply (list inputT) transT) - (#;Some outputT) + (#.Apply inputT transT) + (case (type.apply (list inputT) transT) + (#.Some outputT) (general analyse outputT args) - #;None - (&;throw Invalid-Type-Application (%type inferT))) + #.None + (&.throw Invalid-Type-Application (%type inferT))) ## Arguments are inferred back-to-front because, by convention, ## Lux functions take the most important arguments *last*, which @@ -106,59 +106,59 @@ ## 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 macro;Monad<Meta> + (#.Function inputT outputT) + (do macro.Monad<Meta> [[outputT' args'A] (general analyse outputT args') - argA (&;with-stacked-errors + argA (&.with-stacked-errors (function [_] (Cannot-Infer-Argument (format "Inferred Type: " (%type inputT) "\n" " Argument: " (%code argC)))) - (&;with-type inputT + (&.with-type inputT (analyse argC)))] (wrap [outputT' (list& argA args'A)])) - (#;Var infer-id) - (do macro;Monad<Meta> - [?inferT' (&;with-type-env (tc;read infer-id))] + (#.Var infer-id) + (do macro.Monad<Meta> + [?inferT' (&.with-type-env (tc.read infer-id))] (case ?inferT' - (#;Some inferT') + (#.Some inferT') (general analyse inferT' args) _ - (&;throw Cannot-Infer (cannot-infer inferT args)))) + (&.throw Cannot-Infer (cannot-infer inferT args)))) _ - (&;throw Cannot-Infer (cannot-infer inferT args))) + (&.throw Cannot-Infer (cannot-infer inferT args))) )) ## Turns a record type into the kind of function type suitable for inference. (def: #export (record inferT) (-> Type (Meta Type)) (case inferT - (#;Named name unnamedT) + (#.Named name unnamedT) (record unnamedT) (^template [<tag>] (<tag> env bodyT) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [bodyT+ (record bodyT)] (wrap (<tag> env bodyT+)))) - ([#;UnivQ] - [#;ExQ]) + ([#.UnivQ] + [#.ExQ]) - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) (record outputT) - #;None - (&;throw Invalid-Type-Application (%type inferT))) + #.None + (&.throw Invalid-Type-Application (%type inferT))) - (#;Product _) - (macro/wrap (type;function (type;flatten-tuple inferT) inferT)) + (#.Product _) + (macro/wrap (type.function (type.flatten-tuple inferT) inferT)) _ - (&;throw Not-A-Record-Type (%type inferT)))) + (&.throw Not-A-Record-Type (%type inferT)))) ## Turns a variant type into the kind of function type suitable for inference. (def: #export (variant tag expected-size inferT) @@ -166,60 +166,60 @@ (loop [depth +0 currentT inferT] (case currentT - (#;Named name unnamedT) - (do macro;Monad<Meta> + (#.Named name unnamedT) + (do macro.Monad<Meta> [unnamedT+ (recur depth unnamedT)] (wrap unnamedT+)) (^template [<tag>] (<tag> env bodyT) - (do macro;Monad<Meta> - [bodyT+ (recur (n.inc depth) bodyT)] + (do macro.Monad<Meta> + [bodyT+ (recur (n/inc depth) bodyT)] (wrap (<tag> env bodyT+)))) - ([#;UnivQ] - [#;ExQ]) - - (#;Sum _) - (let [cases (type;flatten-variant currentT) - actual-size (list;size cases) - boundary (n.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) - (macro/wrap (if (n.= +0 depth) - (type;function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n.dec (n.* +2)) inferT)] - (type;function (list (replace! caseT)) + ([#.UnivQ] + [#.ExQ]) + + (#.Sum _) + (let [cases (type.flatten-variant currentT) + actual-size (list.size cases) + boundary (n/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) + (macro/wrap (if (n/= +0 depth) + (type.function (list caseT) currentT) + (let [replace! (replace-bound (|> depth n/dec (n/* +2)) inferT)] + (type.function (list (replace! caseT)) (replace! currentT))))) - #;None - (&common;variant-out-of-bounds-error inferT expected-size tag)) + #.None + (&common.variant-out-of-bounds-error inferT expected-size tag)) - (n.< expected-size actual-size) - (&;throw Smaller-Variant-Than-Expected + (n/< expected-size actual-size) + (&.throw Smaller-Variant-Than-Expected (format "Expected: " (%i (nat-to-int expected-size)) "\n" " Actual: " (%i (nat-to-int actual-size)))) - (n.= boundary tag) - (let [caseT (type;variant (list;drop boundary cases))] - (macro/wrap (if (n.= +0 depth) - (type;function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n.dec (n.* +2)) inferT)] - (type;function (list (replace! caseT)) + (n/= boundary tag) + (let [caseT (type.variant (list.drop boundary cases))] + (macro/wrap (if (n/= +0 depth) + (type.function (list caseT) currentT) + (let [replace! (replace-bound (|> depth n/dec (n/* +2)) inferT)] + (type.function (list (replace! caseT)) (replace! currentT)))))) ## else - (&common;variant-out-of-bounds-error inferT expected-size tag))) + (&common.variant-out-of-bounds-error inferT expected-size tag))) - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) (variant tag expected-size outputT) - #;None - (&;throw Invalid-Type-Application (%type inferT))) + #.None + (&.throw Invalid-Type-Application (%type inferT))) _ - (&;throw Not-A-Variant-Type (%type inferT))))) + (&.throw Not-A-Variant-Type (%type inferT))))) diff --git a/new-luxc/source/luxc/lang/analysis/primitive.lux b/new-luxc/source/luxc/lang/analysis/primitive.lux index 9124ca271..8270e7e73 100644 --- a/new-luxc/source/luxc/lang/analysis/primitive.lux +++ b/new-luxc/source/luxc/lang/analysis/primitive.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad) [macro] @@ -11,20 +11,20 @@ (do-template [<name> <type> <tag>] [(def: #export (<name> value) (-> <type> (Meta Analysis)) - (do macro;Monad<Meta> - [_ (&;infer <type>)] + (do macro.Monad<Meta> + [_ (&.infer <type>)] (wrap (<tag> value))))] - [analyse-bool Bool code;bool] - [analyse-nat Nat code;nat] - [analyse-int Int code;int] - [analyse-deg Deg code;deg] - [analyse-frac Frac code;frac] - [analyse-text Text code;text] + [analyse-bool Bool code.bool] + [analyse-nat Nat code.nat] + [analyse-int Int code.int] + [analyse-deg Deg code.deg] + [analyse-frac Frac code.frac] + [analyse-text Text code.text] ) (def: #export analyse-unit (Meta Analysis) - (do macro;Monad<Meta> - [_ (&;infer Unit)] + (do macro.Monad<Meta> + [_ (&.infer Unit)] (wrap (` [])))) diff --git a/new-luxc/source/luxc/lang/analysis/procedure.lux b/new-luxc/source/luxc/lang/analysis/procedure.lux index 4e9843ddd..25e1be335 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -8,19 +8,19 @@ (coll [dict]))) (luxc ["&" lang] (lang ["la" analysis])) - (/ ["/;" common] - ["/;" host])) + (/ ["/." common] + ["/." host])) (exception: #export Unknown-Procedure) (def: procedures - /common;Bundle - (|> /common;procedures - (dict;merge /host;procedures))) + /common.Bundle + (|> /common.procedures + (dict.merge /host.procedures))) (def: #export (analyse-procedure analyse eval proc-name proc-args) - (-> &;Analyser &;Eval Text (List Code) (Meta la;Analysis)) - (<| (maybe;default (&;throw Unknown-Procedure (%t proc-name))) - (do maybe;Monad<Maybe> - [proc (dict;get proc-name procedures)] + (-> &.Analyser &.Eval Text (List Code) (Meta la.Analysis)) + (<| (maybe.default (&.throw Unknown-Procedure (%t proc-name))) + (do maybe.Monad<Maybe> + [proc (dict.get proc-name procedures)] (wrap ((proc proc-name) analyse eval proc-args))))) diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux index f5afca5bf..b003edfa7 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -14,16 +14,16 @@ [io]) (luxc ["&" lang] (lang ["la" analysis] - (analysis ["&;" common] - [";A" function] - [";A" case] - [";A" type])))) + (analysis ["&." common] + [".A" function] + [".A" case] + [".A" type])))) (exception: #export Incorrect-Procedure-Arity) ## [Utils] (type: #export Proc - (-> &;Analyser &;Eval (List Code) (Meta la;Analysis))) + (-> &.Analyser &.Eval (List Code) (Meta la.Analysis))) (type: #export Bundle (Dict Text (-> Text Proc))) @@ -31,14 +31,14 @@ (def: #export (install name unnamed) (-> Text (-> Text Proc) (-> Bundle Bundle)) - (dict;put name unnamed)) + (dict.put name unnamed)) (def: #export (prefix prefix bundle) (-> Text Bundle Bundle) (|> bundle - dict;entries + dict.entries (list/map (function [[key val]] [(format prefix " " key) val])) - (dict;from-list text;Hash<Text>))) + (dict.from-list text.Hash<Text>))) (def: #export (wrong-arity proc expected actual) (-> Text Nat Nat Text) @@ -48,19 +48,19 @@ (def: (simple proc inputsT+ outputT) (-> Text (List Type) Type Proc) - (let [num-expected (list;size inputsT+)] + (let [num-expected (list.size inputsT+)] (function [analyse eval args] - (let [num-actual (list;size args)] - (if (n.= num-expected num-actual) - (do macro;Monad<Meta> - [_ (&;infer outputT) - argsA (monad;map @ + (let [num-actual (list.size args)] + (if (n/= num-expected num-actual) + (do macro.Monad<Meta> + [_ (&.infer outputT) + argsA (monad.map @ (function [[argT argC]] - (&;with-type argT + (&.with-type argT (analyse argC))) - (list;zip2 inputsT+ args))] - (wrap (la;procedure proc argsA))) - (&;throw Incorrect-Procedure-Arity (wrong-arity proc num-expected num-actual))))))) + (list.zip2 inputsT+ args))] + (wrap (la.procedure proc argsA))) + (&.throw Incorrect-Procedure-Arity (wrong-arity proc num-expected num-actual))))))) (def: #export (nullary valueT proc) (-> Type Text Proc) @@ -83,8 +83,8 @@ (def: (lux-is proc) (-> Text Proc) (function [analyse eval args] - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] ((binary varT varT Bool proc) analyse eval args)))) @@ -95,37 +95,37 @@ (function [analyse eval args] (case args (^ (list opC)) - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - _ (&;infer (type (Either Text varT))) - opA (&;with-type (type (io;IO varT)) + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var) + _ (&.infer (type (Either Text varT))) + opA (&.with-type (type (io.IO varT)) (analyse opC))] - (wrap (la;procedure proc (list opA)))) + (wrap (la.procedure proc (list opA)))) _ - (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args)))))) + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args)))))) (def: (lux//function proc) (-> Text Proc) (function [analyse eval args] (case args - (^ (list [_ (#;Symbol ["" func-name])] - [_ (#;Symbol ["" arg-name])] + (^ (list [_ (#.Symbol ["" func-name])] + [_ (#.Symbol ["" arg-name])] body)) - (functionA;analyse-function analyse func-name arg-name body) + (functionA.analyse-function analyse func-name arg-name body) _ - (&;throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list;size args)))))) + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list.size args)))))) (def: (lux//case proc) (-> Text Proc) (function [analyse eval args] (case args - (^ (list input [_ (#;Record branches)])) - (caseA;analyse-case analyse input branches) + (^ (list input [_ (#.Record branches)])) + (caseA.analyse-case analyse input branches) _ - (&;throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list;size args)))))) + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args)))))) (do-template [<name> <analyser>] [(def: (<name> proc) @@ -136,28 +136,28 @@ (<analyser> analyse eval typeC valueC) _ - (&;throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list;size args))))))] + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))] - [lux//check typeA;analyse-check] - [lux//coerce typeA;analyse-coerce]) + [lux//check typeA.analyse-check] + [lux//coerce typeA.analyse-coerce]) (def: (lux//check//type proc) (-> Text Proc) (function [analyse eval args] (case args (^ (list valueC)) - (do macro;Monad<Meta> - [_ (&;infer (type Type)) - valueA (&;with-type Type + (do macro.Monad<Meta> + [_ (&.infer (type Type)) + valueA (&.with-type Type (analyse valueC))] (wrap valueA)) _ - (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args)))))) + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args)))))) (def: lux-procs Bundle - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "is" lux-is) (install "try" lux-try) (install "function" lux//function) @@ -169,7 +169,7 @@ (def: io-procs Bundle (<| (prefix "io") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "log" (unary Text Unit)) (install "error" (unary Text Bottom)) (install "exit" (unary Int Bottom)) @@ -178,7 +178,7 @@ (def: bit-procs Bundle (<| (prefix "bit") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "count" (unary Nat Nat)) (install "and" (binary Nat Nat Nat)) (install "or" (binary Nat Nat Nat)) @@ -191,7 +191,7 @@ (def: nat-procs Bundle (<| (prefix "nat") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary Nat Nat Nat)) (install "-" (binary Nat Nat Nat)) (install "*" (binary Nat Nat Nat)) @@ -207,7 +207,7 @@ (def: int-procs Bundle (<| (prefix "int") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary Int Int Int)) (install "-" (binary Int Int Int)) (install "*" (binary Int Int Int)) @@ -223,7 +223,7 @@ (def: deg-procs Bundle (<| (prefix "deg") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary Deg Deg Deg)) (install "-" (binary Deg Deg Deg)) (install "*" (binary Deg Deg Deg)) @@ -240,7 +240,7 @@ (def: frac-procs Bundle (<| (prefix "frac") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary Frac Frac Frac)) (install "-" (binary Frac Frac Frac)) (install "*" (binary Frac Frac Frac)) @@ -262,7 +262,7 @@ (def: text-procs Bundle (<| (prefix "text") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "=" (binary Text Text Bool)) (install "<" (binary Text Text Bool)) (install "concat" (binary Text Text Text)) @@ -280,31 +280,31 @@ (def: (array//get proc) (-> Text Proc) (function [analyse eval args] - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] ((binary (type (Array varT)) Nat (type (Maybe varT)) proc) analyse eval args)))) (def: (array//put proc) (-> Text Proc) (function [analyse eval args] - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc) analyse eval args)))) (def: (array//remove proc) (-> Text Proc) (function [analyse eval args] - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] ((binary (type (Array varT)) Nat (type (Array varT)) proc) analyse eval args)))) (def: array-procs Bundle (<| (prefix "array") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "new" (unary Nat Array)) (install "get" array//get) (install "put" array//put) @@ -315,7 +315,7 @@ (def: math-procs Bundle (<| (prefix "math") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "cos" (unary Frac Frac)) (install "sin" (unary Frac Frac)) (install "tan" (unary Frac Frac)) @@ -341,36 +341,36 @@ (function [analyse eval args] (case args (^ (list initC)) - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - _ (&;infer (type (Atom varT))) - initA (&;with-type varT + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var) + _ (&.infer (type (Atom varT))) + initA (&.with-type varT (analyse initC))] - (wrap (la;procedure proc (list initA)))) + (wrap (la.procedure proc (list initA)))) _ - (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args)))))) + (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args)))))) (def: (atom-read proc) (-> Text Proc) (function [analyse eval args] - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] + (do macro.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] - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var)] + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var)] ((trinary (type (Atom varT)) varT varT Bool proc) analyse eval args)))) (def: atom-procs Bundle (<| (prefix "atom") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "new" atom-new) (install "read" atom-read) (install "compare-and-swap" atom//compare-and-swap) @@ -379,25 +379,25 @@ (def: process-procs Bundle (<| (prefix "process") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "concurrency-level" (nullary Nat)) - (install "future" (unary (type (io;IO Top)) Unit)) - (install "schedule" (binary Nat (type (io;IO Top)) Unit)) + (install "future" (unary (type (io.IO Top)) Unit)) + (install "schedule" (binary Nat (type (io.IO Top)) Unit)) ))) (def: #export procedures Bundle (<| (prefix "lux") - (|> (dict;new text;Hash<Text>) - (dict;merge lux-procs) - (dict;merge bit-procs) - (dict;merge nat-procs) - (dict;merge int-procs) - (dict;merge deg-procs) - (dict;merge frac-procs) - (dict;merge text-procs) - (dict;merge array-procs) - (dict;merge math-procs) - (dict;merge atom-procs) - (dict;merge process-procs) - (dict;merge io-procs)))) + (|> (dict.new text.Hash<Text>) + (dict.merge lux-procs) + (dict.merge bit-procs) + (dict.merge nat-procs) + (dict.merge int-procs) + (dict.merge deg-procs) + (dict.merge frac-procs) + (dict.merge text-procs) + (dict.merge array-procs) + (dict.merge math-procs) + (dict.merge atom-procs) + (dict.merge process-procs) + (dict.merge io-procs)))) 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 bb388434f..3c29410d0 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: [lux #- char] (lux (control [monad #+ do] ["p" parser] @@ -21,10 +21,10 @@ (type ["tc" check])) [host]) (luxc ["&" lang] - (lang ["&;" host] + (lang ["&." host] ["la" analysis] - (analysis ["&;" common] - [";A" inference]))) + (analysis ["&." common] + [".A" inference]))) ["@" //common] ) @@ -32,7 +32,7 @@ (def: (wrong-syntax procedure args) (-> Text (List Code) Text) (format "Procedure: " procedure "\n" - "Arguments: " (%code (code;tuple args)))) + "Arguments: " (%code (code.tuple args)))) (exception: #export JVM-Type-Is-Not-Class) @@ -74,7 +74,7 @@ (def: #export null-class Text "#Null") (do-template [<name> <class>] - [(def: #export <name> Type (#;Primitive <class> (list)))] + [(def: #export <name> Type (#.Primitive <class> (list)))] ## Boxes [Boolean "java.lang.Boolean"] @@ -99,52 +99,52 @@ ) (def: conversion-procs - @;Bundle - (<| (@;prefix "convert") - (|> (dict;new text;Hash<Text>) - (@;install "double-to-float" (@;unary Double Float)) - (@;install "double-to-int" (@;unary Double Integer)) - (@;install "double-to-long" (@;unary Double Long)) - (@;install "float-to-double" (@;unary Float Double)) - (@;install "float-to-int" (@;unary Float Integer)) - (@;install "float-to-long" (@;unary Float Long)) - (@;install "int-to-byte" (@;unary Integer Byte)) - (@;install "int-to-char" (@;unary Integer Character)) - (@;install "int-to-double" (@;unary Integer Double)) - (@;install "int-to-float" (@;unary Integer Float)) - (@;install "int-to-long" (@;unary Integer Long)) - (@;install "int-to-short" (@;unary Integer Short)) - (@;install "long-to-double" (@;unary Long Double)) - (@;install "long-to-float" (@;unary Long Float)) - (@;install "long-to-int" (@;unary Long Integer)) - (@;install "long-to-short" (@;unary Long Short)) - (@;install "long-to-byte" (@;unary Long Byte)) - (@;install "char-to-byte" (@;unary Character Byte)) - (@;install "char-to-short" (@;unary Character Short)) - (@;install "char-to-int" (@;unary Character Integer)) - (@;install "char-to-long" (@;unary Character Long)) - (@;install "byte-to-long" (@;unary Byte Long)) - (@;install "short-to-long" (@;unary Short Long)) + @.Bundle + (<| (@.prefix "convert") + (|> (dict.new text.Hash<Text>) + (@.install "double-to-float" (@.unary Double Float)) + (@.install "double-to-int" (@.unary Double Integer)) + (@.install "double-to-long" (@.unary Double Long)) + (@.install "float-to-double" (@.unary Float Double)) + (@.install "float-to-int" (@.unary Float Integer)) + (@.install "float-to-long" (@.unary Float Long)) + (@.install "int-to-byte" (@.unary Integer Byte)) + (@.install "int-to-char" (@.unary Integer Character)) + (@.install "int-to-double" (@.unary Integer Double)) + (@.install "int-to-float" (@.unary Integer Float)) + (@.install "int-to-long" (@.unary Integer Long)) + (@.install "int-to-short" (@.unary Integer Short)) + (@.install "long-to-double" (@.unary Long Double)) + (@.install "long-to-float" (@.unary Long Float)) + (@.install "long-to-int" (@.unary Long Integer)) + (@.install "long-to-short" (@.unary Long Short)) + (@.install "long-to-byte" (@.unary Long Byte)) + (@.install "char-to-byte" (@.unary Character Byte)) + (@.install "char-to-short" (@.unary Character Short)) + (@.install "char-to-int" (@.unary Character Integer)) + (@.install "char-to-long" (@.unary Character Long)) + (@.install "byte-to-long" (@.unary Byte Long)) + (@.install "short-to-long" (@.unary Short Long)) ))) (do-template [<name> <prefix> <type>] [(def: <name> - @;Bundle - (<| (@;prefix <prefix>) - (|> (dict;new text;Hash<Text>) - (@;install "+" (@;binary <type> <type> <type>)) - (@;install "-" (@;binary <type> <type> <type>)) - (@;install "*" (@;binary <type> <type> <type>)) - (@;install "/" (@;binary <type> <type> <type>)) - (@;install "%" (@;binary <type> <type> <type>)) - (@;install "=" (@;binary <type> <type> Boolean)) - (@;install "<" (@;binary <type> <type> Boolean)) - (@;install "and" (@;binary <type> <type> <type>)) - (@;install "or" (@;binary <type> <type> <type>)) - (@;install "xor" (@;binary <type> <type> <type>)) - (@;install "shl" (@;binary <type> Integer <type>)) - (@;install "shr" (@;binary <type> Integer <type>)) - (@;install "ushr" (@;binary <type> Integer <type>)) + @.Bundle + (<| (@.prefix <prefix>) + (|> (dict.new text.Hash<Text>) + (@.install "+" (@.binary <type> <type> <type>)) + (@.install "-" (@.binary <type> <type> <type>)) + (@.install "*" (@.binary <type> <type> <type>)) + (@.install "/" (@.binary <type> <type> <type>)) + (@.install "%" (@.binary <type> <type> <type>)) + (@.install "=" (@.binary <type> <type> Boolean)) + (@.install "<" (@.binary <type> <type> Boolean)) + (@.install "and" (@.binary <type> <type> <type>)) + (@.install "or" (@.binary <type> <type> <type>)) + (@.install "xor" (@.binary <type> <type> <type>)) + (@.install "shl" (@.binary <type> Integer <type>)) + (@.install "shr" (@.binary <type> Integer <type>)) + (@.install "ushr" (@.binary <type> Integer <type>)) )))] [int-procs "int" Integer] @@ -153,16 +153,16 @@ (do-template [<name> <prefix> <type>] [(def: <name> - @;Bundle - (<| (@;prefix <prefix>) - (|> (dict;new text;Hash<Text>) - (@;install "+" (@;binary <type> <type> <type>)) - (@;install "-" (@;binary <type> <type> <type>)) - (@;install "*" (@;binary <type> <type> <type>)) - (@;install "/" (@;binary <type> <type> <type>)) - (@;install "%" (@;binary <type> <type> <type>)) - (@;install "=" (@;binary <type> <type> Boolean)) - (@;install "<" (@;binary <type> <type> Boolean)) + @.Bundle + (<| (@.prefix <prefix>) + (|> (dict.new text.Hash<Text>) + (@.install "+" (@.binary <type> <type> <type>)) + (@.install "-" (@.binary <type> <type> <type>)) + (@.install "*" (@.binary <type> <type> <type>)) + (@.install "/" (@.binary <type> <type> <type>)) + (@.install "%" (@.binary <type> <type> <type>)) + (@.install "=" (@.binary <type> <type> Boolean)) + (@.install "<" (@.binary <type> <type> Boolean)) )))] [float-procs "float" Float] @@ -170,11 +170,11 @@ ) (def: char-procs - @;Bundle - (<| (@;prefix "char") - (|> (dict;new text;Hash<Text>) - (@;install "=" (@;binary Character Character Boolean)) - (@;install "<" (@;binary Character Character Boolean)) + @.Bundle + (<| (@.prefix "char") + (|> (dict.new text.Hash<Text>) + (@.install "=" (@.binary Character Character Boolean)) + (@.install "<" (@.binary Character Character Boolean)) ))) (def: #export boxes @@ -187,439 +187,439 @@ ["float" "java.lang.Float"] ["double" "java.lang.Double"] ["char" "java.lang.Character"]) - (dict;from-list text;Hash<Text>))) + (dict.from-list text.Hash<Text>))) (def: (array-length proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list arrayC)) - (do macro;Monad<Meta> - [_ (&;infer Nat) - [var-id varT] (&;with-type-env tc;var) - arrayA (&;with-type (type (Array varT)) + (do macro.Monad<Meta> + [_ (&.infer Nat) + [var-id varT] (&.with-type-env tc.var) + arrayA (&.with-type (type (Array varT)) (analyse arrayC))] - (wrap (la;procedure proc (list arrayA)))) + (wrap (la.procedure proc (list arrayA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (array-new proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list lengthC)) - (do macro;Monad<Meta> - [lengthA (&;with-type Nat + (do macro.Monad<Meta> + [lengthA (&.with-type Nat (analyse lengthC)) - expectedT macro;expected-type + expectedT macro.expected-type [level elem-class] (: (Meta [Nat Text]) (loop [analysisT expectedT level +0] (case analysisT - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) (recur outputT level) - #;None - (&;throw Non-Array (%type expectedT))) + #.None + (&.throw Non-Array (%type expectedT))) - (^ (#;Primitive "#Array" (list elemT))) - (recur elemT (n.inc level)) + (^ (#.Primitive "#Array" (list elemT))) + (recur elemT (n/inc level)) - (#;Primitive class _) + (#.Primitive class _) (wrap [level class]) _ - (&;throw Non-Array (%type expectedT))))) - _ (if (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)))) + (&.throw Non-Array (%type expectedT)))] + (wrap (la.procedure proc (list (code.nat (n/dec level)) (code.text elem-class) lengthA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (check-jvm objectT) (-> Type (Meta Text)) (case objectT - (#;Primitive name _) + (#.Primitive name _) (macro/wrap name) - (#;Named name unnamed) + (#.Named name unnamed) (check-jvm unnamed) - (#;Var id) + (#.Var id) (macro/wrap "java.lang.Object") (^template [<tag>] (<tag> env unquantified) (check-jvm unquantified)) - ([#;UnivQ] - [#;ExQ]) + ([#.UnivQ] + [#.ExQ]) - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) (check-jvm outputT) - #;None - (&;throw Non-Object (%type objectT))) + #.None + (&.throw Non-Object (%type objectT))) _ - (&;throw Non-Object (%type objectT)))) + (&.throw Non-Object (%type objectT)))) (def: (check-object objectT) (-> Type (Meta Text)) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [name (check-jvm objectT)] - (if (dict;contains? name boxes) - (&;throw Primitives-Are-Not-Objects name) + (if (dict.contains? name boxes) + (&.throw Primitives-Are-Not-Objects name) (macro/wrap name)))) (def: (box-array-element-type elemT) (-> Type (Meta [Type Text])) (case elemT - (#;Primitive name #;Nil) - (let [boxed-name (|> (dict;get name boxes) - (maybe;default name))] - (macro/wrap [(#;Primitive boxed-name #;Nil) + (#.Primitive name #.Nil) + (let [boxed-name (|> (dict.get name boxes) + (maybe.default name))] + (macro/wrap [(#.Primitive boxed-name #.Nil) boxed-name])) - (#;Primitive name _) - (if (dict;contains? name boxes) - (&;throw Primitives-Cannot-Have-Type-Parameters name) + (#.Primitive name _) + (if (dict.contains? name boxes) + (&.throw Primitives-Cannot-Have-Type-Parameters name) (macro/wrap [elemT name])) _ - (&;throw Invalid-Type-For-Array-Element (%type elemT)))) + (&.throw Invalid-Type-For-Array-Element (%type elemT)))) (def: (array-read proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list arrayC idxC)) - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - _ (&;infer varT) - arrayA (&;with-type (type (Array varT)) + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var) + _ (&.infer varT) + arrayA (&.with-type (type (Array varT)) (analyse arrayC)) - ?elemT (&;with-type-env - (tc;read var-id)) - [elemT elem-class] (box-array-element-type (maybe;default varT ?elemT)) - idxA (&;with-type Nat + ?elemT (&.with-type-env + (tc.read var-id)) + [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (&.with-type Nat (analyse idxC))] - (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA)))) + (wrap (la.procedure proc (list (code.text elem-class) idxA arrayA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) (def: (array-write proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list arrayC idxC valueC)) - (do macro;Monad<Meta> - [[var-id varT] (&;with-type-env tc;var) - _ (&;infer (type (Array varT))) - arrayA (&;with-type (type (Array varT)) + (do macro.Monad<Meta> + [[var-id varT] (&.with-type-env tc.var) + _ (&.infer (type (Array varT))) + arrayA (&.with-type (type (Array varT)) (analyse arrayC)) - ?elemT (&;with-type-env - (tc;read var-id)) - [valueT elem-class] (box-array-element-type (maybe;default varT ?elemT)) - idxA (&;with-type Nat + ?elemT (&.with-type-env + (tc.read var-id)) + [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (&.with-type Nat (analyse idxC)) - valueA (&;with-type valueT + valueA (&.with-type valueT (analyse valueC))] - (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA)))) + (wrap (la.procedure proc (list (code.text elem-class) idxA valueA arrayA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) (def: array-procs - @;Bundle - (<| (@;prefix "array") - (|> (dict;new text;Hash<Text>) - (@;install "length" array-length) - (@;install "new" array-new) - (@;install "read" array-read) - (@;install "write" array-write) + @.Bundle + (<| (@.prefix "array") + (|> (dict.new text.Hash<Text>) + (@.install "length" array-length) + (@.install "new" array-new) + (@.install "read" array-read) + (@.install "write" array-write) ))) (def: (object-null proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list)) - (do macro;Monad<Meta> - [expectedT macro;expected-type + (do macro.Monad<Meta> + [expectedT macro.expected-type _ (check-object expectedT)] - (wrap (la;procedure proc (list)))) + (wrap (la.procedure proc (list)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +0 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +0 (list.size args)))))) (def: (object-null? proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list objectC)) - (do macro;Monad<Meta> - [_ (&;infer Bool) - [objectT objectA] (&common;with-unknown-type + (do macro.Monad<Meta> + [_ (&.infer Bool) + [objectT objectA] (&common.with-unknown-type (analyse objectC)) _ (check-object objectT)] - (wrap (la;procedure proc (list objectA)))) + (wrap (la.procedure proc (list objectA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (object-synchronized proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list monitorC exprC)) - (do macro;Monad<Meta> - [[monitorT monitorA] (&common;with-unknown-type + (do macro.Monad<Meta> + [[monitorT monitorA] (&common.with-unknown-type (analyse monitorC)) _ (check-object monitorT) exprA (analyse exprC)] - (wrap (la;procedure proc (list monitorA exprA)))) + (wrap (la.procedure proc (list monitorA exprA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) -(host;import java.lang.Object +(host.import java/lang/Object (equals [Object] boolean)) -(host;import java.lang.ClassLoader) +(host.import java/lang/ClassLoader) -(host;import #long java.lang.reflect.Type +(host.import #long java/lang/reflect/Type (getTypeName [] String)) -(host;import java.lang.reflect.GenericArrayType - (getGenericComponentType [] java.lang.reflect.Type)) +(host.import java/lang/reflect/GenericArrayType + (getGenericComponentType [] java/lang/reflect/Type)) -(host;import java.lang.reflect.ParameterizedType - (getRawType [] java.lang.reflect.Type) - (getActualTypeArguments [] (Array java.lang.reflect.Type))) +(host.import java/lang/reflect/ParameterizedType + (getRawType [] java/lang/reflect/Type) + (getActualTypeArguments [] (Array java/lang/reflect/Type))) -(host;import (java.lang.reflect.TypeVariable d) +(host.import (java/lang/reflect/TypeVariable d) (getName [] String) - (getBounds [] (Array java.lang.reflect.Type))) + (getBounds [] (Array java/lang/reflect/Type))) -(host;import (java.lang.reflect.WildcardType d) - (getLowerBounds [] (Array java.lang.reflect.Type)) - (getUpperBounds [] (Array java.lang.reflect.Type))) +(host.import (java/lang/reflect/WildcardType d) + (getLowerBounds [] (Array java/lang/reflect/Type)) + (getUpperBounds [] (Array java/lang/reflect/Type))) -(host;import java.lang.reflect.Modifier +(host.import java/lang/reflect/Modifier (#static isStatic [int] boolean) (#static isFinal [int] boolean) (#static isInterface [int] boolean) (#static isAbstract [int] boolean)) -(host;import java.lang.reflect.Field - (getDeclaringClass [] (java.lang.Class Object)) +(host.import java/lang/reflect/Field + (getDeclaringClass [] (java/lang/Class Object)) (getModifiers [] int) - (getGenericType [] java.lang.reflect.Type)) + (getGenericType [] java/lang/reflect/Type)) -(host;import java.lang.reflect.Method +(host.import java/lang/reflect/Method (getName [] String) (getModifiers [] int) (getDeclaringClass [] (Class Object)) (getTypeParameters [] (Array (TypeVariable Method))) - (getGenericParameterTypes [] (Array java.lang.reflect.Type)) - (getGenericReturnType [] java.lang.reflect.Type) - (getGenericExceptionTypes [] (Array java.lang.reflect.Type))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericReturnType [] java/lang/reflect/Type) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) -(host;import (java.lang.reflect.Constructor c) +(host.import (java/lang/reflect/Constructor c) (getModifiers [] int) (getDeclaringClass [] (Class c)) (getTypeParameters [] (Array (TypeVariable (Constructor c)))) - (getGenericParameterTypes [] (Array java.lang.reflect.Type)) - (getGenericExceptionTypes [] (Array java.lang.reflect.Type))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) -(host;import (java.lang.Class c) +(host.import (java/lang/Class c) (getName [] String) (getModifiers [] int) (#static forName [String boolean ClassLoader] #try (Class Object)) (isAssignableFrom [(Class Object)] boolean) (getTypeParameters [] (Array (TypeVariable (Class c)))) - (getGenericInterfaces [] (Array java.lang.reflect.Type)) - (getGenericSuperclass [] java.lang.reflect.Type) + (getGenericInterfaces [] (Array java/lang/reflect/Type)) + (getGenericSuperclass [] java/lang/reflect/Type) (getDeclaredField [String] #try Field) (getConstructors [] (Array (Constructor Object))) (getDeclaredMethods [] (Array Method))) (def: (load-class name) (-> Text (Meta (Class Object))) - (do macro;Monad<Meta> - [class-loader &host;class-loader] - (case (Class.forName [name false class-loader]) - (#e;Success [class]) + (do macro.Monad<Meta> + [class-loader &host.class-loader] + (case (Class::forName [name false class-loader]) + (#e.Success [class]) (wrap class) - (#e;Error error) - (&;throw Unknown-Class name)))) + (#e.Error error) + (&.throw Unknown-Class name)))) (def: (sub-class? super sub) (-> Text Text (Meta Bool)) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [super (load-class super) sub (load-class sub)] - (wrap (Class.isAssignableFrom [sub] super)))) + (wrap (Class::isAssignableFrom [sub] super)))) (def: (object-throw proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list exceptionC)) - (do macro;Monad<Meta> - [_ (&;infer Bottom) - [exceptionT exceptionA] (&common;with-unknown-type + (do macro.Monad<Meta> + [_ (&.infer Bottom) + [exceptionT exceptionA] (&common.with-unknown-type (analyse exceptionC)) 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 Non-Throwable exception-class)))] + (wrap (la.procedure proc (list exceptionA)))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (object-class proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC)) (case classC - [_ (#;Text class)] - (do macro;Monad<Meta> - [_ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list))))) + [_ (#.Text class)] + (do macro.Monad<Meta> + [_ (&.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) _ (load-class class)] - (wrap (la;procedure proc (list (code;text class))))) + (wrap (la.procedure proc (list (code.text class))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) (def: (object-instance? proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC objectC)) (case classC - [_ (#;Text class)] - (do macro;Monad<Meta> - [_ (&;infer Bool) - [objectT objectA] (&common;with-unknown-type + [_ (#.Text class)] + (do macro.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)))) + (wrap (la.procedure proc (list (code.text class)))) + (&.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) (def: object-procs - @;Bundle - (<| (@;prefix "object") - (|> (dict;new text;Hash<Text>) - (@;install "null" object-null) - (@;install "null?" object-null?) - (@;install "synchronized" object-synchronized) - (@;install "throw" object-throw) - (@;install "class" object-class) - (@;install "instance?" object-instance?) + @.Bundle + (<| (@.prefix "object") + (|> (dict.new text.Hash<Text>) + (@.install "null" object-null) + (@.install "null?" object-null?) + (@.install "synchronized" object-synchronized) + (@.install "throw" object-throw) + (@.install "class" object-class) + (@.install "instance?" object-instance?) ))) (def: type-descriptor - (-> java.lang.reflect.Type Text) - (java.lang.reflect.Type.getTypeName [])) + (-> java/lang/reflect/Type Text) + (java/lang/reflect/Type::getTypeName [])) (def: (java-type-to-class type) - (-> java.lang.reflect.Type (Meta Text)) - (cond (host;instance? Class type) - (macro/wrap (Class.getName [] (:! Class type))) + (-> java/lang/reflect/Type (Meta Text)) + (cond (host.instance? Class type) + (macro/wrap (Class::getName [] (:! Class type))) - (host;instance? ParameterizedType type) - (java-type-to-class (ParameterizedType.getRawType [] (:! ParameterizedType type))) + (host.instance? ParameterizedType type) + (java-type-to-class (ParameterizedType::getRawType [] (:! ParameterizedType type))) ## else - (&;throw Cannot-Convert-To-Class (type-descriptor type)))) + (&.throw Cannot-Convert-To-Class (type-descriptor type)))) (type: Mappings (Dict Text Type)) -(def: fresh-mappings Mappings (dict;new text;Hash<Text>)) +(def: fresh-mappings Mappings (dict.new text.Hash<Text>)) (def: (java-type-to-lux-type mappings java-type) - (-> Mappings java.lang.reflect.Type (Meta Type)) - (cond (host;instance? TypeVariable java-type) - (let [var-name (TypeVariable.getName [] (:! TypeVariable java-type))] - (case (dict;get var-name mappings) - (#;Some var-type) + (-> Mappings java/lang/reflect/Type (Meta Type)) + (cond (host.instance? TypeVariable java-type) + (let [var-name (TypeVariable::getName [] (:! TypeVariable java-type))] + (case (dict.get var-name mappings) + (#.Some var-type) (macro/wrap var-type) - #;None - (&;throw Unknown-Type-Var var-name))) + #.None + (&.throw Unknown-Type-Var var-name))) - (host;instance? WildcardType java-type) + (host.instance? WildcardType java-type) (let [java-type (:! WildcardType java-type)] - (case [(array;read +0 (WildcardType.getUpperBounds [] java-type)) - (array;read +0 (WildcardType.getLowerBounds [] java-type))] - (^or [(#;Some bound) _] [_ (#;Some bound)]) + (case [(array.read +0 (WildcardType::getUpperBounds [] java-type)) + (array.read +0 (WildcardType::getLowerBounds [] java-type))] + (^or [(#.Some bound) _] [_ (#.Some bound)]) (java-type-to-lux-type mappings bound) _ (macro/wrap Top))) - (host;instance? Class java-type) + (host.instance? Class java-type) (let [java-type (:! (Class Object) java-type) - class-name (Class.getName [] java-type)] - (macro/wrap (case (array;size (Class.getTypeParameters [] java-type)) + class-name (Class::getName [] java-type)] + (macro/wrap (case (array.size (Class::getTypeParameters [] java-type)) +0 - (#;Primitive class-name (list)) + (#.Primitive class-name (list)) arity - (|> (list;n.range +0 (n.dec arity)) - list;reverse - (list/map (|>. (n.* +2) n.inc #;Bound)) - (#;Primitive class-name) - (type;univ-q arity))))) + (|> (list.n/range +0 (n/dec arity)) + list.reverse + (list/map (|>> (n/* +2) n/inc #.Bound)) + (#.Primitive class-name) + (type.univ-q arity))))) - (host;instance? ParameterizedType java-type) + (host.instance? ParameterizedType java-type) (let [java-type (:! ParameterizedType java-type) - raw (ParameterizedType.getRawType [] java-type)] - (if (host;instance? Class raw) - (do macro;Monad<Meta> + raw (ParameterizedType::getRawType [] java-type)] + (if (host.instance? Class raw) + (do macro.Monad<Meta> [paramsT (|> java-type - (ParameterizedType.getActualTypeArguments []) - array;to-list - (monad;map @ (java-type-to-lux-type mappings)))] - (macro/wrap (#;Primitive (Class.getName [] (:! (Class Object) raw)) + (ParameterizedType::getActualTypeArguments []) + array.to-list + (monad.map @ (java-type-to-lux-type mappings)))] + (macro/wrap (#.Primitive (Class::getName [] (:! (Class Object) raw)) paramsT))) - (&;throw JVM-Type-Is-Not-Class (type-descriptor raw)))) + (&.throw JVM-Type-Is-Not-Class (type-descriptor raw)))) - (host;instance? GenericArrayType java-type) - (do macro;Monad<Meta> + (host.instance? GenericArrayType java-type) + (do macro.Monad<Meta> [innerT (|> (:! GenericArrayType java-type) - (GenericArrayType.getGenericComponentType []) + (GenericArrayType::getGenericComponentType []) (java-type-to-lux-type mappings))] - (wrap (#;Primitive "#Array" (list innerT)))) + (wrap (#.Primitive "#Array" (list innerT)))) ## else - (&;throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) + (&.throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) (type: Direction #In @@ -634,18 +634,18 @@ (def: (correspond-type-params class type) (-> (Class Object) Type (Meta Mappings)) (case type - (#;Primitive name params) - (let [class-name (Class.getName [] class) - class-params (array;to-list (Class.getTypeParameters [] class)) - num-class-params (list;size class-params) - num-type-params (list;size params)] + (#.Primitive name params) + (let [class-name (Class::getName [] class) + 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 + (&.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 + (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" @@ -653,28 +653,28 @@ ## else (macro/wrap (|> params - (list;zip2 (list/map (TypeVariable.getName []) class-params)) - (dict;from-list text;Hash<Text>))) + (list.zip2 (list/map (TypeVariable::getName []) class-params)) + (dict.from-list text.Hash<Text>))) )) _ - (&;throw Non-JVM-Type (%type type)))) + (&.throw Non-JVM-Type (%type type)))) (def: (cast direction to from) (-> Direction Type Type (Meta [Text Type])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [to-name (check-jvm to) from-name (check-jvm from)] - (cond (dict;contains? to-name boxes) - (let [box (maybe;assume (dict;get to-name boxes))] + (cond (dict.contains? to-name boxes) + (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 (cannot-cast to from)))) + (wrap [(choose direction to-name from-name) (#.Primitive to-name (list))]) + (&.throw Cannot-Cast (cannot-cast to from)))) - (dict;contains? from-name boxes) - (let [box (maybe;assume (dict;get from-name boxes))] + (dict.contains? from-name boxes) + (let [box (maybe.assume (dict.get from-name boxes))] (do @ - [[_ castT] (cast direction to (#;Primitive box (list)))] + [[_ castT] (cast direction to (#.Primitive box (list)))] (wrap [(choose direction to-name from-name) castT]))) (text/= to-name from-name) @@ -687,226 +687,226 @@ (do @ [to-class (load-class to-name) from-class (load-class from-name) - _ (&;assert Cannot-Cast (cannot-cast to from) - (Class.isAssignableFrom [from-class] to-class)) - candiate-parents (monad;map @ + _ (&.assert Cannot-Cast (cannot-cast to from) + (Class::isAssignableFrom [from-class] to-class)) + candiate-parents (monad.map @ (function [java-type] (do @ [class-name (java-type-to-class java-type) class (load-class class-name)] - (wrap [java-type (Class.isAssignableFrom [class] to-class)]))) - (list& (Class.getGenericSuperclass [] from-class) - (array;to-list (Class.getGenericInterfaces [] from-class))))] + (wrap [java-type (Class::isAssignableFrom [class] to-class)]))) + (list& (Class::getGenericSuperclass [] from-class) + (array.to-list (Class::getGenericInterfaces [] from-class))))] (case (|> candiate-parents - (list;filter product;right) - (list/map product;left)) - (#;Cons parent _) + (list.filter product.right) + (list/map product.left)) + (#.Cons parent _) (do @ [mapping (correspond-type-params from-class from) parentT (java-type-to-lux-type mapping parent) [_ castT] (cast direction to parentT)] (wrap [(choose direction to-name from-name) castT])) - #;Nil - (&;throw Cannot-Cast (cannot-cast to from))))))) + #.Nil + (&.throw Cannot-Cast (cannot-cast to from))))))) (def: (infer-out outputT) (-> Type (Meta [Text Type])) - (do macro;Monad<Meta> - [expectedT macro;expected-type + (do macro.Monad<Meta> + [expectedT macro.expected-type [unboxed castT] (cast #Out expectedT outputT) - _ (&;with-type-env - (tc;check expectedT castT))] + _ (&.with-type-env + (tc.check expectedT castT))] (wrap [unboxed castT]))) (def: (find-field class-name field-name) (-> Text Text (Meta [(Class Object) Field])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [class (load-class class-name)] - (case (Class.getDeclaredField [field-name] class) - (#e;Success field) - (let [owner (Field.getDeclaringClass [] field)] + (case (Class::getDeclaredField [field-name] class) + (#e.Success field) + (let [owner (Field::getDeclaringClass [] field)] (if (is owner class) (wrap [class field]) - (&;throw Mistaken-Field-Owner + (&.throw Mistaken-Field-Owner (format " Field: " field-name "\n" - " Owner Class: " (Class.getName [] owner) "\n" + " Owner Class: " (Class::getName [] owner) "\n" "Target Class: " class-name "\n")))) - (#e;Error _) - (&;throw Unknown-Field (format class-name "#" field-name))))) + (#e.Error _) + (&.throw Unknown-Field (format class-name "#" field-name))))) (def: (static-field class-name field-name) (-> Text Text (Meta [Type Bool])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field.getModifiers [] fieldJ)]] - (if (Modifier.isStatic [modifiers]) - (let [fieldJT (Field.getGenericType [] fieldJ)] + #let [modifiers (Field::getModifiers [] fieldJ)]] + (if (Modifier::isStatic [modifiers]) + (let [fieldJT (Field::getGenericType [] fieldJ)] (do @ [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] - (wrap [fieldT (Modifier.isFinal [modifiers])]))) - (&;throw Not-Static-Field (format class-name "#" field-name))))) + (wrap [fieldT (Modifier::isFinal [modifiers])]))) + (&.throw Not-Static-Field (format class-name "#" field-name))))) (def: (virtual-field class-name field-name objectT) (-> Text Text Type (Meta [Type Bool])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field.getModifiers [] fieldJ)]] - (if (not (Modifier.isStatic [modifiers])) + #let [modifiers (Field::getModifiers [] fieldJ)]] + (if (not (Modifier::isStatic [modifiers])) (do @ - [#let [fieldJT (Field.getGenericType [] fieldJ) + [#let [fieldJT (Field::getGenericType [] fieldJ) var-names (|> class - (Class.getTypeParameters []) - array;to-list - (list/map (TypeVariable.getName [])))] + (Class::getTypeParameters []) + array.to-list + (list/map (TypeVariable::getName [])))] mappings (: (Meta Mappings) (case objectT - (#;Primitive _class-name _class-params) + (#.Primitive _class-name _class-params) (do @ - [#let [num-params (list;size _class-params) - num-vars (list;size var-names)] - _ (&;assert Type-Parameter-Mismatch + [#let [num-params (list.size _class-params) + num-vars (list.size var-names)] + _ (&.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>)))) + (n/= num-params num-vars))] + (wrap (|> (list.zip2 var-names _class-params) + (dict.from-list text.Hash<Text>)))) _ - (&;throw Non-Object (%type objectT)))) + (&.throw Non-Object (%type objectT)))) fieldT (java-type-to-lux-type mappings fieldJT)] - (wrap [fieldT (Modifier.isFinal [modifiers])])) - (&;throw Not-Virtual-Field (format class-name "#" field-name))))) + (wrap [fieldT (Modifier::isFinal [modifiers])])) + (&.throw Not-Virtual-Field (format class-name "#" field-name))))) (def: (analyse-object class analyse sourceC) - (-> Text &;Analyser Code (Meta [Type la;Analysis])) - (do macro;Monad<Meta> + (-> Text &.Analyser Code (Meta [Type la.Analysis])) + (do macro.Monad<Meta> [target-class (load-class class) targetT (java-type-to-lux-type fresh-mappings - (:! java.lang.reflect.Type + (:! java/lang/reflect/Type target-class)) - [sourceT sourceA] (&common;with-unknown-type + [sourceT sourceA] (&common.with-unknown-type (analyse sourceC)) [unboxed castT] (cast #Out targetT sourceT) - _ (&;assert Cannot-Cast (cannot-cast targetT sourceT) - (not (dict;contains? unboxed boxes)))] + _ (&.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])) - (do macro;Monad<Meta> - [[sourceT sourceA] (&common;with-unknown-type + (-> &.Analyser Type Code (Meta [Type Text la.Analysis])) + (do macro.Monad<Meta> + [[sourceT sourceA] (&common.with-unknown-type (analyse sourceC)) [unboxed castT] (cast #In targetT sourceT)] (wrap [castT unboxed sourceA]))) (def: (static-get proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC fieldC)) (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad<Meta> + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> [[fieldT final?] (static-field class field) [unboxed castT] (infer-out fieldT)] - (wrap (la;procedure proc (list (code;text class) (code;text field) - (code;text unboxed))))) + (wrap (la.procedure proc (list (code.text class) (code.text field) + (code.text unboxed))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) (def: (static-put proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC fieldC valueC)) (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad<Meta> - [_ (&;infer Unit) + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> + [_ (&.infer Unit) [fieldT final?] (static-field class field) - _ (&;assert Cannot-Set-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))] - (wrap (la;procedure proc (list (code;text class) (code;text field) - (code;text unboxed) valueA)))) + _ (&.with-type-env + (tc.check fieldT valueT))] + (wrap (la.procedure proc (list (code.text class) (code.text field) + (code.text unboxed) valueA)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) (def: (virtual-get proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC fieldC objectC)) (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad<Meta> + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> [[objectT objectA] (analyse-object class analyse objectC) [fieldT final?] (virtual-field class field objectT) [unboxed castT] (infer-out fieldT)] - (wrap (la;procedure proc (list (code;text class) (code;text field) - (code;text unboxed) objectA)))) + (wrap (la.procedure proc (list (code.text class) (code.text field) + (code.text unboxed) objectA)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args)))))) + (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) (def: (virtual-put proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] (case args (^ (list classC fieldC valueC objectC)) (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do macro;Monad<Meta> + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> [[objectT objectA] (analyse-object class analyse objectC) - _ (&;infer objectT) + _ (&.infer objectT) [fieldT final?] (virtual-field class field objectT) - _ (&;assert Cannot-Set-Final-Field (format class "#" field) + _ (&.assert Cannot-Set-Final-Field (format class "#" field) (not final?)) [valueT unboxed valueA] (analyse-input analyse fieldT valueC)] - (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA)))) + (wrap (la.procedure proc (list (code.text class) (code.text field) (code.text unboxed) valueA objectA)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))) + (&.throw Wrong-Syntax (wrong-syntax proc args))) _ - (&;throw @;Incorrect-Procedure-Arity (@;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)) - (cond (host;instance? Class type) - (macro/wrap (Class.getName [] (:! Class type))) + (-> java/lang/reflect/Type (Meta Text)) + (cond (host.instance? Class type) + (macro/wrap (Class::getName [] (:! Class type))) - (host;instance? ParameterizedType type) - (java-type-to-parameter (ParameterizedType.getRawType [] (:! ParameterizedType type))) + (host.instance? ParameterizedType type) + (java-type-to-parameter (ParameterizedType::getRawType [] (:! ParameterizedType type))) - (or (host;instance? TypeVariable type) - (host;instance? WildcardType type)) + (or (host.instance? TypeVariable type) + (host.instance? WildcardType type)) (macro/wrap "java.lang.Object") - (host;instance? GenericArrayType type) - (do macro;Monad<Meta> - [componentP (java-type-to-parameter (GenericArrayType.getGenericComponentType [] (:! GenericArrayType type)))] + (host.instance? GenericArrayType type) + (do macro.Monad<Meta> + [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:! GenericArrayType type)))] (wrap (format componentP "[]"))) ## else - (&;throw Cannot-Convert-To-Parameter (type-descriptor type)))) + (&.throw Cannot-Convert-To-Parameter (type-descriptor type)))) (type: Method-Type #Static @@ -917,326 +917,326 @@ (def: (check-method class method-name method-type arg-classes method) (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool)) - (do macro;Monad<Meta> - [parameters (|> (Method.getGenericParameterTypes [] method) - array;to-list - (monad;map @ java-type-to-parameter)) - #let [modifiers (Method.getModifiers [] method)]] - (wrap (and (Object.equals [class] (Method.getDeclaringClass [] method)) - (text/= method-name (Method.getName [] method)) + (do macro.Monad<Meta> + [parameters (|> (Method::getGenericParameterTypes [] method) + array.to-list + (monad.map @ java-type-to-parameter)) + #let [modifiers (Method::getModifiers [] method)]] + (wrap (and (Object::equals [class] (Method::getDeclaringClass [] method)) + (text/= method-name (Method::getName [] method)) (case #Static #Special - (Modifier.isStatic [modifiers]) + (Modifier::isStatic [modifiers]) _ true) (case method-type #Special - (not (or (Modifier.isInterface [(Class.getModifiers [] class)]) - (Modifier.isAbstract [modifiers]))) + (not (or (Modifier::isInterface [(Class::getModifiers [] class)]) + (Modifier::isAbstract [modifiers]))) _ true) - (n.= (list;size arg-classes) (list;size parameters)) + (n/= (list.size arg-classes) (list.size parameters)) (list/fold (function [[expectedJC actualJC] prev] (and prev (text/= expectedJC actualJC))) true - (list;zip2 arg-classes parameters)))))) + (list.zip2 arg-classes parameters)))))) (def: (check-constructor class arg-classes constructor) (-> (Class Object) (List Text) (Constructor Object) (Meta Bool)) - (do macro;Monad<Meta> - [parameters (|> (Constructor.getGenericParameterTypes [] constructor) - array;to-list - (monad;map @ java-type-to-parameter))] - (wrap (and (Object.equals [class] (Constructor.getDeclaringClass [] constructor)) - (n.= (list;size arg-classes) (list;size parameters)) + (do macro.Monad<Meta> + [parameters (|> (Constructor::getGenericParameterTypes [] constructor) + array.to-list + (monad.map @ java-type-to-parameter))] + (wrap (and (Object::equals [class] (Constructor::getDeclaringClass [] constructor)) + (n/= (list.size arg-classes) (list.size parameters)) (list/fold (function [[expectedJC actualJC] prev] (and prev (text/= expectedJC actualJC))) true - (list;zip2 arg-classes parameters)))))) + (list.zip2 arg-classes parameters)))))) (def: idx-to-bound (-> Nat Type) - (|>. (n.* +2) n.inc #;Bound)) + (|>> (n/* +2) n/inc #.Bound)) (def: (type-vars amount offset) (-> Nat Nat (List Type)) - (if (n.= +0 amount) + (if (n/= +0 amount) (list) - (|> (list;n.range offset (|> amount n.dec (n.+ offset))) + (|> (list.n/range offset (|> amount n/dec (n/+ offset))) (list/map idx-to-bound)))) (def: (method-to-type method-type method) (-> Method-Type Method (Meta [Type (List Type)])) - (let [owner (Method.getDeclaringClass [] method) - owner-name (Class.getName [] owner) + (let [owner (Method::getDeclaringClass [] method) + owner-name (Class::getName [] owner) owner-tvars (case method-type #Static (list) _ - (|> (Class.getTypeParameters [] owner) - array;to-list - (list/map (TypeVariable.getName [])))) - method-tvars (|> (Method.getTypeParameters [] method) - array;to-list - (list/map (TypeVariable.getName []))) - num-owner-tvars (list;size owner-tvars) - num-method-tvars (list;size method-tvars) + (|> (Class::getTypeParameters [] owner) + array.to-list + (list/map (TypeVariable::getName [])))) + method-tvars (|> (Method::getTypeParameters [] method) + array.to-list + (list/map (TypeVariable::getName []))) + num-owner-tvars (list.size owner-tvars) + num-method-tvars (list.size method-tvars) all-tvars (list/compose owner-tvars method-tvars) - num-all-tvars (list;size all-tvars) + num-all-tvars (list.size all-tvars) owner-tvarsT (type-vars num-owner-tvars +0) method-tvarsT (type-vars num-method-tvars num-owner-tvars) mappings (: Mappings - (if (list;empty? all-tvars) + (if (list.empty? all-tvars) fresh-mappings (|> (list/compose owner-tvarsT method-tvarsT) - list;reverse - (list;zip2 all-tvars) - (dict;from-list text;Hash<Text>))))] - (do macro;Monad<Meta> - [inputsT (|> (Method.getGenericParameterTypes [] method) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - outputT (java-type-to-lux-type mappings (Method.getGenericReturnType [] method)) - exceptionsT (|> (Method.getGenericExceptionTypes [] method) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - #let [methodT (<| (type;univ-q num-all-tvars) - (type;function (case method-type + list.reverse + (list.zip2 all-tvars) + (dict.from-list text.Hash<Text>))))] + (do macro.Monad<Meta> + [inputsT (|> (Method::getGenericParameterTypes [] method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + outputT (java-type-to-lux-type mappings (Method::getGenericReturnType [] method)) + exceptionsT (|> (Method::getGenericExceptionTypes [] method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [methodT (<| (type.univ-q num-all-tvars) + (type.function (case method-type #Static inputsT _ - (list& (#;Primitive owner-name (list;reverse owner-tvarsT)) + (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) inputsT))) outputT)]] (wrap [methodT exceptionsT])))) (def: (methods class-name method-name method-type arg-classes) (-> Text Text Method-Type (List Text) (Meta [Type (List Type)])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [class (load-class class-name) candidates (|> class - (Class.getDeclaredMethods []) - array;to-list - (monad;map @ (function [method] + (Class::getDeclaredMethods []) + array.to-list + (monad.map @ (function [method] (do @ [passes? (check-method class method-name method-type arg-classes method)] (wrap [passes? method])))))] - (case (list;filter product;left candidates) - #;Nil - (&;throw No-Candidates (format class-name "#" method-name)) + (case (list.filter product.left candidates) + #.Nil + (&.throw No-Candidates (format class-name "#" method-name)) - (#;Cons candidate #;Nil) - (|> candidate product;right (method-to-type method-type)) + (#.Cons candidate #.Nil) + (|> candidate product.right (method-to-type method-type)) _ - (&;throw Too-Many-Candidates (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)])) - (let [owner (Constructor.getDeclaringClass [] constructor) - owner-name (Class.getName [] owner) - owner-tvars (|> (Class.getTypeParameters [] owner) - array;to-list - (list/map (TypeVariable.getName []))) - constructor-tvars (|> (Constructor.getTypeParameters [] constructor) - array;to-list - (list/map (TypeVariable.getName []))) - num-owner-tvars (list;size owner-tvars) + (let [owner (Constructor::getDeclaringClass [] constructor) + owner-name (Class::getName [] owner) + owner-tvars (|> (Class::getTypeParameters [] owner) + array.to-list + (list/map (TypeVariable::getName []))) + constructor-tvars (|> (Constructor::getTypeParameters [] constructor) + array.to-list + (list/map (TypeVariable::getName []))) + num-owner-tvars (list.size owner-tvars) all-tvars (list/compose owner-tvars constructor-tvars) - num-all-tvars (list;size all-tvars) + num-all-tvars (list.size all-tvars) owner-tvarsT (type-vars num-owner-tvars +0) constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) mappings (: Mappings - (if (list;empty? all-tvars) + (if (list.empty? all-tvars) fresh-mappings (|> (list/compose owner-tvarsT constructor-tvarsT) - list;reverse - (list;zip2 all-tvars) - (dict;from-list text;Hash<Text>))))] - (do macro;Monad<Meta> - [inputsT (|> (Constructor.getGenericParameterTypes [] constructor) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - exceptionsT (|> (Constructor.getGenericExceptionTypes [] constructor) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - #let [objectT (#;Primitive owner-name (list;reverse owner-tvarsT)) - constructorT (<| (type;univ-q num-all-tvars) - (type;function inputsT) + list.reverse + (list.zip2 all-tvars) + (dict.from-list text.Hash<Text>))))] + (do macro.Monad<Meta> + [inputsT (|> (Constructor::getGenericParameterTypes [] constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + exceptionsT (|> (Constructor::getGenericExceptionTypes [] constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT)) + constructorT (<| (type.univ-q num-all-tvars) + (type.function inputsT) objectT)]] (wrap [constructorT exceptionsT])))) (def: (constructor-methods class-name arg-classes) (-> Text (List Text) (Meta [Type (List Type)])) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [class (load-class class-name) candidates (|> class - (Class.getConstructors []) - array;to-list - (monad;map @ (function [constructor] + (Class::getConstructors []) + array.to-list + (monad.map @ (function [constructor] (do @ [passes? (check-constructor class arg-classes constructor)] (wrap [passes? constructor])))))] - (case (list;filter product;left candidates) - #;Nil - (&;throw No-Candidates (format class-name "(" (text;join-with ", " arg-classes) ")")) + (case (list.filter product.left candidates) + #.Nil + (&.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")")) - (#;Cons candidate #;Nil) - (|> candidate product;right constructor-to-type) + (#.Cons candidate #.Nil) + (|> candidate product.right constructor-to-type) _ - (&;throw Too-Many-Candidates class-name)))) + (&.throw Too-Many-Candidates class-name)))) (def: (decorate-inputs typesT inputsA) - (-> (List Text) (List la;Analysis) (List la;Analysis)) + (-> (List Text) (List la.Analysis) (List la.Analysis)) (|> inputsA - (list;zip2 (list/map code;text typesT)) + (list.zip2 (list/map code.text typesT)) (list/map (function [[type value]] - (la;product (list type value)))))) + (la.product (list type value)))))) (def: (sub-type-analyser analyse) - (-> &;Analyser &;Analyser) + (-> &.Analyser &.Analyser) (function [argC] - (do macro;Monad<Meta> - [[argT argA] (&common;with-unknown-type + (do macro.Monad<Meta> + [[argT argA] (&common.with-unknown-type (analyse argC)) - expectedT macro;expected-type + expectedT macro.expected-type [unboxed castT] (cast #In expectedT argT)] (wrap argA)))) (def: (invoke//static proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] - (case (: (e;Error [Text Text (List [Text Code])]) - (s;run args ($_ p;seq s;text s;text (p;some (s;tuple (p;seq s;text s;any)))))) - (#e;Success [class method argsTC]) - (do macro;Monad<Meta> - [#let [argsT (list/map product;left argsTC)] + (case (: (e.Error [Text Text (List [Text Code])]) + (s.run args ($_ p.seq s.text s.text (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class method argsTC]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Static argsT) - [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC)) + [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC)) [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (code;text method) - (code;text unboxed) (decorate-inputs argsT argsA))))) + (wrap (la.procedure proc (list& (code.text class) (code.text method) + (code.text unboxed) (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//virtual proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] - (case (: (e;Error [Text Text Code (List [Text Code])]) - (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any)))))) - (#e;Success [class method objectC argsTC]) - (do macro;Monad<Meta> - [#let [argsT (list/map product;left argsTC)] + (case (: (e.Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class method objectC argsTC]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Virtual argsT) - [outputT allA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [outputT allA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC))) #let [[objectA argsA] (case allA - (#;Cons objectA argsA) + (#.Cons objectA argsA) [objectA argsA] _ (undefined))] [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (code;text method) - (code;text unboxed) objectA (decorate-inputs argsT argsA))))) + (wrap (la.procedure proc (list& (code.text class) (code.text method) + (code.text unboxed) objectA (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//special proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] - (case (: (e;Error [(List Code) [Text Text Code (List [Text Code]) Unit]]) - (p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!))) - (#e;Success [_ [class method objectC argsTC _]]) - (do macro;Monad<Meta> - [#let [argsT (list/map product;left argsTC)] + (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Unit]]) + (p.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))) s.end!))) + (#e.Success [_ [class method objectC argsTC _]]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Special argsT) - [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC))) [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (code;text method) - (code;text unboxed) (decorate-inputs argsT argsA))))) + (wrap (la.procedure proc (list& (code.text class) (code.text method) + (code.text unboxed) (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//interface proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] - (case (: (e;Error [Text Text Code (List [Text Code])]) - (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any)))))) - (#e;Success [class-name method objectC argsTC]) - (do macro;Monad<Meta> - [#let [argsT (list/map product;left argsTC)] + (case (: (e.Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class-name method objectC argsTC]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] class (load-class class-name) - _ (&;assert Non-Interface class-name - (Modifier.isInterface [(Class.getModifiers [] class)])) + _ (&.assert Non-Interface class-name + (Modifier::isInterface [(Class::getModifiers [] class)])) [methodT exceptionsT] (methods class-name method #Interface argsT) - [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC))) [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc - (list& (code;text class-name) (code;text method) (code;text unboxed) + (wrap (la.procedure proc + (list& (code.text class-name) (code.text method) (code.text unboxed) (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: (invoke//constructor proc) - (-> Text @;Proc) + (-> Text @.Proc) (function [analyse eval args] - (case (: (e;Error [Text (List [Text Code])]) - (s;run args ($_ p;seq s;text (p;some (s;tuple (p;seq s;text s;any)))))) - (#e;Success [class argsTC]) - (do macro;Monad<Meta> - [#let [argsT (list/map product;left argsTC)] + (case (: (e.Error [Text (List [Text Code])]) + (s.run args ($_ p.seq s.text (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class argsTC]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (constructor-methods class argsT) - [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC)) + [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC)) [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA))))) + (wrap (la.procedure proc (list& (code.text class) (decorate-inputs argsT argsA))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc args))))) + (&.throw Wrong-Syntax (wrong-syntax proc args))))) (def: member-procs - @;Bundle - (<| (@;prefix "member") - (|> (dict;new text;Hash<Text>) - (dict;merge (<| (@;prefix "static") - (|> (dict;new text;Hash<Text>) - (@;install "get" static-get) - (@;install "put" static-put)))) - (dict;merge (<| (@;prefix "virtual") - (|> (dict;new text;Hash<Text>) - (@;install "get" virtual-get) - (@;install "put" virtual-put)))) - (dict;merge (<| (@;prefix "invoke") - (|> (dict;new text;Hash<Text>) - (@;install "static" invoke//static) - (@;install "virtual" invoke//virtual) - (@;install "special" invoke//special) - (@;install "interface" invoke//interface) - (@;install "constructor" invoke//constructor) + @.Bundle + (<| (@.prefix "member") + (|> (dict.new text.Hash<Text>) + (dict.merge (<| (@.prefix "static") + (|> (dict.new text.Hash<Text>) + (@.install "get" static-get) + (@.install "put" static-put)))) + (dict.merge (<| (@.prefix "virtual") + (|> (dict.new text.Hash<Text>) + (@.install "get" virtual-get) + (@.install "put" virtual-put)))) + (dict.merge (<| (@.prefix "invoke") + (|> (dict.new text.Hash<Text>) + (@.install "static" invoke//static) + (@.install "virtual" invoke//virtual) + (@.install "special" invoke//special) + (@.install "interface" invoke//interface) + (@.install "constructor" invoke//constructor) ))) ))) (def: #export procedures - @;Bundle - (<| (@;prefix "jvm") - (|> (dict;new text;Hash<Text>) - (dict;merge conversion-procs) - (dict;merge int-procs) - (dict;merge long-procs) - (dict;merge float-procs) - (dict;merge double-procs) - (dict;merge char-procs) - (dict;merge array-procs) - (dict;merge object-procs) - (dict;merge member-procs) + @.Bundle + (<| (@.prefix "jvm") + (|> (dict.new text.Hash<Text>) + (dict.merge conversion-procs) + (dict.merge int-procs) + (dict.merge long-procs) + (dict.merge float-procs) + (dict.merge double-procs) + (dict.merge char-procs) + (dict.merge array-procs) + (dict.merge object-procs) + (dict.merge member-procs) ))) diff --git a/new-luxc/source/luxc/lang/analysis/reference.lux b/new-luxc/source/luxc/lang/analysis/reference.lux index c660408de..56aba35de 100644 --- a/new-luxc/source/luxc/lang/analysis/reference.lux +++ b/new-luxc/source/luxc/lang/analysis/reference.lux @@ -1,56 +1,56 @@ -(;module: +(.module: lux (lux (control monad) [macro] (macro [code]) (lang (type ["tc" check]))) (luxc ["&" lang] - (lang ["&;" scope] + (lang ["&." scope] ["la" analysis #+ Analysis] - [";L" variable #+ Variable]))) + [".L" variable #+ Variable]))) ## [Analysers] (def: (analyse-definition def-name) (-> Ident (Meta Analysis)) - (do macro;Monad<Meta> - [[actualT def-anns _] (&;with-error-tracking - (macro;find-def def-name))] - (case (macro;get-symbol-ann (ident-for #;alias) def-anns) - (#;Some real-def-name) + (do macro.Monad<Meta> + [[actualT def-anns _] (&.with-error-tracking + (macro.find-def def-name))] + (case (macro.get-symbol-ann (ident-for #.alias) def-anns) + (#.Some real-def-name) (analyse-definition real-def-name) _ (do @ - [_ (&;infer actualT) - def-name (macro;normalize def-name)] - (wrap (code;symbol def-name)))))) + [_ (&.infer actualT) + def-name (macro.normalize def-name)] + (wrap (code.symbol def-name)))))) (def: (analyse-variable var-name) (-> Text (Meta (Maybe Analysis))) - (do macro;Monad<Meta> - [?var (&scope;find var-name)] + (do macro.Monad<Meta> + [?var (&scope.find var-name)] (case ?var - (#;Some [actualT ref]) + (#.Some [actualT ref]) (do @ - [_ (&;infer actualT)] - (wrap (#;Some (` ((~ (code;int (variableL;from-ref ref)))))))) + [_ (&.infer actualT)] + (wrap (#.Some (` ((~ (code.int (variableL.from-ref ref)))))))) - #;None - (wrap #;None)))) + #.None + (wrap #.None)))) (def: #export (analyse-reference reference) (-> Ident (Meta Analysis)) (case reference ["" simple-name] - (do macro;Monad<Meta> + (do macro.Monad<Meta> [?var (analyse-variable simple-name)] (case ?var - (#;Some varA) + (#.Some varA) (wrap varA) - #;None + #.None (do @ - [this-module macro;current-module-name] + [this-module macro.current-module-name] (analyse-definition [this-module simple-name])))) _ diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux index e6cd2dbad..fb521d02e 100644 --- a/new-luxc/source/luxc/lang/analysis/structure.lux +++ b/new-luxc/source/luxc/lang/analysis/structure.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -14,11 +14,11 @@ (lang [type] (type ["tc" check]))) (luxc ["&" lang] - (lang ["&;" scope] - ["&;" module] + (lang ["&." scope] + ["&." module] ["la" analysis] - (analysis ["&;" common] - ["&;" inference])))) + (analysis ["&." common] + ["&." inference])))) (exception: #export Invalid-Variant-Type) (exception: #export Invalid-Tuple-Type) @@ -34,46 +34,46 @@ (exception: #export Record-Size-Mismatch) (def: #export (analyse-sum analyse tag valueC) - (-> &;Analyser Nat Code (Meta la;Analysis)) - (do macro;Monad<Meta> - [expectedT macro;expected-type] - (&;with-stacked-errors + (-> &.Analyser Nat Code (Meta la.Analysis)) + (do macro.Monad<Meta> + [expectedT macro.expected-type] + (&.with-stacked-errors (function [_] (Cannot-Analyse-Variant (format " Type: " (%type expectedT) "\n" " Tag: " (%n tag) "\n" "Expression: " (%code valueC)))) (case expectedT - (#;Sum _) - (let [flat (type;flatten-variant expectedT) - type-size (list;size flat)] - (case (list;nth tag flat) - (#;Some variant-type) + (#.Sum _) + (let [flat (type.flatten-variant expectedT) + type-size (list.size flat)] + (case (list.nth tag flat) + (#.Some variant-type) (do @ - [valueA (&;with-type variant-type + [valueA (&.with-type variant-type (analyse valueC)) - temp &scope;next-local] - (wrap (la;sum tag type-size temp valueA))) + temp &scope.next-local] + (wrap (la.sum tag type-size temp valueA))) - #;None - (&common;variant-out-of-bounds-error expectedT type-size tag))) + #.None + (&common.variant-out-of-bounds-error expectedT type-size tag))) - (#;Named name unnamedT) - (&;with-type unnamedT + (#.Named name unnamedT) + (&.with-type unnamedT (analyse-sum analyse tag valueC)) - (#;Var id) + (#.Var id) (do @ - [?expectedT' (&;with-type-env - (tc;read id))] + [?expectedT' (&.with-type-env + (tc.read id))] (case ?expectedT' - (#;Some expectedT') - (&;with-type expectedT' + (#.Some expectedT') + (&.with-type expectedT' (analyse-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 (format " Type: " (%type expectedT) "\n" + (&.throw Cannot-Infer-Numeric-Tag (format " Type: " (%type expectedT) "\n" " Tag: " (%n tag) "\n" "Expression: " (%code valueC))) )) @@ -81,59 +81,59 @@ (^template [<tag> <instancer>] (<tag> _) (do @ - [[instance-id instanceT] (&;with-type-env <instancer>)] - (&;with-type (maybe;assume (type;apply (list instanceT) expectedT)) + [[instance-id instanceT] (&.with-type-env <instancer>)] + (&.with-type (maybe.assume (type.apply (list instanceT) expectedT)) (analyse-sum analyse tag valueC)))) - ([#;UnivQ tc;existential] - [#;ExQ tc;var]) + ([#.UnivQ tc.existential] + [#.ExQ tc.var]) - (#;Apply inputT funT) + (#.Apply inputT funT) (case funT - (#;Var funT-id) + (#.Var funT-id) (do @ - [?funT' (&;with-type-env (tc;read funT-id))] + [?funT' (&.with-type-env (tc.read funT-id))] (case ?funT' - (#;Some funT') - (&;with-type (#;Apply inputT funT') + (#.Some funT') + (&.with-type (#.Apply inputT funT') (analyse-sum analyse tag valueC)) _ - (&;throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" + (&.throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" " Tag: " (%n tag) "\n" "Expression: " (%code valueC))))) _ - (case (type;apply (list inputT) funT) - #;None - (&;throw Not-Quantified-Type (%type funT)) + (case (type.apply (list inputT) funT) + #.None + (&.throw Not-Quantified-Type (%type funT)) - (#;Some outputT) - (&;with-type outputT + (#.Some outputT) + (&.with-type outputT (analyse-sum analyse tag valueC)))) _ - (&;throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" + (&.throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" " Tag: " (%n tag) "\n" "Expression: " (%code valueC))))))) (def: (analyse-typed-product analyse membersC+) - (-> &;Analyser (List Code) (Meta la;Analysis)) - (do macro;Monad<Meta> - [expectedT macro;expected-type] + (-> &.Analyser (List Code) (Meta la.Analysis)) + (do macro.Monad<Meta> + [expectedT 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)] - (&;with-type tailT + [tailT (#.Cons tailC #.Nil)] + (&.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)] + [(#.Product leftT rightT) (#.Cons leftC rightC)] (do @ - [leftA (&;with-type leftT + [leftA (&.with-type leftT (analyse leftC)) rightA (recur rightT rightC)] (wrap (` [(~ leftA) (~ rightA)]))) @@ -157,98 +157,98 @@ ## and what was analysed. [tailT tailC] (do @ - [g!tail (macro;gensym "tail")] - (&;with-type tailT + [g!tail (macro.gensym "tail")] + (&.with-type tailT (analyse (` ("lux case" [(~@ tailC)] (~ g!tail) (~ g!tail)))))) )))) (def: #export (analyse-product analyse membersC) - (-> &;Analyser (List Code) (Meta la;Analysis)) - (do macro;Monad<Meta> - [expectedT macro;expected-type] - (&;with-stacked-errors + (-> &.Analyser (List Code) (Meta la.Analysis)) + (do macro.Monad<Meta> + [expectedT macro.expected-type] + (&.with-stacked-errors (function [_] (Cannot-Analyse-Tuple (format " Type: " (%type expectedT) "\n" "Expression: " (%code (` [(~@ membersC)]))))) (case expectedT - (#;Product _) + (#.Product _) (analyse-typed-product analyse membersC) - (#;Named name unnamedT) - (&;with-type unnamedT + (#.Named name unnamedT) + (&.with-type unnamedT (analyse-product analyse membersC)) - (#;Var id) + (#.Var id) (do @ - [?expectedT' (&;with-type-env - (tc;read id))] + [?expectedT' (&.with-type-env + (tc.read id))] (case ?expectedT' - (#;Some expectedT') - (&;with-type expectedT' + (#.Some expectedT') + (&.with-type expectedT' (analyse-product analyse membersC)) _ ## Must do inference... (do @ - [membersTA (monad;map @ (|>. analyse &common;with-unknown-type) + [membersTA (monad.map @ (|>> analyse &common.with-unknown-type) membersC) - _ (&;with-type-env - (tc;check expectedT - (type;tuple (list/map product;left membersTA))))] - (wrap (la;product (list/map product;right membersTA)))))) + _ (&.with-type-env + (tc.check expectedT + (type.tuple (list/map product.left membersTA))))] + (wrap (la.product (list/map product.right membersTA)))))) (^template [<tag> <instancer>] (<tag> _) (do @ - [[instance-id instanceT] (&;with-type-env <instancer>)] - (&;with-type (maybe;assume (type;apply (list instanceT) expectedT)) + [[instance-id instanceT] (&.with-type-env <instancer>)] + (&.with-type (maybe.assume (type.apply (list instanceT) expectedT)) (analyse-product analyse membersC)))) - ([#;UnivQ tc;existential] - [#;ExQ tc;var]) + ([#.UnivQ tc.existential] + [#.ExQ tc.var]) - (#;Apply inputT funT) + (#.Apply inputT funT) (case funT - (#;Var funT-id) + (#.Var funT-id) (do @ - [?funT' (&;with-type-env (tc;read funT-id))] + [?funT' (&.with-type-env (tc.read funT-id))] (case ?funT' - (#;Some funT') - (&;with-type (#;Apply inputT funT') + (#.Some funT') + (&.with-type (#.Apply inputT funT') (analyse-product analyse membersC)) _ - (&;throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" + (&.throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" "Expression: " (%code (` [(~@ membersC)])))))) _ - (case (type;apply (list inputT) funT) - #;None - (&;throw Not-Quantified-Type (%type funT)) + (case (type.apply (list inputT) funT) + #.None + (&.throw Not-Quantified-Type (%type funT)) - (#;Some outputT) - (&;with-type outputT + (#.Some outputT) + (&.with-type outputT (analyse-product analyse membersC)))) _ - (&;throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" + (&.throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" "Expression: " (%code (` [(~@ membersC)])))) )))) (def: #export (analyse-tagged-sum analyse tag valueC) - (-> &;Analyser Ident Code (Meta la;Analysis)) - (do macro;Monad<Meta> - [tag (macro;normalize tag) - [idx group variantT] (macro;resolve-tag tag) - expectedT macro;expected-type] + (-> &.Analyser Ident Code (Meta la.Analysis)) + (do macro.Monad<Meta> + [tag (macro.normalize tag) + [idx group variantT] (macro.resolve-tag tag) + expectedT macro.expected-type] (case expectedT - (#;Var _) + (#.Var _) (do @ - [#let [case-size (list;size group)] - inferenceT (&inference;variant idx case-size variantT) - [inferredT valueA+] (&inference;general analyse inferenceT (list valueC)) - temp &scope;next-local] - (wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume)))) + [#let [case-size (list.size group)] + inferenceT (&inference.variant idx case-size variantT) + [inferredT valueA+] (&inference.general analyse inferenceT (list valueC)) + temp &scope.next-local] + (wrap (la.sum idx case-size temp (|> valueA+ list.head maybe.assume)))) _ (analyse-sum analyse idx valueC)))) @@ -259,17 +259,17 @@ ## canonical form (with their corresponding module identified). (def: #export (normalize record) (-> (List [Code Code]) (Meta (List [Ident Code]))) - (monad;map macro;Monad<Meta> + (monad.map macro.Monad<Meta> (function [[key val]] (case key - [_ (#;Tag key)] - (do macro;Monad<Meta> - [key (macro;normalize key)] + [_ (#.Tag key)] + (do macro.Monad<Meta> + [key (macro.normalize key)] (wrap [key val])) _ - (&;throw Record-Keys-Must-Be-Tags (format " Key: " (%code key) "\n" - "Record: " (%code (code;record record)))))) + (&.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 @@ -279,56 +279,56 @@ (-> (List [Ident Code]) (Meta [(List Code) Type])) (case record ## empty-record = empty-tuple = unit = [] - #;Nil - (:: macro;Monad<Meta> wrap [(list) Unit]) - - (#;Cons [head-k head-v] _) - (do macro;Monad<Meta> - [head-k (macro;normalize head-k) - [_ tag-set recordT] (macro;resolve-tag head-k) - #let [size-record (list;size record) - size-ts (list;size tag-set)] - _ (if (n.= size-ts size-record) + #.Nil + (:: macro.Monad<Meta> wrap [(list) Unit]) + + (#.Cons [head-k head-v] _) + (do macro.Monad<Meta> + [head-k (macro.normalize head-k) + [_ tag-set recordT] (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 + (&.throw Record-Size-Mismatch (format " Expected: " (|> size-ts nat-to-int %i) "\n" " Actual: " (|> size-record nat-to-int %i) "\n" " Type: " (%type recordT) "\n" "Expression: " (%code (|> record (list/map (function [[keyI valueC]] - [(code;tag keyI) valueC])) - code;record))))) - #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 @ + [(code.tag keyI) valueC])) + code.record))))) + #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 @ (function [[key val] idx->val] (do @ - [key (macro;normalize key)] - (case (dict;get key tag->idx) - #;None - (&;throw Tag-Does-Not-Belong-To-Record - (format " Tag: " (%code (code;tag key)) "\n" + [key (macro.normalize key)] + (case (dict.get key tag->idx) + #.None + (&.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) - (&;throw Cannot-Repeat-Tag - (format " Tag: " (%code (code;tag key)) "\n" - "Record: " (%code (code;record (list/map (function [[keyI valC]] - [(code;tag keyI) valC]) + (#.Some idx) + (if (dict.contains? idx idx->val) + (&.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)))))) + (wrap (dict.put idx val idx->val)))))) (: (Dict Nat Code) - (dict;new number;Hash<Nat>)) + (dict.new number.Hash<Nat>)) record) - #let [ordered-tuple (list/map (function [idx] (maybe;assume (dict;get idx idx->val))) + #let [ordered-tuple (list/map (function [idx] (maybe.assume (dict.get idx idx->val))) tuple-range)]] (wrap [ordered-tuple recordT])) )) (def: #export (analyse-record analyse members) - (-> &;Analyser (List [Code Code]) (Meta la;Analysis)) - (do macro;Monad<Meta> + (-> &.Analyser (List [Code Code]) (Meta la.Analysis)) + (do macro.Monad<Meta> [members (normalize members) [membersC recordT] (order members)] (case membersC @@ -337,13 +337,13 @@ _ (do @ - [expectedT macro;expected-type] + [expectedT macro.expected-type] (case expectedT - (#;Var _) + (#.Var _) (do @ - [inferenceT (&inference;record recordT) - [inferredT membersA] (&inference;general analyse inferenceT membersC)] - (wrap (la;product membersA))) + [inferenceT (&inference.record recordT) + [inferredT membersA] (&inference.general analyse inferenceT membersC)] + (wrap (la.product membersA))) _ (analyse-product analyse membersC)))))) diff --git a/new-luxc/source/luxc/lang/analysis/type.lux b/new-luxc/source/luxc/lang/analysis/type.lux index f85608e19..c3296fd21 100644 --- a/new-luxc/source/luxc/lang/analysis/type.lux +++ b/new-luxc/source/luxc/lang/analysis/type.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad) [macro] @@ -10,18 +10,18 @@ ## means of evaluating Lux expressions at compile-time for the sake of ## computing Lux type values. (def: #export (analyse-check analyse eval type value) - (-> &;Analyser &;Eval Code Code (Meta Analysis)) - (do macro;Monad<Meta> + (-> &.Analyser &.Eval Code Code (Meta Analysis)) + (do macro.Monad<Meta> [actualT (eval Type type) #let [actualT (:! Type actualT)] - _ (&;infer actualT)] - (&;with-type actualT + _ (&.infer actualT)] + (&.with-type actualT (analyse value)))) (def: #export (analyse-coerce analyse eval type value) - (-> &;Analyser &;Eval Code Code (Meta Analysis)) - (do macro;Monad<Meta> + (-> &.Analyser &.Eval Code Code (Meta Analysis)) + (do macro.Monad<Meta> [actualT (eval Type type) - _ (&;infer (:! Type actualT))] - (&;with-type Top + _ (&.infer (:! Type actualT))] + (&.with-type Top (analyse value)))) |