diff options
Diffstat (limited to 'new-luxc/source/luxc/analyser')
| -rw-r--r-- | new-luxc/source/luxc/analyser/case.lux | 108 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/common.lux | 20 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/function.lux | 45 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/inference.lux | 21 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/primitive.lux | 8 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure.lux | 20 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/common.lux | 86 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/host.jvm.lux | 57 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/reference.lux | 8 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/structure.lux | 103 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/type.lux | 8 |
11 files changed, 244 insertions, 240 deletions
diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux index 9a205d934..4b327fb6d 100644 --- a/new-luxc/source/luxc/analyser/case.lux +++ b/new-luxc/source/luxc/analyser/case.lux @@ -2,18 +2,18 @@ lux (lux (control [monad #+ do] eq) - (data [bool "B/" Eq<Bool>] + (data [bool] [number] + [product] + ["R" result] + [maybe] [text] text/format - [product] - ["R" result "R/" Monad<Result>] - (coll [list "L/" Fold<List> Monoid<List> Monad<List>] - ["D" dict])) - [macro #+ Monad<Lux>] + (coll [list "list/" Fold<List> Monoid<List> Functor<List>])) + [macro] (macro [code]) [type] - (type ["TC" check])) + (type ["tc" check])) (../.. ["&" base] (lang ["la" analysis]) ["&;" scope]) @@ -37,13 +37,13 @@ (-> Type (Lux Type)) (case type (#;Var id) - (do Monad<Lux> - [? (&;within-type-env - (TC;bound? id))] + (do macro;Monad<Lux> + [? (&;with-type-env + (tc;bound? id))] (if ? (do @ - [type' (&;within-type-env - (TC;read-var id))] + [type' (&;with-type-env + (tc;read id))] (simplify-case-type type')) (&;fail (format "Cannot simplify type for pattern-matching: " (%type type))))) @@ -51,13 +51,13 @@ (simplify-case-type unnamedT) (^or (#;UnivQ _) (#;ExQ _)) - (do Monad<Lux> - [[ex-id exT] (&;within-type-env - TC;existential)] - (simplify-case-type (assume (type;apply (list exT) type)))) + (do macro;Monad<Lux> + [[ex-id exT] (&;with-type-env + tc;existential)] + (simplify-case-type (maybe;assume (type;apply (list exT) type)))) _ - (:: Monad<Lux> wrap type))) + (:: macro;Monad<Lux> wrap type))) ## This function handles several concerns at once, but it must be that ## way because those concerns are interleaved when doing @@ -80,7 +80,7 @@ (case pattern [cursor (#;Symbol ["" name])] (&;with-cursor cursor - (do Monad<Lux> + (do macro;Monad<Lux> [outputA (&scope;with-local [name inputT] next) idx &scope;next-local] @@ -93,9 +93,9 @@ (^template [<type> <code-tag> <pattern-tag>] [cursor (<code-tag> test)] (&;with-cursor cursor - (do Monad<Lux> - [_ (&;within-type-env - (TC;check inputT <type>)) + (do macro;Monad<Lux> + [_ (&;with-type-env + (tc;check inputT <type>)) outputA next] (wrap [(<pattern-tag> test) outputA])))) ([Bool #;Bool #la;BoolP] @@ -107,9 +107,9 @@ (^ [cursor (#;Tuple (list))]) (&;with-cursor cursor - (do Monad<Lux> - [_ (&;within-type-env - (TC;check inputT Unit)) + (do macro;Monad<Lux> + [_ (&;with-type-env + (tc;check inputT Unit)) outputA next] (wrap [(#la;TupleP (list)) outputA]))) @@ -118,39 +118,39 @@ [cursor (#;Tuple sub-patterns)] (&;with-cursor cursor - (do Monad<Lux> + (do macro;Monad<Lux> [inputT' (simplify-case-type inputT)] (case inputT' (#;Product _) (let [sub-types (type;flatten-tuple inputT) - num-sub-types (default (list;size sub-types) - num-tags) + 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 (L/append prefix (list (type;tuple suffix))) sub-patterns)) + (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 (L/append prefix (list (code;tuple suffix))))) + (list;zip2 sub-types (list/compose prefix (list (code;tuple suffix))))) ## (n.= num-sub-types num-sub-patterns) (list;zip2 sub-types sub-patterns) )] (do @ - [[memberP+ thenA] (L/fold (: (All [a] - (-> [Type Code] (Lux [(List la;Pattern) a]) - (Lux [(List la;Pattern) a]))) - (function [[memberT memberC] then] - (do @ - [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Lux a) (Lux [la;Pattern a]))) - analyse-pattern) - #;None memberT memberC then)] - (wrap [(list& memberP memberP+) thenA])))) - (do @ - [nextA next] - (wrap [(list) nextA])) - matches)] + [[memberP+ thenA] (list/fold (: (All [a] + (-> [Type Code] (Lux [(List la;Pattern) a]) + (Lux [(List la;Pattern) a]))) + (function [[memberT memberC] then] + (do @ + [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Lux a) (Lux [la;Pattern a]))) + analyse-pattern) + #;None memberT memberC then)] + (wrap [(list& memberP memberP+) thenA])))) + (do @ + [nextA next] + (wrap [(list) nextA])) + matches)] (wrap [(#la;TupleP memberP+) thenA]))) _ @@ -158,11 +158,11 @@ ))) [cursor (#;Record record)] - (do Monad<Lux> + (do macro;Monad<Lux> [record (&structure;normalize record) [members recordT] (&structure;order record) - _ (&;within-type-env - (TC;check inputT recordT))] + _ (&;with-type-env + (tc;check inputT recordT))] (analyse-pattern (#;Some (list;size members)) inputT [cursor (#;Tuple members)] next)) [cursor (#;Tag tag)] @@ -171,26 +171,26 @@ (^ [cursor (#;Form (list& [_ (#;Nat idx)] values))]) (&;with-cursor cursor - (do Monad<Lux> + (do macro;Monad<Lux> [inputT' (simplify-case-type inputT)] (case inputT' (#;Sum _) (let [flat-sum (type;flatten-variant inputT) size-sum (list;size flat-sum) - num-cases (default size-sum num-tags)] + 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 Monad<Lux> + (do macro;Monad<Lux> [[testP nextA] (analyse-pattern #;None (type;variant (list;drop (n.dec num-cases) flat-sum)) (` [(~@ values)]) next)] (wrap [(#la;VariantP idx num-cases testP) nextA])) - (do Monad<Lux> + (do macro;Monad<Lux> [[testP nextA] (analyse-pattern #;None case-type (` [(~@ values)]) next)] (wrap [(#la;VariantP idx num-cases testP) nextA]))) @@ -203,11 +203,11 @@ (^ [cursor (#;Form (list& [_ (#;Tag tag)] values))]) (&;with-cursor cursor - (do Monad<Lux> + (do macro;Monad<Lux> [tag (macro;normalize tag) [idx group variantT] (macro;resolve-tag tag) - _ (&;within-type-env - (TC;check inputT variantT))] + _ (&;with-type-env + (tc;check inputT variantT))] (analyse-pattern (#;Some (list;size group)) inputT (` ((~ (code;nat idx)) (~@ values))) next))) _ @@ -221,7 +221,7 @@ (&;fail "Cannot have empty branches in pattern-matching expression.") (#;Cons [patternH bodyH] branchesT) - (do Monad<Lux> + (do macro;Monad<Lux> [[inputT inputA] (&common;with-unknown-type (analyse input)) outputH (analyse-pattern #;None inputT patternH (analyse bodyH)) @@ -232,7 +232,7 @@ _ (case (monad;fold R;Monad<Result> &&coverage;merge (|> outputH product;left &&coverage;determine) - (L/map (|>. product;left &&coverage;determine) outputT)) + (list/map (|>. product;left &&coverage;determine) outputT)) (#R;Success coverage) (if (&&coverage;exhaustive? coverage) (wrap []) diff --git a/new-luxc/source/luxc/analyser/common.lux b/new-luxc/source/luxc/analyser/common.lux index c1246d81c..b9142713c 100644 --- a/new-luxc/source/luxc/analyser/common.lux +++ b/new-luxc/source/luxc/analyser/common.lux @@ -6,29 +6,31 @@ [product]) [macro #+ Monad<Lux>] [type] - (type ["TC" check])) + (type ["tc" check])) (luxc ["&" base] (lang analysis))) (def: #export (with-unknown-type action) (All [a] (-> (Lux Analysis) (Lux [Type Analysis]))) (do Monad<Lux> - [[var-id var-type] (&;within-type-env - TC;create-var) + [[var-id var-type] (&;with-type-env + tc;create) analysis (&;with-expected-type var-type action) - analysis-type (&;within-type-env - (TC;clean var-id var-type)) - _ (&;within-type-env - (TC;delete-var var-id))] + analysis-type (&;with-type-env + (tc;clean var-id var-type)) + _ (&;with-type-env + (tc;delete var-id))] (wrap [analysis-type analysis]))) (def: #export (with-var body) (All [a] (-> (-> [Nat Type] (Lux a)) (Lux a))) (do Monad<Lux> - [[id var] (&;within-type-env TC;create-var) + [[id var] (&;with-type-env + tc;create) output (body [id var]) - _ (&;within-type-env (TC;delete-var id))] + _ (&;with-type-env + (tc;delete id))] (wrap output))) (def: #export (variant-out-of-bounds-error type size tag) diff --git a/new-luxc/source/luxc/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux index 31bc367f4..f9fde0eab 100644 --- a/new-luxc/source/luxc/analyser/function.lux +++ b/new-luxc/source/luxc/analyser/function.lux @@ -1,12 +1,13 @@ (;module: lux (lux (control monad) - (data [text] + (data [maybe] + [text] text/format - (coll [list "L/" Fold<List> Monoid<List> Monad<List>])) + (coll [list "list/" Fold<List> Monoid<List> Monad<List>])) [macro #+ Monad<Lux>] [type] - (type ["TC" check])) + (type ["tc" check])) (luxc ["&" base] (lang ["la" analysis #+ Analysis]) ["&;" scope] @@ -35,23 +36,23 @@ (#;UnivQ _) (do @ - [[var-id var] (&;within-type-env - TC;existential)] - (recur (assume (type;apply (list var) expected)))) + [[var-id var] (&;with-type-env + tc;existential)] + (recur (maybe;assume (type;apply (list var) expected)))) (#;ExQ _) (&common;with-var (function [[var-id var]] - (recur (assume (type;apply (list var) expected))))) + (recur (maybe;assume (type;apply (list var) expected))))) (#;Var id) (do @ - [? (&;within-type-env - (TC;bound? id))] + [? (&;with-type-env + (tc;bound? id))] (if ? (do @ - [expected' (&;within-type-env - (TC;read-var id))] + [expected' (&;with-type-env + (tc;read id))] (recur expected')) ## Inference (&common;with-var @@ -61,16 +62,16 @@ (do @ [#let [funT (#;Function inputT outputT)] funA (recur funT) - funT' (&;within-type-env - (TC;clean output-id funT)) - concrete-input? (&;within-type-env - (TC;bound? input-id)) + funT' (&;with-type-env + (tc;clean output-id funT)) + concrete-input? (&;with-type-env + (tc;bound? input-id)) funT'' (if concrete-input? - (&;within-type-env - (TC;clean input-id funT')) + (&;with-type-env + (tc;clean input-id funT')) (wrap (type;univ-q +1 (&inference;replace-var input-id +1 funT')))) - _ (&;within-type-env - (TC;check expected funT''))] + _ (&;with-type-env + (tc;check expected funT''))] (wrap funA)) )))))) @@ -92,10 +93,10 @@ (-> &;Analyser Type Analysis (List Code) (Lux Analysis)) (&;with-stacked-errors (function [_] (format "Cannot apply function " (%type funcT) - " to args: " (|> args (L/map %code) (text;join-with " ")))) + " to args: " (|> args (list/map %code) (text;join-with " ")))) (do Monad<Lux> [expected macro;expected-type [applyT argsA] (&inference;apply-function analyse funcT args) - _ (&;within-type-env - (TC;check expected applyT))] + _ (&;with-type-env + (tc;check expected applyT))] (wrap (la;apply argsA funcA))))) diff --git a/new-luxc/source/luxc/analyser/inference.lux b/new-luxc/source/luxc/analyser/inference.lux index 8390a890c..9b2411249 100644 --- a/new-luxc/source/luxc/analyser/inference.lux +++ b/new-luxc/source/luxc/analyser/inference.lux @@ -1,11 +1,12 @@ (;module: lux (lux (control monad) - (data text/format + (data [maybe] + text/format (coll [list "L/" Functor<List>])) [macro #+ Monad<Lux>] [type] - (type ["TC" check])) + (type ["tc" check])) (luxc ["&" base] (lang ["la" analysis #+ Analysis]) (analyser ["&;" common]))) @@ -74,23 +75,23 @@ (&common;with-var (function [[var-id varT]] (do Monad<Lux> - [[outputT argsA] (apply-function analyse (assume (type;apply (list varT) funcT)) args)] + [[outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) funcT)) args)] (do @ - [? (&;within-type-env - (TC;bound? var-id)) + [? (&;with-type-env + (tc;bound? var-id)) ## Quantify over the type if genericity/parametricity ## is discovered. outputT' (if ? - (&;within-type-env - (TC;clean var-id outputT)) + (&;with-type-env + (tc;clean var-id outputT)) (wrap (type;univ-q +1 (replace-var var-id +1 outputT))))] (wrap [outputT' argsA]))))) (#;ExQ _) (do Monad<Lux> - [[ex-id exT] (&;within-type-env - TC;existential)] - (apply-function analyse (assume (type;apply (list exT) funcT)) args)) + [[ex-id exT] (&;with-type-env + tc;existential)] + (apply-function analyse (maybe;assume (type;apply (list exT) funcT)) args)) ## Arguments are inferred back-to-front because, by convention, ## Lux functions take the most important arguments *last*, which diff --git a/new-luxc/source/luxc/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux index 69e4f2b07..127e5896c 100644 --- a/new-luxc/source/luxc/analyser/primitive.lux +++ b/new-luxc/source/luxc/analyser/primitive.lux @@ -12,8 +12,8 @@ (-> <type> (Lux Analysis)) (do Monad<Lux> [expected macro;expected-type - _ (&;within-type-env - (TC;check expected <type>))] + _ (&;with-type-env + (TC;check expected <type>))] (wrap (<tag> value))))] [analyse-bool Bool #la;Bool] @@ -28,6 +28,6 @@ (Lux Analysis) (do Monad<Lux> [expected macro;expected-type - _ (&;within-type-env - (TC;check expected Unit))] + _ (&;with-type-env + (TC;check expected Unit))] (wrap #la;Unit))) diff --git a/new-luxc/source/luxc/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux index 064a28e9b..23fbae198 100644 --- a/new-luxc/source/luxc/analyser/procedure.lux +++ b/new-luxc/source/luxc/analyser/procedure.lux @@ -1,23 +1,23 @@ (;module: lux (lux (control [monad #+ do]) - (data [text] + (data [maybe] + [text] text/format - (coll ["d" dict]) - [maybe])) + (coll [dict]))) (luxc ["&" base] - (lang ["la" analysis #+ Analysis])) + (lang ["la" analysis])) (. ["./;" common] ["./;" host])) (def: procedures ./common;Bundle (|> ./common;procedures - (d;merge ./host;procedures))) + (dict;merge ./host;procedures))) (def: #export (analyse-procedure analyse proc-name proc-args) - (-> &;Analyser Text (List Code) (Lux Analysis)) - (default (&;fail (format "Unknown procedure: " (%t proc-name))) - (do maybe;Monad<Maybe> - [proc (d;get proc-name procedures)] - (wrap (proc analyse proc-args))))) + (-> &;Analyser Text (List Code) (Lux la;Analysis)) + (<| (maybe;default (&;fail (format "Unknown procedure: " (%t proc-name)))) + (do maybe;Monad<Maybe> + [proc (dict;get proc-name procedures)] + (wrap (proc analyse proc-args))))) diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux index ffb87a2ca..a0f739f3b 100644 --- a/new-luxc/source/luxc/analyser/procedure/common.lux +++ b/new-luxc/source/luxc/analyser/procedure/common.lux @@ -6,32 +6,32 @@ text/format (coll [list "list/" Functor<List>] [array #+ Array] - ["d" dict])) + [dict #+ Dict])) [macro #+ Monad<Lux>] - (type ["TC" check]) + (type ["tc" check]) [io]) (luxc ["&" base] - (lang ["la" analysis #+ Analysis]) + (lang ["la" analysis]) (analyser ["&;" common]))) ## [Utils] (type: #export Proc - (-> &;Analyser (List Code) (Lux Analysis))) + (-> &;Analyser (List Code) (Lux la;Analysis))) (type: #export Bundle - (d;Dict Text Proc)) + (Dict Text Proc)) (def: #export (install name unnamed) (-> Text (-> Text Proc) (-> Bundle Bundle)) - (d;put name (unnamed name))) + (dict;put name (unnamed name))) (def: #export (prefix prefix bundle) (-> Text Bundle Bundle) (|> bundle - d;entries + dict;entries (list/map (function [[key val]] [(format prefix " " key) val])) - (d;from-list text;Hash<Text>))) + (dict;from-list text;Hash<Text>))) (def: #export (wrong-arity proc expected actual) (-> Text Nat Nat Text) @@ -52,8 +52,8 @@ (analyse argC))) (list;zip2 input-types args)) expected macro;expected-type - _ (&;within-type-env - (TC;check expected output-type))] + _ (&;with-type-env + (tc;check expected output-type))] (wrap (#la;Procedure proc argsA))) (&;fail (wrong-arity proc num-expected num-actual))))))) @@ -95,11 +95,11 @@ (do Monad<Lux> [opA (&;with-expected-type (type (io;IO varT)) (analyse opC)) - outputT (&;within-type-env - (TC;clean var-id (type (Either Text varT)))) + outputT (&;with-type-env + (tc;clean var-id (type (Either Text varT)))) expected macro;expected-type - _ (&;within-type-env - (TC;check expected outputT))] + _ (&;with-type-env + (tc;check expected outputT))] (wrap (#la;Procedure proc (list opA)))) _ @@ -107,14 +107,14 @@ (def: lux-procs Bundle - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "is" lux-is) (install "try" lux-try))) (def: io-procs Bundle (<| (prefix "io") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "log" (unary Text Unit)) (install "error" (unary Text Bottom)) (install "exit" (unary Nat Bottom)) @@ -123,7 +123,7 @@ (def: bit-procs Bundle (<| (prefix "bit") - (|> (d;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)) @@ -136,7 +136,7 @@ (def: nat-procs Bundle (<| (prefix "nat") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "+" (binary Nat Nat Nat)) (install "-" (binary Nat Nat Nat)) (install "*" (binary Nat Nat Nat)) @@ -152,7 +152,7 @@ (def: int-procs Bundle (<| (prefix "int") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "+" (binary Int Int Int)) (install "-" (binary Int Int Int)) (install "*" (binary Int Int Int)) @@ -168,7 +168,7 @@ (def: deg-procs Bundle (<| (prefix "deg") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "+" (binary Deg Deg Deg)) (install "-" (binary Deg Deg Deg)) (install "*" (binary Deg Deg Deg)) @@ -185,7 +185,7 @@ (def: frac-procs Bundle (<| (prefix "frac") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "+" (binary Frac Frac Frac)) (install "-" (binary Frac Frac Frac)) (install "*" (binary Frac Frac Frac)) @@ -207,7 +207,7 @@ (def: text-procs Bundle (<| (prefix "text") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "=" (binary Text Text Bool)) (install "<" (binary Text Text Bool)) (install "prepend" (binary Text Text Text)) @@ -246,7 +246,7 @@ (def: array-procs Bundle (<| (prefix "array") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "new" (unary Nat Array)) (install "get" array-get) (install "put" array-put) @@ -257,7 +257,7 @@ (def: math-procs Bundle (<| (prefix "math") - (|> (d;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "cos" (unary Frac Frac)) (install "sin" (unary Frac Frac)) (install "tan" (unary Frac Frac)) @@ -288,11 +288,11 @@ (do Monad<Lux> [initA (&;with-expected-type varT (analyse initC)) - outputT (&;within-type-env - (TC;clean var-id (type (A;Atom varT)))) + outputT (&;with-type-env + (tc;clean var-id (type (A;Atom varT)))) expected macro;expected-type - _ (&;within-type-env - (TC;check expected outputT))] + _ (&;with-type-env + (tc;check expected outputT))] (wrap (#la;Procedure proc (list initA)))) _ @@ -317,7 +317,7 @@ (def: atom-procs Bundle (<| (prefix "atom") - (|> (d;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) @@ -326,7 +326,7 @@ (def: process-procs Bundle (<| (prefix "process") - (|> (d;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)) @@ -335,16 +335,16 @@ (def: #export procedures Bundle (<| (prefix "lux") - (|> (d;new text;Hash<Text>) - (d;merge lux-procs) - (d;merge bit-procs) - (d;merge nat-procs) - (d;merge int-procs) - (d;merge deg-procs) - (d;merge frac-procs) - (d;merge text-procs) - (d;merge array-procs) - (d;merge math-procs) - (d;merge atom-procs) - (d;merge process-procs) - (d;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/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index a8af2748a..1dba7a5f8 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -5,6 +5,7 @@ ["ex" exception #+ exception:]) (concurrency ["A" atom]) (data ["R" result] + [maybe] [product] [text "text/" Eq<Text>] (text format @@ -18,7 +19,7 @@ [host]) (luxc ["&" base] ["&;" host] - (lang ["la" analysis #+ Analysis]) + (lang ["la" analysis]) (analyser ["&;" common])) ["@" ../common] ) @@ -245,7 +246,7 @@ (case elemT (#;Host name #;Nil) (let [boxed-name (|> (dict;get name boxes) - (default name))] + (maybe;default name))] (wrap [(#;Host boxed-name #;Nil) boxed-name])) @@ -267,8 +268,8 @@ (do macro;Monad<Lux> [arrayA (&;with-expected-type (type (Array varT)) (analyse arrayC)) - elemT (&;within-type-env - (tc;read-var var-id)) + elemT (&;with-type-env + (tc;read var-id)) [elemT elem-class] (box-array-element-type elemT) idxA (&;with-expected-type Nat (analyse idxC)) @@ -288,8 +289,8 @@ (do macro;Monad<Lux> [arrayA (&;with-expected-type (type (Array varT)) (analyse arrayC)) - elemT (&;within-type-env - (tc;read-var var-id)) + elemT (&;with-type-env + (tc;read var-id)) [valueT elem-class] (box-array-element-type elemT) idxA (&;with-expected-type Nat (analyse idxC)) @@ -334,8 +335,8 @@ (do macro;Monad<Lux> [objectA (&;with-expected-type varT (analyse objectC)) - objectT (&;within-type-env - (tc;read-var var-id)) + objectT (&;with-type-env + (tc;read var-id)) _ (check-object objectT) _ (&;infer Bool)] (wrap (#la;Procedure proc (list objectA)))) @@ -353,8 +354,8 @@ (do macro;Monad<Lux> [monitorA (&;with-expected-type varT (analyse monitorC)) - monitorT (&;within-type-env - (tc;read-var var-id)) + monitorT (&;with-type-env + (tc;read var-id)) _ (check-object monitorT) exprA (analyse exprC)] (wrap (#la;Procedure proc (list monitorA exprA)))) @@ -432,8 +433,8 @@ (do macro;Monad<Lux> [exceptionA (&;with-expected-type varT (analyse exceptionC)) - exceptionT (&;within-type-env - (tc;read-var var-id)) + exceptionT (&;with-type-env + (tc;read var-id)) exception-class (check-object exceptionT) ? (sub-class? "java.lang.Throwable" exception-class) _ (: (Lux Unit) @@ -478,8 +479,8 @@ (do macro;Monad<Lux> [objectA (&;with-expected-type varT (analyse objectC)) - objectT (&;within-type-env - (tc;read-var var-id)) + objectT (&;with-type-env + (tc;read var-id)) object-class (check-object objectT) ? (sub-class? class object-class)] (if ? @@ -599,13 +600,13 @@ [to-name (check-jvm to) from-name (check-jvm from)] (cond (dict;contains? to-name boxes) - (let [box (assume (dict;get to-name boxes))] + (let [box (maybe;assume (dict;get to-name boxes))] (if (text/= box from-name) (wrap [box (#;Host to-name (list))]) (&;throw Cannot-Cast-To-Primitive (format from-name " => " to-name)))) (dict;contains? from-name boxes) - (let [box (assume (dict;get from-name boxes))] + (let [box (maybe;assume (dict;get from-name boxes))] (do @ [[_ castT] (cast to (#;Host box (list)))] (wrap [from-name castT]))) @@ -709,8 +710,8 @@ target-class)) sourceA (&;with-expected-type varT (analyse sourceC)) - sourceT (&;within-type-env - (tc;read-var var-id)) + sourceT (&;with-type-env + (tc;read var-id)) [unboxed castT] (cast targetT sourceT) _ (&;assert (format "Object cannot be a primitive: " unboxed) (text;empty? unboxed))] @@ -722,8 +723,8 @@ (do macro;Monad<Lux> [sourceA (&;with-expected-type varT (analyse sourceC)) - sourceT (&;within-type-env - (tc;read-var var-id)) + sourceT (&;with-type-env + (tc;read var-id)) [unboxed castT] (cast targetT sourceT)] (wrap [castT unboxed sourceA])))) @@ -738,8 +739,8 @@ [[fieldT final?] (static-field class field) expectedT macro;expected-type [unboxed castT] (cast expectedT fieldT) - _ (&;within-type-env - (tc;check expectedT castT))] + _ (&;with-type-env + (tc;check expectedT castT))] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed))))) _ @@ -760,8 +761,8 @@ _ (&;assert (Final-Field (format class "#" field)) (not final?)) [valueT unboxed valueA] (analyse-input analyse fieldT valueC) - _ (&;within-type-env - (tc;check fieldT valueT)) + _ (&;with-type-env + (tc;check fieldT valueT)) _ (&;infer Unit)] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA)))) @@ -783,8 +784,8 @@ [fieldT final?] (virtual-field class field objectT) expectedT macro;expected-type [unboxed castT] (cast expectedT fieldT) - _ (&;within-type-env - (tc;check expectedT castT))] + _ (&;with-type-env + (tc;check expectedT castT))] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) objectA)))) _ @@ -806,8 +807,8 @@ _ (&;assert (Final-Field (format class "#" field)) (not final?)) [valueT unboxed valueA] (analyse-input analyse fieldT valueC) - _ (&;within-type-env - (tc;check fieldT valueT)) + _ (&;with-type-env + (tc;check fieldT valueT)) _ (&;infer Unit)] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA objectA)))) diff --git a/new-luxc/source/luxc/analyser/reference.lux b/new-luxc/source/luxc/analyser/reference.lux index d664ac9d0..9b051bb79 100644 --- a/new-luxc/source/luxc/analyser/reference.lux +++ b/new-luxc/source/luxc/analyser/reference.lux @@ -13,8 +13,8 @@ (do Monad<Lux> [actual (macro;find-def-type def-name) expected macro;expected-type - _ (&;within-type-env - (TC;check expected actual))] + _ (&;with-type-env + (TC;check expected actual))] (wrap (#la;Definition def-name)))) (def: (analyse-variable var-name) @@ -25,8 +25,8 @@ (#;Some [actual ref]) (do @ [expected macro;expected-type - _ (&;within-type-env - (TC;check expected actual))] + _ (&;with-type-env + (TC;check expected actual))] (wrap (#;Some (#la;Variable ref)))) #;None diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux index 9a42db0fa..a6424b466 100644 --- a/new-luxc/source/luxc/analyser/structure.lux +++ b/new-luxc/source/luxc/analyser/structure.lux @@ -2,21 +2,20 @@ lux (lux (control [monad #+ do] pipe) - [io #- run] [function] (concurrency ["A" atom]) - (data [text "T/" Eq<Text>] - text/format - [ident] - (coll [list "L/" Fold<List> Monoid<List> Monad<List>] - ["D" dict] - ["S" set]) + (data [ident] [number] - [product]) - [macro #+ Monad<Lux>] + [product] + [maybe] + (coll [list "list/" Functor<List>] + [dict #+ Dict]) + [text] + text/format) + [macro] (macro [code]) [type] - (type ["TC" check])) + (type ["tc" check])) (luxc ["&" base] (lang ["la" analysis]) ["&;" module] @@ -37,7 +36,7 @@ (def: #export (analyse-sum analyse tag valueC) (-> &;Analyser Nat Code (Lux la;Analysis)) - (do Monad<Lux> + (do macro;Monad<Lux> [expected macro;expected-type] (&;with-stacked-errors (function [_] (not-variant expected)) @@ -62,12 +61,12 @@ (#;Var id) (do @ - [bound? (&;within-type-env - (TC;bound? id))] + [bound? (&;with-type-env + (tc;bound? id))] (if bound? (do @ - [expected' (&;within-type-env - (TC;read-var id))] + [expected' (&;with-type-env + (tc;read id))] (&;with-expected-type expected' (analyse-sum analyse tag valueC))) ## Cannot do inference when the tag is numeric. @@ -77,15 +76,15 @@ (#;UnivQ _) (do @ - [[var-id var] (&;within-type-env - TC;existential)] - (&;with-expected-type (assume (type;apply (list var) expected)) + [[var-id var] (&;with-type-env + tc;existential)] + (&;with-expected-type (maybe;assume (type;apply (list var) expected)) (analyse-sum analyse tag valueC))) (#;ExQ _) (&common;with-var (function [[var-id var]] - (&;with-expected-type (assume (type;apply (list var) expected)) + (&;with-expected-type (maybe;assume (type;apply (list var) expected)) (analyse-sum analyse tag valueC)))) (#;Apply inputT funT) @@ -102,7 +101,7 @@ (def: (analyse-typed-product analyse members) (-> &;Analyser (List Code) (Lux la;Analysis)) - (do Monad<Lux> + (do macro;Monad<Lux> [expected macro;expected-type] (loop [expected expected members members] @@ -150,7 +149,7 @@ (def: #export (analyse-product analyse membersC) (-> &;Analyser (List Code) (Lux la;Analysis)) - (do Monad<Lux> + (do macro;Monad<Lux> [expected macro;expected-type] (&;with-stacked-errors (function [_] (format "Invalid type for tuple: " (%type expected))) @@ -164,34 +163,34 @@ (#;Var id) (do @ - [bound? (&;within-type-env - (TC;bound? id))] + [bound? (&;with-type-env + (tc;bound? id))] (if bound? (do @ - [expected' (&;within-type-env - (TC;read-var id))] + [expected' (&;with-type-env + (tc;read id))] (&;with-expected-type expected' (analyse-product analyse membersC))) ## Must do inference... (do @ [membersTA (monad;map @ (|>. analyse &common;with-unknown-type) membersC) - _ (&;within-type-env - (TC;check expected - (type;tuple (L/map product;left membersTA))))] - (wrap (la;product (L/map product;right membersTA)))))) + _ (&;with-type-env + (tc;check expected + (type;tuple (list/map product;left membersTA))))] + (wrap (la;product (list/map product;right membersTA)))))) (#;UnivQ _) (do @ - [[var-id var] (&;within-type-env - TC;existential)] - (&;with-expected-type (assume (type;apply (list var) expected)) + [[var-id var] (&;with-type-env + tc;existential)] + (&;with-expected-type (maybe;assume (type;apply (list var) expected)) (analyse-product analyse membersC))) (#;ExQ _) (&common;with-var (function [[var-id var]] - (&;with-expected-type (assume (type;apply (list var) expected)) + (&;with-expected-type (maybe;assume (type;apply (list var) expected)) (analyse-product analyse membersC)))) (#;Apply inputT funT) @@ -209,17 +208,17 @@ (def: #export (analyse-tagged-sum analyse tag value) (-> &;Analyser Ident Code (Lux la;Analysis)) - (do Monad<Lux> + (do macro;Monad<Lux> [tag (macro;normalize tag) [idx group variantT] (macro;resolve-tag tag) #let [case-size (list;size group)] inferenceT (&inference;variant-inference-type idx case-size variantT) [inferredT valueA+] (&inference;apply-function analyse inferenceT (list value)) expectedT macro;expected-type - _ (&;within-type-env - (TC;check expectedT inferredT)) + _ (&;with-type-env + (tc;check expectedT inferredT)) temp &scope;next-local] - (wrap (la;sum idx case-size temp (|> valueA+ list;head assume))))) + (wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume))))) ## There cannot be any ambiguity or improper syntax when analysing ## records, so they must be normalized for further analysis. @@ -227,11 +226,11 @@ ## canonical form (with their corresponding module identified). (def: #export (normalize record) (-> (List [Code Code]) (Lux (List [Ident Code]))) - (monad;map Monad<Lux> + (monad;map macro;Monad<Lux> (function [[key val]] (case key [_ (#;Tag key)] - (do Monad<Lux> + (do macro;Monad<Lux> [key (macro;normalize key)] (wrap [key val])) @@ -247,10 +246,10 @@ (case record ## empty-record = empty-tuple = unit = [] #;Nil - (:: Monad<Lux> wrap [(list) Unit]) + (:: macro;Monad<Lux> wrap [(list) Unit]) (#;Cons [head-k head-v] _) - (do Monad<Lux> + (do macro;Monad<Lux> [head-k (macro;normalize head-k) [_ tag-set recordT] (macro;resolve-tag head-k) #let [size-record (list;size record) @@ -262,36 +261,36 @@ " Actual: " (|> size-record nat-to-int %i) "\n" "For type: " (%type recordT)))) #let [tuple-range (list;n.range +0 (n.dec size-ts)) - tag->idx (D;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))] + 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 (D;get key tag->idx) + (case (dict;get key tag->idx) #;None (&;fail (format "Tag " (%code (code;tag key)) " does not belong to tag-set for type " (%type recordT))) (#;Some idx) - (if (D;contains? idx idx->val) + (if (dict;contains? idx idx->val) (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key)))) - (wrap (D;put idx val idx->val)))))) - (: (D;Dict Nat Code) - (D;new number;Hash<Nat>)) + (wrap (dict;put idx val idx->val)))))) + (: (Dict Nat Code) + (dict;new number;Hash<Nat>)) record) - #let [ordered-tuple (L/map (function [idx] (assume (D;get idx idx->val))) - tuple-range)]] + #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]) (Lux la;Analysis)) - (do Monad<Lux> + (do macro;Monad<Lux> [members (normalize members) [members recordT] (order members) expectedT macro;expected-type inferenceT (&inference;record-inference-type recordT) [inferredT membersA] (&inference;apply-function analyse inferenceT members) - _ (&;within-type-env - (TC;check expectedT inferredT))] + _ (&;with-type-env + (tc;check expectedT inferredT))] (wrap (la;product membersA)))) diff --git a/new-luxc/source/luxc/analyser/type.lux b/new-luxc/source/luxc/analyser/type.lux index 1eb278d2a..b69790a59 100644 --- a/new-luxc/source/luxc/analyser/type.lux +++ b/new-luxc/source/luxc/analyser/type.lux @@ -15,8 +15,8 @@ [actual (eval Type type) #let [actual (:! Type actual)] expected macro;expected-type - _ (&;within-type-env - (TC;check expected actual))] + _ (&;with-type-env + (TC;check expected actual))] (&;with-expected-type actual (analyse value)))) @@ -25,7 +25,7 @@ (do Monad<Lux> [actual (eval Type type) expected macro;expected-type - _ (&;within-type-env - (TC;check expected (:! Type actual)))] + _ (&;with-type-env + (TC;check expected (:! Type actual)))] (&;with-expected-type Top (analyse value)))) |