From 74a835634fc9ee5457f3cc7109af069dad9f2d2f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 11 Oct 2017 18:57:44 -0400 Subject: - Migrated new-luxc to latest version of stdlib. - Some refactoring. --- new-luxc/source/luxc/analyser/case.lux | 108 ++++++++++++++++----------------- 1 file changed, 54 insertions(+), 54 deletions(-) (limited to 'new-luxc/source/luxc/analyser/case.lux') 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] + (data [bool] [number] + [product] + ["R" result] + [maybe] [text] text/format - [product] - ["R" result "R/" Monad] - (coll [list "L/" Fold Monoid Monad] - ["D" dict])) - [macro #+ Monad] + (coll [list "list/" Fold Monoid Functor])) + [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 - [? (&;within-type-env - (TC;bound? id))] + (do macro;Monad + [? (&;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 - [[ex-id exT] (&;within-type-env - TC;existential)] - (simplify-case-type (assume (type;apply (list exT) type)))) + (do macro;Monad + [[ex-id exT] (&;with-type-env + tc;existential)] + (simplify-case-type (maybe;assume (type;apply (list exT) type)))) _ - (:: Monad wrap type))) + (:: macro;Monad 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 + (do macro;Monad [outputA (&scope;with-local [name inputT] next) idx &scope;next-local] @@ -93,9 +93,9 @@ (^template [ ] [cursor ( test)] (&;with-cursor cursor - (do Monad - [_ (&;within-type-env - (TC;check inputT )) + (do macro;Monad + [_ (&;with-type-env + (tc;check inputT )) outputA next] (wrap [( test) outputA])))) ([Bool #;Bool #la;BoolP] @@ -107,9 +107,9 @@ (^ [cursor (#;Tuple (list))]) (&;with-cursor cursor - (do Monad - [_ (&;within-type-env - (TC;check inputT Unit)) + (do macro;Monad + [_ (&;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 + (do macro;Monad [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 + (do macro;Monad [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 + (do macro;Monad [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 + (do macro;Monad [[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 + (do macro;Monad [[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 + (do macro;Monad [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 + (do macro;Monad [[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 &&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 []) -- cgit v1.2.3