diff options
| author | Eduardo Julian | 2017-10-11 18:57:44 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2017-10-11 18:57:44 -0400 |
| commit | 74a835634fc9ee5457f3cc7109af069dad9f2d2f (patch) | |
| tree | dec444467ecde32ac165627f782f315ac41567e8 | |
| parent | ccabfc6a5e41650788199cb8fd5d87731f094bcd (diff) | |
- Migrated new-luxc to latest version of stdlib.
- Some refactoring.
39 files changed, 576 insertions, 573 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux index f17ec8496..ba6003440 100644 --- a/new-luxc/source/luxc/analyser.lux +++ b/new-luxc/source/luxc/analyser.lux @@ -2,13 +2,10 @@ lux (lux (control monad) (data ["R" result] - [text "T/" Eq<Text>] - text/format - [number] - [product]) - [macro #+ Monad<Lux>] + text/format) + [macro] [type] - (type ["TC" check])) + (type ["tc" check])) (luxc ["&" base] (lang ["la" analysis]) ["&;" module]) @@ -25,10 +22,10 @@ (-> (List Code) (Lux (List [Code Code]))) (case raw (^ (list)) - (:: Monad<Lux> wrap (list)) + (:: macro;Monad<Lux> wrap (list)) (^ (list& patternH bodyH inputT)) - (do Monad<Lux> + (do macro;Monad<Lux> [outputT (to-branches inputT)] (wrap (list& [patternH bodyH] outputT))) @@ -88,7 +85,7 @@ (^ (#;Form (list& [_ (#;Symbol ["" "_lux_case"])] input branches))) - (do Monad<Lux> + (do macro;Monad<Lux> [paired (to-branches branches)] (&&case;analyse-case analyse input paired)) @@ -105,7 +102,7 @@ [#;Tag &&structure;analyse-tagged-sum]) (^ (#;Form (list& func args))) - (do Monad<Lux> + (do macro;Monad<Lux> [[funcT =func] (&&common;with-unknown-type (analyse func))] (case =func 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)))) diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux index c0108da7e..fe57cc1dd 100644 --- a/new-luxc/source/luxc/base.lux +++ b/new-luxc/source/luxc/base.lux @@ -57,7 +57,7 @@ (#R;Error error) (#R;Error error)))) -(def: #export (within-type-env action) +(def: #export (with-type-env action) (All [a] (-> (tc;Check a) (Lux a))) (function [compiler] (case (action (get@ #;type-context compiler)) @@ -72,8 +72,8 @@ (-> Type (Lux Unit)) (do macro;Monad<Lux> [expectedT macro;expected-type] - (within-type-env - (tc;check expectedT actualT)))) + (with-type-env + (tc;check expectedT actualT)))) (def: #export (pl-get key table) (All [a] (-> Text (List [Text a]) (Maybe a))) diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux index 1f04f5798..054d11098 100644 --- a/new-luxc/source/luxc/generator/common.jvm.lux +++ b/new-luxc/source/luxc/generator/common.jvm.lux @@ -21,7 +21,7 @@ (host;import java.lang.ClassLoader (loadClass [String] (Class Object))) -(type: #export Bytecode host;Byte-Array) +(type: #export Bytecode (host;type (Array byte))) (type: #export Class-Store (A;Atom (d;Dict Text Bytecode))) diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux index 96f7a4917..4f02dcffb 100644 --- a/new-luxc/source/luxc/generator/eval.jvm.lux +++ b/new-luxc/source/luxc/generator/eval.jvm.lux @@ -54,7 +54,7 @@ (visitEnd [] void) (visitField [int String String String Object] FieldVisitor) (visitMethod [int String String String (Array String)] MethodVisitor) - (toByteArray [] Byte-Array)) + (toByteArray [] (Array byte))) (def: eval-field Text "_value") (def: $Object $;Type ($t;class "java.lang.Object" (list))) diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux index 135daf47e..e3582e183 100644 --- a/new-luxc/source/luxc/generator/function.jvm.lux +++ b/new-luxc/source/luxc/generator/function.jvm.lux @@ -2,7 +2,7 @@ lux (lux (control [monad #+ do]) (data text/format - (coll [list "L/" Functor<List> Monoid<List>])) + (coll [list "list/" Functor<List> Monoid<List>])) [macro]) (luxc ["&" base] (lang ["la" analysis] @@ -68,7 +68,7 @@ (def: (inputsI start amount) (-> $;Register Nat $;Inst) (|> (list;n.range start (n.+ start (n.dec amount))) - (L/map $i;ALOAD) + (list/map $i;ALOAD) $i;fuse)) (def: (applysI start amount) @@ -96,26 +96,26 @@ (def: (with-captured env) (-> (List ls;Variable) $;Def) (|> (list;enumerate env) - (L/map (function [[env-idx env-source]] - ($d;field #$;Private $;finalF (captured env-idx) $Object))) + (list/map (function [[env-idx env-source]] + ($d;field #$;Private $;finalF (captured env-idx) $Object))) $d;fuse)) (def: (with-partial arity) (-> ls;Arity $;Def) (if (poly-arg? arity) (|> (list;n.range +0 (n.- +2 arity)) - (L/map (function [idx] - ($d;field #$;Private $;finalF (partial idx) $Object))) + (list/map (function [idx] + ($d;field #$;Private $;finalF (partial idx) $Object))) $d;fuse) id)) (def: (instance class arity env) (-> Text ls;Arity (List ls;Variable) $;Inst) (let [captureI (|> env - (L/map (function [source] - (if (function;captured? source) - ($i;GETFIELD class (captured (function;captured-idx source)) $Object) - ($i;ALOAD (int-to-nat source))))) + (list/map (function [source] + (if (function;captured? source) + ($i;GETFIELD class (captured (function;captured-idx source)) $Object) + ($i;ALOAD (int-to-nat source))))) $i;fuse) argsI (if (poly-arg? arity) (|> (nullsI (n.dec arity)) @@ -136,9 +136,9 @@ captureI (|> (case env-size +0 (list) _ (list;n.range +0 (n.dec env-size))) - (L/map (function [source] - (|>. ($i;ALOAD +0) - ($i;GETFIELD class (captured source) $Object)))) + (list/map (function [source] + (|>. ($i;ALOAD +0) + ($i;GETFIELD class (captured source) $Object)))) $i;fuse) argsI (|> (nullsI (n.dec arity)) (list ($i;int 0)) @@ -179,18 +179,18 @@ store-capturedI (|> (case env-size +0 (list) _ (list;n.range +0 (n.dec env-size))) - (L/map (function [register] - (|>. ($i;ALOAD +0) - ($i;ALOAD (n.inc register)) - ($i;PUTFIELD class (captured register) $Object)))) + (list/map (function [register] + (|>. ($i;ALOAD +0) + ($i;ALOAD (n.inc register)) + ($i;PUTFIELD class (captured register) $Object)))) $i;fuse) store-partialI (if (poly-arg? arity) (|> (list;n.range +0 (n.- +2 arity)) - (L/map (function [idx] - (let [register (offset-partial idx)] - (|>. ($i;ALOAD +0) - ($i;ALOAD (n.inc register)) - ($i;PUTFIELD class (partial idx) $Object))))) + (list/map (function [idx] + (let [register (offset-partial idx)] + (|>. ($i;ALOAD +0) + ($i;ALOAD (n.inc register)) + ($i;PUTFIELD class (partial idx) $Object))))) $i;fuse) id)] ($d;method #$;Public $;noneM "<init>" (init-method env arity) @@ -200,69 +200,62 @@ store-partialI $i;RETURN)))) -(def: (when test f) - (All [a] (-> Bool (-> a a) (-> a a))) - (function [value] - (if test - (f value) - value))) - (def: (with-apply class env function-arity @begin bodyI apply-arity) (-> Text (List ls;Variable) ls;Arity $;Label $;Inst ls;Arity $;Def) (let [num-partials (n.dec function-arity) @default ($;new-label []) - @labels (L/map $;new-label (list;repeat num-partials [])) + @labels (list/map $;new-label (list;repeat num-partials [])) arity-over-extent (|> (nat-to-int function-arity) (i.- (nat-to-int apply-arity))) - casesI (|> (L/append @labels (list @default)) + casesI (|> (list/compose @labels (list @default)) (list;zip2 (list;n.range +0 num-partials)) - (L/map (function [[stage @label]] - (let [load-partialsI (if (n.> +0 stage) - (|> (list;n.range +0 (n.dec stage)) - (L/map (|>. partial (load-fieldI class))) - $i;fuse) - id)] - (cond (i.= arity-over-extent (nat-to-int stage)) - (|>. ($i;label @label) - ($i;ALOAD +0) - (when (n.> +0 stage) - ($i;INVOKEVIRTUAL class "reset" (reset-method class) false)) - load-partialsI - (inputsI +1 apply-arity) - ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) - $i;ARETURN) + (list/map (function [[stage @label]] + (let [load-partialsI (if (n.> +0 stage) + (|> (list;n.range +0 (n.dec stage)) + (list/map (|>. partial (load-fieldI class))) + $i;fuse) + id)] + (cond (i.= arity-over-extent (nat-to-int stage)) + (|>. ($i;label @label) + ($i;ALOAD +0) + (when (n.> +0 stage) + ($i;INVOKEVIRTUAL class "reset" (reset-method class) false)) + load-partialsI + (inputsI +1 apply-arity) + ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) + $i;ARETURN) - (i.> arity-over-extent (nat-to-int stage)) - (let [args-to-completion (|> function-arity (n.- stage)) - args-left (|> apply-arity (n.- args-to-completion))] - (|>. ($i;label @label) - ($i;ALOAD +0) - ($i;INVOKEVIRTUAL class "reset" (reset-method class) false) - load-partialsI - (inputsI +1 args-to-completion) - ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) - (applysI (n.inc args-to-completion) args-left) - $i;ARETURN)) + (i.> arity-over-extent (nat-to-int stage)) + (let [args-to-completion (|> function-arity (n.- stage)) + args-left (|> apply-arity (n.- args-to-completion))] + (|>. ($i;label @label) + ($i;ALOAD +0) + ($i;INVOKEVIRTUAL class "reset" (reset-method class) false) + load-partialsI + (inputsI +1 args-to-completion) + ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) + (applysI (n.inc args-to-completion) args-left) + $i;ARETURN)) - ## (i.< arity-over-extent (nat-to-int stage)) - (let [env-size (list;size env) - load-capturedI (|> (case env-size - +0 (list) - _ (list;n.range +0 (n.dec env-size))) - (L/map (|>. captured (load-fieldI class))) - $i;fuse)] - (|>. ($i;label @label) - ($i;NEW class) - $i;DUP - load-capturedI - get-amount-of-partialsI - (inc-intI apply-arity) - load-partialsI - (inputsI +1 apply-arity) - (nullsI (|> num-partials (n.- apply-arity) (n.- stage))) - ($i;INVOKESPECIAL class "<init>" (init-method env function-arity) false) - $i;ARETURN)) - )))) + ## (i.< arity-over-extent (nat-to-int stage)) + (let [env-size (list;size env) + load-capturedI (|> (case env-size + +0 (list) + _ (list;n.range +0 (n.dec env-size))) + (list/map (|>. captured (load-fieldI class))) + $i;fuse)] + (|>. ($i;label @label) + ($i;NEW class) + $i;DUP + load-capturedI + get-amount-of-partialsI + (inc-intI apply-arity) + load-partialsI + (inputsI +1 apply-arity) + (nullsI (|> num-partials (n.- apply-arity) (n.- stage))) + ($i;INVOKESPECIAL class "<init>" (init-method env function-arity) false) + $i;ARETURN)) + )))) $i;fuse)] ($d;method #$;Public $;noneM &runtime;apply-method (&runtime;apply-signature apply-arity) (|>. get-amount-of-partialsI @@ -286,7 +279,7 @@ (if (poly-arg? arity) (|> (n.min arity &runtime;num-apply-variants) (list;n.range +1) - (L/map (with-apply class env arity @begin bodyI)) + (list/map (with-apply class env arity @begin bodyI)) (list& (with-implementation arity @begin bodyI)) $d;fuse) ($d;method #$;Public $;strictM &runtime;apply-method (&runtime;apply-signature +1) @@ -332,10 +325,10 @@ [functionI (generate functionS) argsI (monad;map @ generate argsS) #let [applyI (|> (segment &runtime;num-apply-variants argsI) - (L/map (function [chunkI+] - (|>. ($i;CHECKCAST &runtime;function-class) - ($i;fuse chunkI+) - ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false)))) + (list/map (function [chunkI+] + (|>. ($i;CHECKCAST &runtime;function-class) + ($i;fuse chunkI+) + ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false)))) $i;fuse)]] (wrap (|>. functionI applyI)))) diff --git a/new-luxc/source/luxc/generator/host/jvm.lux b/new-luxc/source/luxc/generator/host/jvm.lux index 149fbf123..4fb3fa77d 100644 --- a/new-luxc/source/luxc/generator/host/jvm.lux +++ b/new-luxc/source/luxc/generator/host/jvm.lux @@ -2,7 +2,7 @@ [lux #- Type Def] (lux (control monad ["p" parser]) - (data (coll [list "L/" Functor<List>])) + (data (coll [list "list/" Functor<List>])) [macro] (macro [code] ["s" syntax #+ syntax:]) @@ -86,32 +86,32 @@ [options (s;tuple (p;many s;local-symbol))]) (let [g!type (code;local-symbol type) g!none (code;local-symbol none) - g!tags+ (L/map code;local-tag options) + g!tags+ (list/map code;local-tag options) g!_left (code;local-symbol "_left") g!_right (code;local-symbol "_right") - g!options+ (L/map (function [option] - (` (def: (~' #export) (~ (code;local-symbol option)) - (~ g!type) - (|> (~ g!none) - (set@ (~ (code;local-tag option)) true))))) - options)] + g!options+ (list/map (function [option] + (` (def: (~' #export) (~ (code;local-symbol option)) + (~ g!type) + (|> (~ g!none) + (set@ (~ (code;local-tag option)) true))))) + options)] (wrap (list& (` (type: (~' #export) (~ g!type) - (~ (code;record (L/map (function [tag] - [tag (` ;Bool)]) - g!tags+))))) + (~ (code;record (list/map (function [tag] + [tag (` ;Bool)]) + g!tags+))))) (` (def: (~' #export) (~ g!none) (~ g!type) - (~ (code;record (L/map (function [tag] - [tag (` false)]) - g!tags+))))) + (~ (code;record (list/map (function [tag] + [tag (` false)]) + g!tags+))))) (` (def: (~' #export) ((~ (code;local-symbol ++)) (~ g!_left) (~ g!_right)) (-> (~ g!type) (~ g!type) (~ g!type)) - (~ (code;record (L/map (function [tag] - [tag (` (and (get@ (~ tag) (~ g!_left)) - (get@ (~ tag) (~ g!_right))))]) - g!tags+))))) + (~ (code;record (list/map (function [tag] + [tag (` (and (get@ (~ tag) (~ g!_left)) + (get@ (~ tag) (~ g!_right))))]) + g!tags+))))) g!options+)))) diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux index 18cd4f945..7dd78ceb3 100644 --- a/new-luxc/source/luxc/generator/host/jvm/def.lux +++ b/new-luxc/source/luxc/generator/host/jvm/def.lux @@ -4,7 +4,7 @@ text/format [product] (coll ["a" array] - [list "L/" Functor<List>])) + [list "list/" Functor<List>])) [host #+ do-to]) ["$" ..] (.. ["$t" type])) @@ -56,13 +56,13 @@ (visitEnd [] void) (visitField [int String String String Object] FieldVisitor) (visitMethod [int String String String (Array String)] MethodVisitor) - (toByteArray [] Byte-Array)) + (toByteArray [] (Array byte))) ## [Defs] (def: (string-array values) (-> (List Text) (a;Array Text)) (let [output (host;array String (list;size values))] - (exec (L/map (function [[idx value]] + (exec (list/map (function [[idx value]] (host;array-write idx value output)) (list;enumerate values)) output))) @@ -70,7 +70,7 @@ (def: exceptions-array (-> $;Method (a;Array Text)) (|>. (get@ #$;exceptions) - (L/map (|>. #$;Generic $t;descriptor)) + (list/map (|>. #$;Generic $t;descriptor)) string-array)) (def: (version-flag version) @@ -127,7 +127,7 @@ (format name (param-signature super) (|> interfaces - (L/map param-signature) + (list/map param-signature) (text;join-with "")))) (def: (parameters-signature parameters super interfaces) @@ -137,13 +137,13 @@ "" (format "<" (|> parameters - (L/map formal-param) + (list/map formal-param) (text;join-with "")) ">"))] (format formal-params (|> super class-to-type $t;signature) (|> interfaces - (L/map (|>. class-to-type $t;signature)) + (list/map (|>. class-to-type $t;signature)) (text;join-with ""))))) (def: class-computes @@ -156,7 +156,7 @@ [(def: #export (<name> version visibility config name parameters super interfaces definitions) (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) $;Class (List $;Class) $;Def - host;Byte-Array) + (host;type (Array byte))) (let [writer (|> (do-to (ClassWriter.new class-computes) (ClassWriter.visit [(version-flag version) ($_ i.+ @@ -168,7 +168,7 @@ (parameters-signature parameters super interfaces) (|> super product;left $t;binary-name) (|> interfaces - (L/map (|>. product;left $t;binary-name)) + (list/map (|>. product;left $t;binary-name)) string-array)])) definitions) _ (ClassWriter.visitEnd [] writer)] @@ -183,7 +183,7 @@ (def: #export (interface version visibility config name parameters interfaces definitions) (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) (List $;Class) $;Def - host;Byte-Array) + (host;type (Array byte))) (let [writer (|> (do-to (ClassWriter.new class-computes) (ClassWriter.visit [(version-flag version) ($_ i.+ @@ -195,7 +195,7 @@ (parameters-signature parameters $Object interfaces) (|> $Object product;left $t;binary-name) (|> interfaces - (L/map (|>. product;left $t;binary-name)) + (list/map (|>. product;left $t;binary-name)) string-array)])) definitions) _ (ClassWriter.visitEnd [] writer)] diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux index 02027294a..aa9a852dd 100644 --- a/new-luxc/source/luxc/generator/host/jvm/inst.lux +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -2,8 +2,9 @@ [lux #- char] (lux (control monad ["p" parser]) - (data text/format + (data [maybe] ["R" result] + text/format (coll [list "L/" Functor<List>])) [host #+ do-to] [macro] @@ -262,7 +263,7 @@ _ (loop [idx +0] (if (n.< num-labels idx) (exec (host;array-write idx - (assume (list;nth idx labels)) + (maybe;assume (list;nth idx labels)) labels-array) (recur (n.inc idx))) []))] diff --git a/new-luxc/source/luxc/generator/procedure.jvm.lux b/new-luxc/source/luxc/generator/procedure.jvm.lux index 77828c952..524513eb5 100644 --- a/new-luxc/source/luxc/generator/procedure.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure.jvm.lux @@ -2,8 +2,8 @@ (;module: lux (lux (control [monad #+ do]) - (data text/format - [maybe] + (data [maybe] + text/format (coll ["d" dict]))) (luxc ["&" base] (lang ["ls" synthesis]) @@ -13,7 +13,7 @@ (def: #export (generate-procedure generate name args) (-> (-> ls;Synthesis (Lux $;Inst)) Text (List ls;Synthesis) (Lux $;Inst)) - (default (&;fail (format "Unknown procedure: " (%t name))) - (do maybe;Monad<Maybe> - [proc (d;get name &&common;procedures)] - (wrap (proc generate args))))) + (<| (maybe;default (&;fail (format "Unknown procedure: " (%t name)))) + (do maybe;Monad<Maybe> + [proc (d;get name &&common;procedures)] + (wrap (proc generate args))))) diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux index 9f8afdbb2..ffbe69708 100644 --- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux @@ -3,9 +3,9 @@ (lux (control [monad #+ do]) (data [text] text/format - (coll [list "L/" Functor<List> Monoid<List>] - ["D" dict])) - [macro #+ Monad<Lux> with-gensyms] + (coll [list "list/" Functor<List>] + [dict #+ Dict])) + [macro #+ with-gensyms] (macro [code] ["s" syntax #+ syntax:]) [host]) @@ -41,7 +41,7 @@ (-> Generator (List ls;Synthesis) (Lux $;Inst))) (type: Bundle - (D;Dict Text Proc)) + (Dict Text Proc)) (syntax: (Vector [size s;nat] elemT) (wrap (list (` [(~@ (list;repeat size elemT))])))) @@ -61,7 +61,7 @@ (def: (install name unnamed) (-> Text (-> Text Proc) (-> Bundle Bundle)) - (D;put name (unnamed name))) + (dict;put name (unnamed name))) (def: (wrong-amount-error proc expected actual) (-> Text Nat Nat Text) @@ -82,8 +82,8 @@ (^ (list (~@ g!input+))) (do macro;Monad<Lux> [(~@ (|> g!input+ - (L/map (function [g!input] - (list g!input (` ((~ g!generate) (~ g!input)))))) + (list/map (function [g!input] + (list g!input (` ((~ g!generate) (~ g!input)))))) list;concat))] ((~' wrap) ((~ g!proc) [(~@ g!input+)]))) @@ -527,13 +527,13 @@ ## [Bundles] (def: lux-procs Bundle - (|> (D;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "lux is" (binary lux//is)) (install "lux try" (unary lux//try)))) (def: bit-procs Bundle - (|> (D;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "bit count" (unary bit//count)) (install "bit and" (binary bit//and)) (install "bit or" (binary bit//or)) @@ -545,7 +545,7 @@ (def: nat-procs Bundle - (|> (D;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "nat +" (binary nat//add)) (install "nat -" (binary nat//sub)) (install "nat *" (binary nat//mul)) @@ -560,7 +560,7 @@ (def: int-procs Bundle - (|> (D;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "int +" (binary int//add)) (install "int -" (binary int//sub)) (install "int *" (binary int//mul)) @@ -575,7 +575,7 @@ (def: deg-procs Bundle - (|> (D;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "deg +" (binary deg//add)) (install "deg -" (binary deg//sub)) (install "deg *" (binary deg//mul)) @@ -591,7 +591,7 @@ (def: frac-procs Bundle - (|> (D;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "frac +" (binary frac//add)) (install "frac -" (binary frac//sub)) (install "frac *" (binary frac//mul)) @@ -612,7 +612,7 @@ (def: text-procs Bundle - (|> (D;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "text =" (binary text//eq)) (install "text <" (binary text//lt)) (install "text append" (binary text//append)) @@ -626,7 +626,7 @@ (def: array-procs Bundle - (|> (D;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "array new" (unary array//new)) (install "array get" (binary array//get)) (install "array put" (trinary array//put)) @@ -636,7 +636,7 @@ (def: math-procs Bundle - (|> (D;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "math cos" (unary math//cos)) (install "math sin" (unary math//sin)) (install "math tan" (unary math//tan)) @@ -659,7 +659,7 @@ (def: io-procs Bundle - (|> (D;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "io log" (unary io//log)) (install "io error" (unary io//error)) (install "io exit" (unary io//exit)) @@ -667,14 +667,14 @@ (def: atom-procs Bundle - (|> (D;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "atom new" (unary atom//new)) (install "atom read" (unary atom//read)) (install "atom compare-and-swap" (trinary atom//compare-and-swap)))) (def: process-procs Bundle - (|> (D;new text;Hash<Text>) + (|> (dict;new text;Hash<Text>) (install "process concurrency-level" (nullary process//concurrency-level)) (install "process future" (unary process//future)) (install "process schedule" (binary process//schedule)) @@ -682,17 +682,17 @@ (def: #export procedures Bundle - (|> (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 io-procs) - (D;merge atom-procs) - (D;merge process-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 io-procs) + (dict;merge atom-procs) + (dict;merge process-procs) )) diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux index 69f90cea0..c073e7da0 100644 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -39,7 +39,7 @@ (new [int]) (visit [int int String String String (Array String)] void) (visitEnd [] void) - (toByteArray [] Byte-Array)) + (toByteArray [] (Array byte))) (def: #export runtime-class Text "LuxRuntime") (def: #export function-class Text "LuxFunction") diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux index 66c53e479..240b60f97 100644 --- a/new-luxc/source/luxc/module.lux +++ b/new-luxc/source/luxc/module.lux @@ -11,14 +11,14 @@ (def: (new-module hash) (-> Nat Module) - {#;module-hash hash - #;module-aliases (list) - #;defs (list) - #;imports (list) - #;tags (list) - #;types (list) - #;module-anns (list) - #;module-state #;Active}) + {#;module-hash hash + #;module-aliases (list) + #;defs (list) + #;imports (list) + #;tags (list) + #;types (list) + #;module-annotations (' {}) + #;module-state #;Active}) (def: #export (define (^@ full-name [module-name def-name]) definition) diff --git a/new-luxc/source/luxc/parser.lux b/new-luxc/source/luxc/parser.lux index 2e8ad1fd5..7eb4dcb16 100644 --- a/new-luxc/source/luxc/parser.lux +++ b/new-luxc/source/luxc/parser.lux @@ -32,9 +32,10 @@ [text] ["R" result] [number] + [product] + [maybe] (text ["l" lexer] format) - [product] (coll [list "L/" Functor<List> Fold<List>] ["V" vector])))) @@ -252,7 +253,7 @@ (update@ #;column (n.+ chars-consumed))) char])))) _ (l;this "\"") - #let [char (assume (text;nth +0 char))]] + #let [char (maybe;assume (text;nth +0 char))]] (wrap [(|> where' (update@ #;column n.inc)) [where (#;Nat char)]]))) @@ -372,7 +373,7 @@ ## text's body. (recur (|> offset (text;split offset-column) - (default (undefined)) + (maybe;default (undefined)) product;right (format text-read)) (|> where diff --git a/new-luxc/source/luxc/scope.lux b/new-luxc/source/luxc/scope.lux index e15e01130..1dc5b932d 100644 --- a/new-luxc/source/luxc/scope.lux +++ b/new-luxc/source/luxc/scope.lux @@ -1,12 +1,12 @@ (;module: lux (lux (control monad) - (data [text "T/" Eq<Text>] + (data [text] text/format - [maybe #+ Monad<Maybe> "Maybe/" Monad<Maybe>] + [maybe "maybe/" Monad<Maybe>] [product] ["R" result] - (coll [list "L/" Fold<List> Monoid<List>])) + (coll [list "list/" Fold<List> Monoid<List>])) [macro]) (luxc ["&" base])) @@ -25,7 +25,7 @@ (|> scope (get@ [<slot> #;mappings]) (&;pl-get name) - (Maybe/map (function [[type value]] + (maybe/map (function [[type value]] [type (<then> value)]))))] [#;locals is-local? get-local #;Local] @@ -57,20 +57,20 @@ (#;Right [compiler #;None]) (#;Cons top-outer _) - (let [[ref-type init-ref] (default (undefined) - (get-ref name top-outer)) - [ref inner'] (L/fold (: (-> Scope [Ref (List Scope)] [Ref (List Scope)]) - (function [scope [ref inner]] - [(#;Captured (get@ [#;captured #;counter] scope)) - (#;Cons (update@ #;captured - (: (-> Captured Captured) - (|>. (update@ #;counter n.inc) - (update@ #;mappings (&;pl-put name [ref-type ref])))) - scope) - inner)])) - [init-ref #;Nil] - (list;reverse inner)) - scopes (L/append inner' outer)] + (let [[ref-type init-ref] (maybe;default (undefined) + (get-ref name top-outer)) + [ref inner'] (list/fold (: (-> Scope [Ref (List Scope)] [Ref (List Scope)]) + (function [scope [ref inner]] + [(#;Captured (get@ [#;captured #;counter] scope)) + (#;Cons (update@ #;captured + (: (-> Captured Captured) + (|>. (update@ #;counter n.inc) + (update@ #;mappings (&;pl-put name [ref-type ref])))) + scope) + inner)])) + [init-ref #;Nil] + (list;reverse inner)) + scopes (list/compose inner' outer)] (#;Right [(set@ #;scopes scopes compiler) (#;Some [ref-type ref])])) )))) @@ -141,7 +141,7 @@ (#R;Success [compiler' output]) (#R;Success [(update@ #;scopes - (|>. list;tail (default (list))) + (|>. list;tail (maybe;default (list))) compiler') output]) )) diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux index 7bee8fe58..651da82a7 100644 --- a/new-luxc/source/luxc/synthesizer.lux +++ b/new-luxc/source/luxc/synthesizer.lux @@ -1,10 +1,11 @@ (;module: lux - (lux (data text/format + (lux (data [maybe] [number] [product] - (coll [list "L/" Functor<List> Fold<List> Monoid<List>] - ["d" dict]))) + text/format + (coll [list "list/" Functor<List> Fold<List> Monoid<List>] + [dict #+ Dict]))) (luxc ["&" base] (lang ["la" analysis] ["ls" synthesis]) @@ -15,7 +16,7 @@ )) (def: init-env (List ls;Variable) (list)) -(def: init-resolver (d;Dict Int Int) (d;new number;Hash<Int>)) +(def: init-resolver (Dict Int Int) (dict;new number;Hash<Int>)) (def: (prepare-body inner-arity arity body) (-> Nat Nat ls;Synthesis ls;Synthesis) @@ -43,7 +44,7 @@ [#la;Definition #ls;Definition]) (#la;Product _) - (#ls;Tuple (L/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA))) + (#ls;Tuple (list/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA))) (#la;Sum choice) (let [[tag last? value] (&&structure;unfold-variant choice)] @@ -55,14 +56,14 @@ (if (&&function;nested? outer-arity) (if (n.= +0 register) (#ls;Call (|> (list;n.range +1 (n.dec outer-arity)) - (L/map (|>. &&function;to-local #ls;Variable))) + (list/map (|>. &&function;to-local #ls;Variable))) (#ls;Variable 0)) (#ls;Variable (&&function;adjust-var outer-arity (&&function;to-local register)))) (#ls;Variable (&&function;to-local register))) (#;Captured register) (#ls;Variable (let [var (&&function;to-captured register)] - (default var (d;get var resolver))))) + (maybe;default var (dict;get var resolver))))) (#la;Case inputA branchesA) (let [inputS (recur +0 resolver num-locals inputA)] @@ -88,9 +89,9 @@ #ls;ExecP (#ls;SeqP (&&case;path pattern)))))] (#ls;Case inputS - (L/fold &&case;weave - (transform-branch lastP lastA) - (L/map (product;uncurry transform-branch) prevsPA)))) + (list/fold &&case;weave + (transform-branch lastP lastA) + (list/map (product;uncurry transform-branch) prevsPA)))) _ (undefined) @@ -99,21 +100,21 @@ (#la;Function scope bodyA) (let [inner-arity (n.inc outer-arity) raw-env (&&function;environment scope) - env (L/map (function [var] (default var (d;get var resolver))) raw-env) + env (list/map (function [var] (maybe;default var (dict;get var resolver))) raw-env) env-vars (let [env-size (list;size raw-env)] (: (List ls;Variable) (case env-size +0 (list) - _ (L/map &&function;to-captured (list;n.range +0 (n.dec env-size)))))) + _ (list/map &&function;to-captured (list;n.range +0 (n.dec env-size)))))) resolver' (if (&&function;nested? inner-arity) - (L/fold (function [[from to] resolver'] - (d;put from to resolver')) - init-resolver - (list;zip2 env-vars env)) - (L/fold (function [var resolver'] - (d;put var var resolver')) - init-resolver - env-vars))] + (list/fold (function [[from to] resolver'] + (dict;put from to resolver')) + init-resolver + (list;zip2 env-vars env)) + (list/fold (function [var resolver'] + (dict;put var var resolver')) + init-resolver + env-vars))] (case (recur inner-arity resolver' +0 bodyA) (#ls;Function arity' env' bodyS') (let [arity (n.inc arity')] @@ -125,7 +126,7 @@ (#la;Apply _) (let [[funcA argsA] (&&function;unfold-apply exprA) funcS (recur +0 resolver num-locals funcA) - argsS (L/map (recur +0 resolver num-locals) argsA)] + argsS (list/map (recur +0 resolver num-locals) argsA)] (case funcS (^multi (#ls;Function _arity _env _bodyS) (and (n.= _arity (list;size argsS)) @@ -137,11 +138,11 @@ (&&loop;adjust _env register-offset _bodyS))) (#ls;Call argsS' funcS') - (#ls;Call (L/append argsS' argsS) funcS') + (#ls;Call (list/compose argsS' argsS) funcS') _ (#ls;Call argsS funcS))) (#la;Procedure name args) - (#ls;Procedure name (L/map (recur +0 resolver num-locals) args)) + (#ls;Procedure name (list/map (recur +0 resolver num-locals) args)) ))) diff --git a/new-luxc/source/luxc/synthesizer/loop.lux b/new-luxc/source/luxc/synthesizer/loop.lux index 9f4d09a49..ad4504f41 100644 --- a/new-luxc/source/luxc/synthesizer/loop.lux +++ b/new-luxc/source/luxc/synthesizer/loop.lux @@ -1,7 +1,8 @@ (;module: lux - (lux (data (coll [list "L/" Functor<List>]) - text/format)) + (lux (data [maybe] + text/format + (coll [list "L/" Functor<List>]))) (luxc (lang ["ls" synthesis]) (synthesizer ["&&;" function]))) @@ -105,7 +106,7 @@ (let [resolve-captured (: (-> ls;Variable ls;Variable) (function [var] (let [idx (|> var (i.* -1) int-to-nat n.dec)] - (|> env (list;nth idx) assume))))] + (|> env (list;nth idx) maybe;assume))))] (loop [exprS exprS] (case exprS (#ls;Variant tag last? valueS) diff --git a/new-luxc/source/luxc/synthesizer/variable.lux b/new-luxc/source/luxc/synthesizer/variable.lux index 3a48cb3f2..01ad101fa 100644 --- a/new-luxc/source/luxc/synthesizer/variable.lux +++ b/new-luxc/source/luxc/synthesizer/variable.lux @@ -16,7 +16,7 @@ (list (nat-to-int register)) (^or (#ls;SeqP pre post) (#ls;AltP pre post)) - (L/append (bound-vars pre) (bound-vars post)) + (L/compose (bound-vars pre) (bound-vars post)) _ (list))) @@ -31,7 +31,7 @@ (path-bodies post) (#ls;AltP pre post) - (L/append (path-bodies pre) (path-bodies post)) + (L/compose (path-bodies pre) (path-bodies post)) _ (list))) diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux index 983dff6f5..f75ebce00 100644 --- a/new-luxc/test/test/luxc/analyser/case.lux +++ b/new-luxc/test/test/luxc/analyser/case.lux @@ -6,6 +6,7 @@ (data [bool "B/" Eq<Bool>] ["R" result] [product] + [maybe] [text "T/" Eq<Text>] text/format (coll [list "L/" Monad<List>] @@ -111,8 +112,8 @@ (r/map product;right gen-primitive) (do r;Monad<Random> [choice (|> r;nat (:: @ map (n.% (list;size variant-tags)))) - #let [choiceT (assume (list;nth choice variant-tags)) - choiceC (assume (list;nth choice primitivesC))]] + #let [choiceT (maybe;assume (list;nth choice variant-tags)) + choiceC (maybe;assume (list;nth choice primitivesC))]] (wrap (` ((~ choiceT) (~ choiceC))))) (do r;Monad<Random> [size (|> r;nat (:: @ map (n.% +3))) @@ -156,10 +157,10 @@ redundant-branchesC (<| (L/map (branch outputC)) list;concat (list (list;take redundancy-idx redundant-patterns) - (list (assume (list;nth redundancy-idx redundant-patterns))) + (list (maybe;assume (list;nth redundancy-idx redundant-patterns))) (list;drop redundancy-idx redundant-patterns))) heterogeneous-branchesC (list;concat (list (list;take heterogeneous-idx exhaustive-branchesC) - (list (let [[_pattern _body] (assume (list;nth heterogeneous-idx exhaustive-branchesC))] + (list (let [[_pattern _body] (maybe;assume (list;nth heterogeneous-idx exhaustive-branchesC))] [_pattern heterogeneousC])) (list;drop (n.inc heterogeneous-idx) exhaustive-branchesC))) ]] diff --git a/new-luxc/test/test/luxc/analyser/function.lux b/new-luxc/test/test/luxc/analyser/function.lux index 827e9a245..f26025034 100644 --- a/new-luxc/test/test/luxc/analyser/function.lux +++ b/new-luxc/test/test/luxc/analyser/function.lux @@ -4,15 +4,14 @@ (control [monad #+ do] pipe) (data ["R" result] + [maybe] [product] - [text "T/" Eq<Text>] + [text "text/" Eq<Text>] text/format - (coll [list "L/" Functor<List>] - ["S" set])) + (coll [list "list/" Functor<List>])) ["r" math/random "r/" Monad<Random>] - [type "Type/" Eq<Type>] - (type ["TC" check]) - [macro #+ Monad<Lux>] + [type "type/" Eq<Type>] + [macro] (macro [code]) test) (luxc ["&" base] @@ -28,7 +27,7 @@ (-> Type (R;Result [Type la;Analysis]) Bool) (case result (#R;Success [exprT exprA]) - (Type/= expectedT exprT) + (type/= expectedT exprT) _ false)) @@ -58,7 +57,7 @@ (macro;run (init-compiler [])) (case> (#R;Success [applyT applyA]) (let [[funcA argsA] (flatten-apply applyA)] - (and (Type/= expectedT applyT) + (and (type/= expectedT applyT) (n.= num-args (list;size argsA)))) (#R;Error error) @@ -66,7 +65,7 @@ (context: "Function definition." [func-name (r;text +5) - arg-name (|> (r;text +5) (r;filter (|>. (T/= func-name) not))) + arg-name (|> (r;text +5) (r;filter (|>. (text/= func-name) not))) [outputT outputC] gen-primitive [inputT _] gen-primitive] ($_ seq @@ -111,8 +110,8 @@ partial-args (|> r;nat (:: @ map (n.% full-args))) var-idx (|> r;nat (:: @ map (|>. (n.% full-args) (n.max +1)))) inputsTC (r;list full-args gen-primitive) - #let [inputsT (L/map product;left inputsTC) - inputsC (L/map product;right inputsTC)] + #let [inputsT (list/map product;left inputsTC) + inputsC (list/map product;right inputsTC)] [outputT outputC] gen-primitive #let [funcT (type;function inputsT outputT) partialT (type;function (list;drop partial-args inputsT) outputT) @@ -122,7 +121,7 @@ (list varT) (list;drop (n.inc var-idx) inputsT)))) varT) - poly-inputT (assume (list;nth var-idx inputsT)) + poly-inputT (maybe;assume (list;nth var-idx inputsT)) partial-poly-inputsT (list;drop (n.inc var-idx) inputsT) partial-polyT1 (<| (type;function partial-poly-inputsT) poly-inputT) diff --git a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux index 87c315750..c45143d5b 100644 --- a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux @@ -4,10 +4,11 @@ (control [monad #+ do] pipe) (concurrency [atom]) - (data text/format - [text "text/" Eq<Text>] - ["R" result] + (data ["R" result] [product] + [maybe] + [text "text/" Eq<Text>] + text/format (coll [array] [list "list/" Fold<List>] [dict])) @@ -247,7 +248,7 @@ #let [[unboxed boxed] (: [Text Text] (|> entries (list;nth choice) - (default ["java.lang.Object" "java.lang.Object"])))]] + (maybe;default ["java.lang.Object" "java.lang.Object"])))]] (wrap [unboxed boxed])))) (context: "Array." @@ -320,7 +321,7 @@ (:: @ map (function [idx] (|> throwables (list;nth idx) - (default "java.lang.Object"))))) + (maybe;default "java.lang.Object"))))) #let [throwableC (`' (_lux_check (+0 (~ (code;text throwable)) (+0)) ("jvm object null")))]] ($_ seq diff --git a/new-luxc/test/test/luxc/analyser/reference.lux b/new-luxc/test/test/luxc/analyser/reference.lux index 5601318aa..5cc607080 100644 --- a/new-luxc/test/test/luxc/analyser/reference.lux +++ b/new-luxc/test/test/luxc/analyser/reference.lux @@ -4,8 +4,8 @@ (control [monad #+ do] pipe) (data ["R" result]) - ["r" math/random "R/" Monad<Random>] - [type "Type/" Eq<Type>] + ["r" math/random] + [type "type/" Eq<Type>] [macro #+ Monad<Lux>] test) (luxc ["&;" scope] @@ -30,7 +30,7 @@ (@;analyse-reference ["" var-name])))) (macro;run (init-compiler [])) (case> (#R;Success [_type (#~;Variable idx)]) - (Type/= ref-type _type) + (type/= ref-type _type) _ false))) @@ -38,12 +38,12 @@ (|> (do Monad<Lux> [_ (&module;create +0 module-name) _ (&module;define [module-name var-name] - [ref-type (list) (:! Void [])])] + [ref-type (' {}) (:! Void [])])] (@common;with-unknown-type (@;analyse-reference [module-name var-name]))) (macro;run (init-compiler [])) (case> (#R;Success [_type (#~;Definition idx)]) - (Type/= ref-type _type) + (type/= ref-type _type) _ false))) diff --git a/new-luxc/test/test/luxc/analyser/structure.lux b/new-luxc/test/test/luxc/analyser/structure.lux index d9595492e..d4d915364 100644 --- a/new-luxc/test/test/luxc/analyser/structure.lux +++ b/new-luxc/test/test/luxc/analyser/structure.lux @@ -3,17 +3,18 @@ (lux [io] (control [monad #+ do] pipe) - (data [bool "B/" Eq<Bool>] + (data [bool "bool/" Eq<Bool>] ["R" result] [product] + [maybe] [text] text/format - (coll [list "L/" Functor<List>] + (coll [list "list/" Functor<List>] ["S" set])) ["r" math/random "r/" Monad<Random>] - [type "Type/" Eq<Type>] - (type ["TC" check]) - [macro #+ Monad<Lux>] + [type "type/" Eq<Type>] + (type ["tc" check]) + [macro] (macro [code]) test) (luxc ["&" base] @@ -61,14 +62,14 @@ primitives (r;list size gen-primitive) +choice (|> r;nat (:: @ map (n.% (n.inc size)))) [_ +valueC] gen-primitive - #let [variantT (type;variant (L/map product;left primitives)) - [valueT valueC] (assume (list;nth choice primitives)) + #let [variantT (type;variant (list/map product;left primitives)) + [valueT valueC] (maybe;assume (list;nth choice primitives)) +size (n.inc size) +primitives (list;concat (list (list;take choice primitives) (list [(#;Bound +1) +valueC]) (list;drop choice primitives))) - [+valueT +valueC] (assume (list;nth +choice +primitives)) - +variantT (type;variant (L/map product;left +primitives))]] + [+valueT +valueC] (maybe;assume (list;nth +choice +primitives)) + +variantT (type;variant (list/map product;left +primitives))]] ($_ seq (test "Can analyse sum." (|> (&;with-scope @@ -79,7 +80,7 @@ [(flatten-variant sumA) (#;Some [tag last? valueA])]) (and (n.= tag choice) - (B/= last? (n.= (n.dec size) choice))) + (bool/= last? (n.= (n.dec size) choice))) _ false))) @@ -87,9 +88,9 @@ (|> (&;with-scope (@common;with-var (function [[var-id varT]] - (do Monad<Lux> - [_ (&;within-type-env - (TC;check varT variantT))] + (do macro;Monad<Lux> + [_ (&;with-type-env + (tc;check varT variantT))] (&;with-expected-type varT (@;analyse-sum analyse choice valueC)))))) (macro;run (init-compiler [])) @@ -97,7 +98,7 @@ [(flatten-variant sumA) (#;Some [tag last? valueA])]) (and (n.= tag choice) - (B/= last? (n.= (n.dec size) choice))) + (bool/= last? (n.= (n.dec size) choice))) _ false))) @@ -140,15 +141,15 @@ primitives (r;list size gen-primitive) choice (|> r;nat (:: @ map (n.% size))) [_ +valueC] gen-primitive - #let [[singletonT singletonC] (|> primitives (list;nth choice) assume) + #let [[singletonT singletonC] (|> primitives (list;nth choice) maybe;assume) +primitives (list;concat (list (list;take choice primitives) (list [(#;Bound +1) +valueC]) (list;drop choice primitives))) - +tupleT (type;tuple (L/map product;left +primitives))]] + +tupleT (type;tuple (list/map product;left +primitives))]] ($_ seq (test "Can analyse product." - (|> (&;with-expected-type (type;tuple (L/map product;left primitives)) - (@;analyse-product analyse (L/map product;right primitives))) + (|> (&;with-expected-type (type;tuple (list/map product;left primitives)) + (@;analyse-product analyse (list/map product;right primitives))) (macro;run (init-compiler [])) (case> (#R;Success tupleA) (n.= size (list;size (flatten-tuple tupleA))) @@ -157,10 +158,10 @@ false))) (test "Can infer product." (|> (@common;with-unknown-type - (@;analyse-product analyse (L/map product;right primitives))) + (@;analyse-product analyse (list/map product;right primitives))) (macro;run (init-compiler [])) (case> (#R;Success [_type tupleA]) - (and (Type/= (type;tuple (L/map product;left primitives)) + (and (type/= (type;tuple (list/map product;left primitives)) _type) (n.= size (list;size (flatten-tuple tupleA)))) @@ -179,11 +180,11 @@ (|> (&;with-scope (@common;with-var (function [[var-id varT]] - (do Monad<Lux> - [_ (&;within-type-env - (TC;check varT (type;tuple (L/map product;left primitives))))] + (do macro;Monad<Lux> + [_ (&;with-type-env + (tc;check varT (type;tuple (list/map product;left primitives))))] (&;with-expected-type varT - (@;analyse-product analyse (L/map product;right primitives))))))) + (@;analyse-product analyse (list/map product;right primitives))))))) (macro;run (init-compiler [])) (case> (#R;Success [_ tupleA]) (n.= size (list;size (flatten-tuple tupleA))) @@ -193,7 +194,7 @@ (test "Can analyse product through existential quantification." (|> (&;with-scope (&;with-expected-type (type;ex-q +1 +tupleT) - (@;analyse-product analyse (L/map product;right +primitives)))) + (@;analyse-product analyse (list/map product;right +primitives)))) (macro;run (init-compiler [])) (case> (#R;Success _) true @@ -203,7 +204,7 @@ (test "Cannot analyse product through universal quantification." (|> (&;with-scope (&;with-expected-type (type;univ-q +1 +tupleT) - (@;analyse-product analyse (L/map product;right +primitives)))) + (@;analyse-product analyse (list/map product;right +primitives)))) (macro;run (init-compiler [])) (case> (#R;Success _) false @@ -219,9 +220,9 @@ (case> (^multi (#R;Success [_ _ sumT sumA]) [(flatten-variant sumA) (#;Some [tag last? valueA])]) - (and (Type/= variantT sumT) + (and (type/= variantT sumT) (n.= tag choice) - (B/= last? (n.= (n.dec size) choice))) + (bool/= last? (n.= (n.dec size) choice))) _ false))) @@ -233,7 +234,7 @@ (case> (^multi (#R;Success [_ _ productT productA]) [(flatten-tuple productA) membersA]) - (and (Type/= tupleT productT) + (and (type/= tupleT productT) (n.= size (list;size membersA))) _ @@ -248,9 +249,9 @@ module-name (r;text +5) type-name (r;text +5) #let [varT (#;Bound +1) - primitivesT (L/map product;left primitives) - [choiceT choiceC] (assume (list;nth choice primitives)) - [other-choiceT other-choiceC] (assume (list;nth other-choice primitives)) + primitivesT (list/map product;left primitives) + [choiceT choiceC] (maybe;assume (list;nth choice primitives)) + [other-choiceT other-choiceC] (maybe;assume (list;nth other-choice primitives)) variantT (type;variant primitivesT) namedT (#;Named [module-name type-name] variantT) polyT (|> (type;variant (list;concat (list (list;take choice primitivesT) @@ -258,12 +259,12 @@ (list;drop (n.inc choice) primitivesT)))) (type;univ-q +1)) named-polyT (#;Named [module-name type-name] polyT) - choice-tag (assume (list;nth choice tags)) - other-choice-tag (assume (list;nth other-choice tags))]] + choice-tag (maybe;assume (list;nth choice tags)) + other-choice-tag (maybe;assume (list;nth other-choice tags))]] ($_ seq (test "Can infer tagged sum." (|> (@module;with-module +0 module-name - (do Monad<Lux> + (do macro;Monad<Lux> [_ (@module;declare-tags tags false namedT)] (&;with-scope (@common;with-unknown-type @@ -271,7 +272,7 @@ (check-variant-inference variantT choice size))) (test "Tagged sums specialize when type-vars get bound." (|> (@module;with-module +0 module-name - (do Monad<Lux> + (do macro;Monad<Lux> [_ (@module;declare-tags tags false named-polyT)] (&;with-scope (@common;with-unknown-type @@ -279,7 +280,7 @@ (check-variant-inference variantT choice size))) (test "Tagged sum inference retains universal quantification when type-vars are not bound." (|> (@module;with-module +0 module-name - (do Monad<Lux> + (do macro;Monad<Lux> [_ (@module;declare-tags tags false named-polyT)] (&;with-scope (@common;with-unknown-type @@ -287,7 +288,7 @@ (check-variant-inference polyT other-choice size))) (test "Can specialize generic tagged sums." (|> (@module;with-module +0 module-name - (do Monad<Lux> + (do macro;Monad<Lux> [_ (@module;declare-tags tags false named-polyT)] (&;with-scope (&;with-expected-type variantT @@ -297,7 +298,7 @@ [(flatten-variant sumA) (#;Some [tag last? valueA])]) (and (n.= tag other-choice) - (B/= last? (n.= (n.dec size) other-choice))) + (bool/= last? (n.= (n.dec size) other-choice))) _ false))) @@ -311,9 +312,9 @@ type-name (r;text +5) choice (|> r;nat (:: @ map (n.% size))) #let [varT (#;Bound +1) - tagsC (L/map (|>. [module-name] code;tag) tags) - primitivesT (L/map product;left primitives) - primitivesC (L/map product;right primitives) + tagsC (list/map (|>. [module-name] code;tag) tags) + primitivesT (list/map product;left primitives) + primitivesC (list/map product;right primitives) tupleT (type;tuple primitivesT) namedT (#;Named [module-name type-name] tupleT) recordC (list;zip2 tagsC primitivesC) @@ -325,7 +326,7 @@ ($_ seq (test "Can infer record." (|> (@module;with-module +0 module-name - (do Monad<Lux> + (do macro;Monad<Lux> [_ (@module;declare-tags tags false namedT)] (&;with-scope (@common;with-unknown-type @@ -333,7 +334,7 @@ (check-record-inference tupleT size))) (test "Records specialize when type-vars get bound." (|> (@module;with-module +0 module-name - (do Monad<Lux> + (do macro;Monad<Lux> [_ (@module;declare-tags tags false named-polyT)] (&;with-scope (@common;with-unknown-type @@ -341,7 +342,7 @@ (check-record-inference tupleT size))) (test "Can specialize generic records." (|> (@module;with-module +0 module-name - (do Monad<Lux> + (do macro;Monad<Lux> [_ (@module;declare-tags tags false named-polyT)] (&;with-scope (&;with-expected-type tupleT diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux index 9fec0d501..4aff49779 100644 --- a/new-luxc/test/test/luxc/generator/case.lux +++ b/new-luxc/test/test/luxc/generator/case.lux @@ -74,6 +74,7 @@ )))) (context: "Pattern-matching." + #seed +17952275935008918762 [[valueS path] gen-case to-bind r;nat] ($_ seq diff --git a/new-luxc/test/test/luxc/generator/function.lux b/new-luxc/test/test/luxc/generator/function.lux index 3f938d9df..3757c0937 100644 --- a/new-luxc/test/test/luxc/generator/function.lux +++ b/new-luxc/test/test/luxc/generator/function.lux @@ -3,16 +3,13 @@ (lux [io] (control [monad #+ do] pipe) - (data text/format - [product] + (data [product] + [maybe] ["R" result] - [bool "B/" Eq<Bool>] - [text "T/" Eq<Text>] (coll ["a" array] - [list "L/" Functor<List>] - ["S" set])) + [list "list/" Functor<List>])) ["r" math/random "r/" Monad<Random>] - [macro #+ Monad<Lux>] + [macro] (macro [code]) [host] test) @@ -43,13 +40,13 @@ [[arity arg functionS] gen-function cut-off (|> r;nat (:: @ map (n.% arity))) args (r;list arity r;nat) - #let [arg-value (assume (list;nth arg args)) - argsS (L/map (|>. #ls;Nat) args) + #let [arg-value (maybe;assume (list;nth arg args)) + argsS (list/map (|>. #ls;Nat) args) last-arg (n.dec arity) cut-off (|> cut-off (n.min (n.dec last-arg)))]] ($_ seq (test "Can read arguments." - (|> (do Monad<Lux> + (|> (do macro;Monad<Lux> [runtime-bytecode @runtime;generate sampleI (@expr;generate (#ls;Call argsS functionS))] (@eval;eval sampleI)) @@ -61,7 +58,7 @@ false))) (test "Can partially apply functions." (or (n.= +1 arity) - (|> (do Monad<Lux> + (|> (do macro;Monad<Lux> [#let [partial-arity (n.inc cut-off) preS (list;take partial-arity argsS) postS (list;drop partial-arity argsS)] @@ -76,9 +73,9 @@ false)))) (test "Can read environment." (or (n.= +1 arity) - (|> (do Monad<Lux> + (|> (do macro;Monad<Lux> [#let [env (|> (list;n.range +0 cut-off) - (L/map (|>. n.inc nat-to-int))) + (list/map (|>. n.inc nat-to-int))) super-arity (n.inc cut-off) arg-var (if (n.<= cut-off arg) (|> arg n.inc nat-to-int (i.* -1)) diff --git a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux index 1016d4957..20e19fb5f 100644 --- a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux @@ -287,6 +287,7 @@ ))) (context: "Deg procedures" + #seed +1021167468900 [param (|> r;deg (r;filter (|>. (d.= .0) not))) special r;nat subject r;deg] diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux index 9fec0e078..fb15588ea 100644 --- a/new-luxc/test/test/luxc/generator/structure.lux +++ b/new-luxc/test/test/luxc/generator/structure.lux @@ -3,10 +3,11 @@ (lux [io] (control [monad #+ do] pipe) - (data text/format - ["R" result] + (data ["R" result] + [maybe] [bool "bool/" Eq<Bool>] [text "text/" Eq<Text>] + text/format (coll ["a" array] [list])) ["r" math/random "r/" Monad<Random>] @@ -89,9 +90,9 @@ (case> (#R;Success valueG) (let [valueG (:! (a;Array Top) valueG)] (and (n.= +3 (a;size valueG)) - (let [_tag (:! Integer (assume (a;get +0 valueG))) + (let [_tag (:! Integer (maybe;assume (a;get +0 valueG))) _last? (a;get +1 valueG) - _value (:! Top (assume (a;get +2 valueG)))] + _value (:! Top (maybe;assume (a;get +2 valueG)))] (and (n.= tag (|> _tag host;i2l int-to-nat)) (case _last? (#;Some _last?') diff --git a/new-luxc/test/test/luxc/parser.lux b/new-luxc/test/test/luxc/parser.lux index 247850e2b..a7708e1e5 100644 --- a/new-luxc/test/test/luxc/parser.lux +++ b/new-luxc/test/test/luxc/parser.lux @@ -2,11 +2,11 @@ lux (lux [io] (control [monad #+ do]) - (data [text "T/" Eq<Text>] + (data [number] + ["R" result] + [text] (text format ["l" lexer]) - [number] - ["R" result] (coll [list])) ["r" math/random "r/" Monad<Random>] (macro [code]) @@ -74,6 +74,7 @@ composite^)))))) (context: "Lux code parser." + #seed +15545773516740647407 [sample code^] (test "Can parse Lux code." (case (&;parse [default-cursor (code;to-text sample)]) @@ -107,6 +108,7 @@ )) (context: "Nat special syntax." + #seed +8051810494442953019 [expected (|> r;nat (:: @ map (n.% +1_000)))] (test "Can parse nat char syntax." (case (&;parse [default-cursor diff --git a/new-luxc/test/test/luxc/synthesizer/function.lux b/new-luxc/test/test/luxc/synthesizer/function.lux index 6791eceb4..c97f2f0fc 100644 --- a/new-luxc/test/test/luxc/synthesizer/function.lux +++ b/new-luxc/test/test/luxc/synthesizer/function.lux @@ -4,11 +4,12 @@ (control [monad #+ do] pipe) (data [product] + [maybe] [number] text/format - (coll [list "L/" Functor<List> Fold<List>] - ["D" dict] - ["s" set])) + (coll [list "list/" Functor<List> Fold<List>] + [dict #+ Dict] + [set])) ["r" math/random "r/" Monad<Random>] test) (luxc (lang ["la" analysis] @@ -29,8 +30,8 @@ #;inner +0 #;locals {#;counter +0 #;mappings (list)} #;captured {#;counter +0 - #;mappings (L/map (|>. reference [Void] [""]) - env)}}) + #;mappings (list/map (|>. reference [Void] [""]) + env)}}) (def: gen-function//constant (r;Random [Nat la;Analysis la;Analysis]) @@ -57,34 +58,34 @@ (do r;Monad<Random> [num-locals (|> r;nat (:: @ map (|>. (n.% +100) (n.max +10)))) #let [indices (list;n.range +0 (n.dec num-locals)) - absolute-env (L/map &&function;to-local indices) - relative-env (L/map &&function;to-captured indices)] + absolute-env (list/map &&function;to-local indices) + relative-env (list/map &&function;to-captured indices)] [total-args prediction bodyA] (: (r;Random [Nat Int la;Analysis]) (loop [num-args +1 global-env relative-env] (let [env-size (list;size global-env) - resolver (L/fold (function [[idx var] resolver] - (D;put idx var resolver)) - (: (D;Dict Nat Int) - (D;new number;Hash<Nat>)) - (list;zip2 (list;n.range +0 (n.dec env-size)) - global-env))] + resolver (list/fold (function [[idx var] resolver] + (dict;put idx var resolver)) + (: (Dict Nat Int) + (dict;new number;Hash<Nat>)) + (list;zip2 (list;n.range +0 (n.dec env-size)) + global-env))] (do @ [nest? r;bool] (if nest? (do @ [num-picks (:: @ map (n.max +1) (pick (n.inc env-size))) picks (|> (r;set number;Hash<Nat> num-picks (pick env-size)) - (:: @ map s;to-list)) + (:: @ map set;to-list)) [total-args prediction bodyA] (recur (n.inc num-args) - (L/map (function [pick] (assume (list;nth pick global-env))) - picks))] - (wrap [total-args prediction (#la;Function (make-scope (L/map &&function;to-captured picks)) + (list/map (function [pick] (maybe;assume (list;nth pick global-env))) + picks))] + (wrap [total-args prediction (#la;Function (make-scope (list/map &&function;to-captured picks)) bodyA)])) (do @ [chosen (pick (list;size global-env))] (wrap [num-args - (assume (D;get chosen resolver)) + (maybe;assume (dict;get chosen resolver)) (#la;Variable (#;Captured chosen))])))))))] (wrap [total-args prediction (#la;Function (make-scope absolute-env) bodyA)]) )) |