diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/common.lux | 31 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis/case.lux (renamed from new-luxc/source/luxc/lang/analysis/case.lux) | 225 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis/case/coverage.lux (renamed from new-luxc/source/luxc/lang/analysis/case/coverage.lux) | 120 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/analysis/case.lux (renamed from new-luxc/test/test/luxc/lang/analysis/case.lux) | 102 |
4 files changed, 225 insertions, 253 deletions
diff --git a/new-luxc/test/test/luxc/lang/analysis/common.lux b/new-luxc/test/test/luxc/lang/analysis/common.lux deleted file mode 100644 index 7e343cc88..000000000 --- a/new-luxc/test/test/luxc/lang/analysis/common.lux +++ /dev/null @@ -1,31 +0,0 @@ -(.module: - lux - (lux [io] - (control pipe) - ["r" math/random "r/" Monad<Random>] - (data ["e" error]) - [macro] - (macro [code])) - (luxc ["&" lang] - (lang (analysis [".A" expression]) - [eval])) - (test/luxc common)) - -(def: #export analyse - &.Analyser - (expressionA.analyser eval.eval)) - -(do-template [<name> <on-success> <on-failure>] - [(def: #export (<name> analysis) - (All [a] (-> (Meta a) Bool)) - (|> analysis - (macro.run (io.run init-jvm)) - (case> (#e.Success _) - <on-success> - - (#e.Error error) - <on-failure>)))] - - [check-success true false] - [check-failure false true] - ) diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/stdlib/source/lux/lang/analysis/case.lux index d9efa2bf4..3140a9d7e 100644 --- a/new-luxc/source/luxc/lang/analysis/case.lux +++ b/stdlib/source/lux/lang/analysis/case.lux @@ -1,8 +1,8 @@ (.module: - lux + [lux #- case] (lux (control [monad #+ do] ["ex" exception #+ exception:] - eq) + [equality #+ Eq]) (data [bool] [number] [product] @@ -11,38 +11,43 @@ [text] text/format (coll [list "list/" Fold<List> Monoid<List> Functor<List>])) + [function] [macro] (macro [code]) + [lang] (lang [type] - (type ["tc" check]))) - (luxc ["&" lang] - (lang ["&." scope] - ["la" analysis] - (analysis [".A" common] - [".A" structure] - (case [".A" coverage]))))) + (type ["tc" check]) + [".L" scope] + [".L" analysis #+ Pattern Analysis Analyser] + (analysis [".A" type] + [".A" structure] + (case [".A" coverage]))))) + +(exception: #export (cannot-match-type-with-pattern {type Type} {pattern Code}) + (ex.report ["Type" (%type type)] + ["Pattern" (%code pattern)])) + +(exception: #export (sum-type-has-no-case {case Nat} {type Type}) + (ex.report ["Case" (%n case)] + ["Type" (%type type)])) + +(exception: #export (unrecognized-pattern-syntax {pattern Code}) + (%code pattern)) + +(exception: #export (cannot-simplify-type-for-pattern-matching {type Type}) + (%type type)) (do-template [<name>] [(exception: #export (<name> {message Text}) message)] - [Cannot-Match-Type-With-Pattern] - [Sum-Type-Has-No-Case] - [Unrecognized-Pattern-Syntax] - [Cannot-Simplify-Type-For-Pattern-Matching] - [Cannot-Have-Empty-Branches] - [Non-Exhaustive-Pattern-Matching] - [Symbols-Must-Be-Unqualified-Inside-Patterns] + [cannot-have-empty-branches] + [non-exhaustive-pattern-matching] ) -(def: (pattern-error type pattern) - (-> Type Code Text) - (format " Type: " (%type type) "\n" - "Pattern: " (%code pattern))) - (def: (re-quantify envs baseT) (-> (List (List Type)) Type Type) - (case envs + (.case envs #.Nil baseT @@ -61,17 +66,17 @@ (loop [envs (: (List (List Type)) (list)) caseT caseT] - (case caseT + (.case caseT (#.Var id) (do macro.Monad<Meta> - [?caseT' (&.with-type-env + [?caseT' (typeA.with-env (tc.read id))] - (case ?caseT' + (.case ?caseT' (#.Some caseT') (recur envs caseT') _ - (&.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) + (lang.throw cannot-simplify-type-for-pattern-matching caseT))) (#.Named name unnamedT) (recur envs unnamedT) @@ -79,43 +84,34 @@ (#.UnivQ env unquantifiedT) (recur (#.Cons env envs) unquantifiedT) - ## (^template [<tag> <instancer>] - ## (<tag> _) - ## (do macro.Monad<Meta> - ## [[_ instanceT] (&.with-type-env - ## <instancer>)] - ## (recur (maybe.assume (type.apply (list instanceT) caseT))))) - ## ([#.UnivQ tc.var] - ## [#.ExQ tc.existential]) - (#.ExQ _) (do macro.Monad<Meta> - [[ex-id exT] (&.with-type-env + [[ex-id exT] (typeA.with-env tc.existential)] (recur envs (maybe.assume (type.apply (list exT) caseT)))) (#.Apply inputT funcT) - (case funcT + (.case funcT (#.Var funcT-id) (do macro.Monad<Meta> - [funcT' (&.with-type-env + [funcT' (typeA.with-env (do tc.Monad<Check> [?funct' (tc.read funcT-id)] - (case ?funct' + (.case ?funct' (#.Some funct') (wrap funct') _ - (tc.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))] + (tc.throw cannot-simplify-type-for-pattern-matching caseT))))] (recur envs (#.Apply inputT funcT'))) _ - (case (type.apply (list inputT) funcT) + (.case (type.apply (list inputT) funcT) (#.Some outputT) (recur envs outputT) #.None - (&.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) + (lang.throw cannot-simplify-type-for-pattern-matching caseT))) (#.Product _) (|> caseT @@ -127,6 +123,15 @@ _ (:: macro.Monad<Meta> wrap (re-quantify envs caseT))))) +(def: (analyse-primitive type inputT cursor output next) + (All [a] (-> Type Type Cursor Pattern (Meta a) (Meta [Pattern a]))) + (lang.with-cursor cursor + (do macro.Monad<Meta> + [_ (typeA.with-env + (tc.check inputT type)) + outputA next] + (wrap [output outputA])))) + ## This function handles several concerns at once, but it must be that ## way because those concerns are interleaved when doing ## pattern-matching and they cannot be separated. @@ -144,74 +149,57 @@ ## That is why the body must be analysed in the context of the ## pattern, and not separately. (def: (analyse-pattern num-tags inputT pattern next) - (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a]))) - (case pattern + (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [Pattern a]))) + (.case pattern [cursor (#.Symbol ["" name])] - (&.with-cursor cursor + (lang.with-cursor cursor (do macro.Monad<Meta> - [outputA (&scope.with-local [name inputT] + [outputA (scopeL.with-local [name inputT] next) - idx &scope.next-local] - (wrap [(` ("lux case bind" (~ (code.nat idx)))) outputA]))) - - [cursor (#.Symbol ident)] - (&.with-cursor cursor - (&.throw Symbols-Must-Be-Unqualified-Inside-Patterns (%ident ident))) - - (^template [<type> <code-tag>] - [cursor (<code-tag> test)] - (&.with-cursor cursor - (do macro.Monad<Meta> - [_ (&.with-type-env - (tc.check inputT <type>)) - outputA next] - (wrap [pattern outputA])))) - ([Bool #.Bool] - [Nat #.Nat] - [Int #.Int] - [Deg #.Deg] - [Frac #.Frac] - [Text #.Text]) - - (^ [cursor (#.Tuple (list))]) - (&.with-cursor cursor - (do macro.Monad<Meta> - [_ (&.with-type-env - (tc.check inputT Top)) - outputA next] - (wrap [(` ("lux case tuple" [])) outputA]))) - + idx scopeL.next-local] + (wrap [(#analysisL.Bind idx) outputA]))) + + (^template [<type> <input> <output>] + [cursor <input>] + (analyse-primitive <type> inputT cursor (#analysisL.Simple <output>) next)) + ([Bool (#.Bool pattern-value) (#analysisL.Bool pattern-value)] + [Nat (#.Nat pattern-value) (#analysisL.Nat pattern-value)] + [Int (#.Int pattern-value) (#analysisL.Int pattern-value)] + [Deg (#.Deg pattern-value) (#analysisL.Deg pattern-value)] + [Frac (#.Frac pattern-value) (#analysisL.Frac pattern-value)] + [Text (#.Text pattern-value) (#analysisL.Text pattern-value)] + [Top (#.Tuple #.Nil) #analysisL.Unit]) + (^ [cursor (#.Tuple (list singleton))]) (analyse-pattern #.None inputT singleton next) [cursor (#.Tuple sub-patterns)] - (&.with-cursor cursor + (lang.with-cursor cursor (do macro.Monad<Meta> [inputT' (simplify-case-type inputT)] - (case inputT' + (.case inputT' (#.Product _) (let [sub-types (type.flatten-tuple inputT') num-sub-types (maybe.default (list.size sub-types) num-tags) num-sub-patterns (list.size sub-patterns) matches (cond (n/< num-sub-types num-sub-patterns) - (let [[prefix suffix] (list.split (n/dec num-sub-patterns) sub-types)] + (let [[prefix suffix] (list.split (dec num-sub-patterns) sub-types)] (list.zip2 (list/compose prefix (list (type.tuple suffix))) sub-patterns)) (n/> num-sub-types num-sub-patterns) - (let [[prefix suffix] (list.split (n/dec num-sub-types) sub-patterns)] + (let [[prefix suffix] (list.split (dec num-sub-types) sub-patterns)] (list.zip2 sub-types (list/compose prefix (list (code.tuple suffix))))) ## (n/= num-sub-types num-sub-patterns) - (list.zip2 sub-types sub-patterns) - )] + (list.zip2 sub-types sub-patterns))] (do @ [[memberP+ thenA] (list/fold (: (All [a] - (-> [Type Code] (Meta [(List la.Pattern) a]) - (Meta [(List la.Pattern) a]))) + (-> [Type Code] (Meta [(List Pattern) a]) + (Meta [(List Pattern) a]))) (function (_ [memberT memberC] then) (do @ - [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a]))) + [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [Pattern a]))) analyse-pattern) #.None memberT memberC then)] (wrap [(list& memberP memberP+) thenA])))) @@ -219,81 +207,76 @@ [nextA next] (wrap [(list) nextA])) (list.reverse matches))] - (wrap [(` ("lux case tuple" [(~+ memberP+)])) + (wrap [(analysisL.product-pattern memberP+) thenA]))) _ - (&.throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern)) + (lang.throw cannot-match-type-with-pattern [inputT pattern]) ))) [cursor (#.Record record)] (do macro.Monad<Meta> [record (structureA.normalize record) [members recordT] (structureA.order record) - _ (&.with-type-env + _ (typeA.with-env (tc.check inputT recordT))] (analyse-pattern (#.Some (list.size members)) inputT [cursor (#.Tuple members)] next)) [cursor (#.Tag tag)] - (&.with-cursor cursor + (lang.with-cursor cursor (analyse-pattern #.None inputT (` ((~ pattern))) next)) (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))]) - (&.with-cursor cursor + (lang.with-cursor cursor (do macro.Monad<Meta> [inputT' (simplify-case-type inputT)] - (case inputT' + (.case inputT' (#.Sum _) (let [flat-sum (type.flatten-variant inputT') size-sum (list.size flat-sum) num-cases (maybe.default size-sum num-tags)] - (case (list.nth idx flat-sum) + (.case (list.nth idx flat-sum) (^multi (#.Some case-type) (n/< num-cases idx)) - (if (and (n/> num-cases size-sum) - (n/= (n/dec num-cases) idx)) - (do macro.Monad<Meta> - [[testP nextA] (analyse-pattern #.None - (type.variant (list.drop (n/dec num-cases) flat-sum)) + (do macro.Monad<Meta> + [[testP nextA] (if (and (n/> num-cases size-sum) + (n/= (dec num-cases) idx)) + (analyse-pattern #.None + (type.variant (list.drop (dec num-cases) flat-sum)) (` [(~+ values)]) - next)] - (wrap [(` ("lux case variant" (~ (code.nat idx)) (~ (code.nat num-cases)) (~ testP))) - nextA])) - (do macro.Monad<Meta> - [[testP nextA] (analyse-pattern #.None case-type (` [(~+ values)]) next)] - (wrap [(` ("lux case variant" (~ (code.nat idx)) (~ (code.nat num-cases)) (~ testP))) - nextA]))) + next) + (analyse-pattern #.None case-type (` [(~+ values)]) next))] + (wrap [(analysisL.sum-pattern num-cases idx testP) + nextA])) _ - (&.throw Sum-Type-Has-No-Case - (format "Case: " (%n idx) "\n" - "Type: " (%type inputT))))) + (lang.throw sum-type-has-no-case [idx inputT]))) _ - (&.throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern))))) + (lang.throw cannot-match-type-with-pattern [inputT pattern])))) (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) - (&.with-cursor cursor + (lang.with-cursor cursor (do macro.Monad<Meta> [tag (macro.normalize tag) [idx group variantT] (macro.resolve-tag tag) - _ (&.with-type-env + _ (typeA.with-env (tc.check inputT variantT))] (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next))) _ - (&.throw Unrecognized-Pattern-Syntax (%code pattern)) + (lang.throw unrecognized-pattern-syntax pattern) )) -(def: #export (analyse-case analyse inputC branches) - (-> &.Analyser Code (List [Code Code]) (Meta la.Analysis)) - (case branches +(def: #export (case analyse inputC branches) + (-> Analyser Code (List [Code Code]) (Meta Analysis)) + (.case branches #.Nil - (&.throw Cannot-Have-Empty-Branches "") + (lang.throw cannot-have-empty-branches "") (#.Cons [patternH bodyH] branchesT) (do macro.Monad<Meta> - [[inputT inputA] (commonA.with-unknown-type + [[inputT inputA] (typeA.with-inference (analyse inputC)) outputH (analyse-pattern #.None inputT patternH (analyse bodyH)) outputT (monad.map @ @@ -302,11 +285,11 @@ branchesT) outputHC (|> outputH product.left coverageA.determine) outputTC (monad.map @ (|>> product.left coverageA.determine) outputT) - _ (case (monad.fold e.Monad<Error> coverageA.merge outputHC outputTC) + _ (.case (monad.fold e.Monad<Error> coverageA.merge outputHC outputTC) (#e.Success coverage) - (&.assert Non-Exhaustive-Pattern-Matching "" - (coverageA.exhaustive? coverage)) + (lang.assert non-exhaustive-pattern-matching "" + (coverageA.exhaustive? coverage)) (#e.Error error) - (&.fail error))] - (wrap (` ("lux case" (~ inputA) (~ (code.record (list& outputH outputT))))))))) + (lang.fail error))] + (wrap (#analysisL.Case inputA [outputH outputT]))))) diff --git a/new-luxc/source/luxc/lang/analysis/case/coverage.lux b/stdlib/source/lux/lang/analysis/case/coverage.lux index 38f977011..da256206f 100644 --- a/new-luxc/source/luxc/lang/analysis/case/coverage.lux +++ b/stdlib/source/lux/lang/analysis/case/coverage.lux @@ -2,19 +2,41 @@ lux (lux (control [monad #+ do] ["ex" exception #+ exception:] - eq) + equality) (data [bool "bool/" Eq<Bool>] [number] ["e" error "error/" Monad<Error>] + [maybe] text/format (coll [list "list/" Fold<List>] (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad<Meta>]) - (luxc ["&" lang] - (lang ["la" analysis]))) - -(exception: #export (Unknown-Pattern {message Text}) - message) + [macro "macro/" Monad<Meta>] + [lang] + (lang [".L" analysis #+ Pattern Variant]))) + +(def: cases + (-> (Maybe Nat) Nat) + (|>> (maybe.default +0))) + +(def: (variant sum-side) + (-> (Either Pattern Pattern) (Variant Pattern)) + (loop [lefts +0 + variantP sum-side] + (case variantP + (#.Left valueP) + (case valueP + (#analysisL.Complex (#analysisL.Sum value-side)) + (recur (inc lefts) value-side) + + _ + {#analysisL.lefts lefts + #analysisL.right? false + #analysisL.value valueP}) + + (#.Right valueP) + {#analysisL.lefts lefts + #analysisL.right? true + #analysisL.value valueP}))) ## The coverage of a pattern-matching expression summarizes how well ## all the possible values of an input are being covered by the @@ -31,7 +53,7 @@ (type: #export #rec Coverage #Partial (#Bool Bool) - (#Variant Nat (Dict Nat Coverage)) + (#Variant (Maybe Nat) (Dict Nat Coverage)) (#Seq Coverage Coverage) (#Alt Coverage Coverage) #Exhaustive) @@ -46,57 +68,56 @@ false)) (def: #export (determine pattern) - (-> la.Pattern (Meta Coverage)) + (-> Pattern (Meta Coverage)) (case pattern - ## Binding amounts to exhaustive coverage because any value can be - ## matched that way. - ## Unit [] amounts to exhaustive coverage because there is only one - ## possible value, so matching against it covers all cases. - (^or (^code ("lux case bind" (~ _))) (^code ("lux case tuple" []))) + (^or (#analysisL.Simple #analysisL.Unit) + (#analysisL.Bind _)) (macro/wrap #Exhaustive) - (^code ("lux case tuple" [(~ singleton)])) - (determine singleton) - ## Primitive patterns always have partial coverage because there ## are too many possibilities as far as values go. - (^or [_ (#.Nat _)] [_ (#.Int _)] [_ (#.Deg _)] - [_ (#.Frac _)] [_ (#.Text _)]) - (macro/wrap #Partial) + (^template [<tag>] + (#analysisL.Simple (<tag> _)) + (macro/wrap #Partial)) + ([#analysisL.Nat] + [#analysisL.Int] + [#analysisL.Deg] + [#analysisL.Frac] + [#analysisL.Text]) ## Bools are the exception, since there is only "true" and ## "false", which means it is possible for boolean ## pattern-matching to become exhaustive if complementary parts meet. - [_ (#.Bool value)] + (#analysisL.Simple (#analysisL.Bool value)) (macro/wrap (#Bool value)) ## Tuple patterns can be exhaustive if there is exhaustiveness for all of ## their sub-patterns. - (^code ("lux case tuple" [(~+ subs)])) - (loop [subs subs] - (case subs - #.Nil - (macro/wrap #Exhaustive) - - (#.Cons sub subs') - (do macro.Monad<Meta> - [pre (determine sub) - post (recur subs')] - (if (exhaustive? post) - (wrap pre) - (wrap (#Seq pre post)))))) - - ## Variant patterns can be shown to be exhaustive if all the possible - ## cases are handled exhaustively. - (^code ("lux case variant" (~ [_ (#.Nat tag-id)]) (~ [_ (#.Nat num-tags)]) (~ sub))) + (#analysisL.Complex (#analysisL.Product [left right])) (do macro.Monad<Meta> - [=sub (determine sub)] - (wrap (#Variant num-tags - (|> (dict.new number.Hash<Nat>) - (dict.put tag-id =sub))))) - - _ - (&.throw Unknown-Pattern (%code pattern)))) + [left (determine left) + right (determine right)] + (case right + (#Exhaustive _) + (wrap left) + + _ + (wrap (#Seq left right)))) + + (#analysisL.Complex (#analysisL.Sum sum-side)) + (let [[variant-lefts variant-right? variant-value] (variant sum-side)] + ## Variant patterns can be shown to be exhaustive if all the possible + ## cases are handled exhaustively. + (do macro.Monad<Meta> + [value-coverage (determine variant-value) + #let [variant-idx (if variant-right? + (inc variant-lefts) + variant-lefts)]] + (wrap (#Variant (if variant-right? + (#.Some variant-idx) + #.None) + (|> (dict.new number.Hash<Nat>) + (dict.put variant-idx value-coverage)))))))) (def: (xor left right) (-> Bool Bool Bool) @@ -132,9 +153,10 @@ (bool/= sideR sideS) [(#Variant allR casesR) (#Variant allS casesS)] - (and (n/= allR allS) + (and (n/= (cases allR) + (cases allS)) (:: (dict.Eq<Dict> =) = casesR casesS)) - + [(#Seq leftR rightR) (#Seq leftS rightS)] (and (= leftR leftS) (= rightR rightS)) @@ -176,7 +198,7 @@ (error/wrap #Exhaustive) [(#Variant allA casesA) (#Variant allSF casesSF)] - (cond (not (n/= allSF allA)) + (cond (not (n/= (cases allSF) (cases allA))) (e.fail "Variants do not match.") (:: (dict.Eq<Dict> Eq<Coverage>) = casesSF casesA) @@ -196,7 +218,7 @@ (wrap (dict.put tagA coverageA casesSF')))) casesSF (dict.entries casesA))] (wrap (if (let [case-coverages (dict.values casesM)] - (and (n/= allSF (list.size case-coverages)) + (and (n/= (cases allSF) (list.size case-coverages)) (list.every? exhaustive? case-coverages))) #Exhaustive (#Variant allSF casesM))))) diff --git a/new-luxc/test/test/luxc/lang/analysis/case.lux b/stdlib/test/test/lux/lang/analysis/case.lux index 63dd60e14..9e775f8a3 100644 --- a/new-luxc/test/test/luxc/lang/analysis/case.lux +++ b/stdlib/test/test/lux/lang/analysis/case.lux @@ -9,22 +9,20 @@ [maybe] [text "T/" Eq<Text>] text/format - (coll [list "L/" Monad<List>] + (coll [list "list/" Monad<List>] (set ["set" unordered]))) ["r" math/random "r/" Monad<Random>] [macro #+ Monad<Meta>] (macro [code]) + [lang] (lang [type "type/" Eq<Type>] - (type ["tc" check])) + (type ["tc" check]) + [".L" module] + (analysis [".A" type] + ["/" case])) test) - (luxc ["&" lang] - (lang ["@." module] - ["la" analysis] - (analysis [".A" expression] - ["@" case] - ["@." common]))) - (// common) - (test/luxc common)) + (// ["_." primitive] + ["_." structure])) (def: (exhaustive-weaving branchings) (-> (List (List Code)) (List (List Code))) @@ -33,7 +31,7 @@ #.Nil (#.Cons head+ #.Nil) - (L/map (|>> list) head+) + (list/map (|>> list) head+) (#.Cons head+ tail++) (do list.Monad<List> @@ -61,11 +59,11 @@ #.None (wrap (list (' _))))) (r/wrap (list (' _))))) - ([#.Nat r.nat code.nat] - [#.Int r.int code.int] - [#.Deg r.deg code.deg] - [#.Frac r.frac code.frac] - [#.Text (r.text +5) code.text]) + ([#.Nat r.nat code.nat] + [#.Int r.int code.int] + [#.Deg r.deg code.deg] + [#.Frac r.frac code.frac] + [#.Text (r.unicode +5) code.text]) (^ [_ (#.Tuple (list))]) (r/wrap (list (' []))) @@ -78,16 +76,16 @@ [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] (wrap (|> member-wise-patterns exhaustive-weaving - (L/map code.tuple)))) + (list/map code.tuple)))) [_ (#.Record kvs)] (do r.Monad<Random> - [#let [ks (L/map product.left kvs) - vs (L/map product.right kvs)] + [#let [ks (list/map product.left kvs) + vs (list/map product.right kvs)] member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)] (wrap (|> member-wise-patterns exhaustive-weaving - (L/map (|>> (list.zip2 ks) code.record))))) + (list/map (|>> (list.zip2 ks) code.record))))) (^ [_ (#.Form (list [_ (#.Tag _)] _))]) (do r.Monad<Random> @@ -95,10 +93,10 @@ (function (_ [_tag _code]) (do @ [v-branches (exhaustive-branches allow-literals? variantTC _code)] - (wrap (L/map (function (_ pattern) (` ((~ _tag) (~ pattern)))) - v-branches)))) + (wrap (list/map (function (_ pattern) (` ((~ _tag) (~ pattern)))) + v-branches)))) variantTC)] - (wrap (L/join bundles))) + (wrap (list/join bundles))) _ (r/wrap (list)) @@ -109,7 +107,7 @@ (r.rec (function (_ input) ($_ r.either - (r/map product.right gen-primitive) + (r/map product.right _primitive.primitive) (do r.Monad<Random> [choice (|> r.nat (:: @ map (n/% (list.size variant-tags)))) #let [choiceT (maybe.assume (list.nth choice variant-tags)) @@ -132,32 +130,32 @@ (<| (seed +5004137551292836565) ## (times +100) (do @ - [module-name (r.text +5) - variant-name (r.text +5) - record-name (|> (r.text +5) (r.filter (|>> (T/= variant-name) not))) + [module-name (r.unicode +5) + variant-name (r.unicode +5) + record-name (|> (r.unicode +5) (r.filter (|>> (T/= variant-name) not))) size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - variant-tags (|> (r.set text.Hash<Text> size (r.text +5)) (:: @ map set.to-list)) - record-tags (|> (r.set text.Hash<Text> size (r.text +5)) (:: @ map set.to-list)) - primitivesTC (r.list size gen-primitive) - #let [primitivesT (L/map product.left primitivesTC) - primitivesC (L/map product.right primitivesTC) + variant-tags (|> (r.set text.Hash<Text> size (r.unicode +5)) (:: @ map set.to-list)) + record-tags (|> (r.set text.Hash<Text> size (r.unicode +5)) (:: @ map set.to-list)) + primitivesTC (r.list size _primitive.primitive) + #let [primitivesT (list/map product.left primitivesTC) + primitivesC (list/map product.right primitivesTC) code-tag (|>> [module-name] code.tag) - variant-tags+ (L/map code-tag variant-tags) - record-tags+ (L/map code-tag record-tags) + variant-tags+ (list/map code-tag variant-tags) + record-tags+ (list/map code-tag record-tags) variantTC (list.zip2 variant-tags+ primitivesC)] inputC (input variant-tags+ record-tags+ primitivesC) - [outputT outputC] gen-primitive - [heterogeneousT heterogeneousC] (|> gen-primitive + [outputT outputC] _primitive.primitive + [heterogeneousT heterogeneousC] (|> _primitive.primitive (r.filter (|>> product.left (tc.checks? outputT) not))) exhaustive-patterns (exhaustive-branches true variantTC inputC) redundant-patterns (exhaustive-branches false variantTC inputC) redundancy-idx (|> r.nat (:: @ map (n/% (list.size redundant-patterns)))) heterogeneous-idx (|> r.nat (:: @ map (n/% (list.size exhaustive-patterns)))) - #let [exhaustive-branchesC (L/map (branch outputC) - exhaustive-patterns) - non-exhaustive-branchesC (list.take (n/dec (list.size exhaustive-branchesC)) + #let [exhaustive-branchesC (list/map (branch outputC) + exhaustive-patterns) + non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC)) exhaustive-branchesC) - redundant-branchesC (<| (L/map (branch outputC)) + redundant-branchesC (<| (list/map (branch outputC)) list.concat (list (list.take redundancy-idx redundant-patterns) (list (maybe.assume (list.nth redundancy-idx redundant-patterns))) @@ -165,32 +163,32 @@ heterogeneous-branchesC (list.concat (list (list.take 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))) - analyse-pm (|>> (@.analyse-case analyse inputC) - (&.with-type outputT) - &.with-scope + (list.drop (inc heterogeneous-idx) exhaustive-branchesC))) + analyse-pm (|>> (/.case _primitive.analyse inputC) + (typeA.with-type outputT) + lang.with-scope (do Monad<Meta> - [_ (@module.declare-tags variant-tags false + [_ (moduleL.declare-tags variant-tags false (#.Named [module-name variant-name] (type.variant primitivesT))) - _ (@module.declare-tags record-tags false + _ (moduleL.declare-tags record-tags false (#.Named [module-name record-name] (type.tuple primitivesT)))]) - (@module.with-module +0 module-name))]] + (moduleL.with-module +0 module-name))]] ($_ seq (test "Will reject empty pattern-matching (no branches)." (|> (analyse-pm (list)) - check-failure)) + _structure.check-fails)) (test "Can analyse exhaustive pattern-matching." (|> (analyse-pm exhaustive-branchesC) - check-success)) + _structure.check-succeeds)) (test "Will reject non-exhaustive pattern-matching." (|> (analyse-pm non-exhaustive-branchesC) - check-failure)) + _structure.check-fails)) (test "Will reject redundant pattern-matching." (|> (analyse-pm redundant-branchesC) - check-failure)) + _structure.check-fails)) (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." (|> (analyse-pm heterogeneous-branchesC) - check-failure)) + _structure.check-fails)) )))) |