aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/test/lux/compiler/default/phase/analysis/case.lux')
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/case.lux198
1 files changed, 0 insertions, 198 deletions
diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux
deleted file mode 100644
index 5c47960c1..000000000
--- a/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux
+++ /dev/null
@@ -1,198 +0,0 @@
-(.module:
- [lux #*
- [control
- ["." monad (#+ do)]
- pipe]
- [data
- ["." product]
- ["." maybe]
- ["." text ("#;." equivalence)]
- [collection
- ["." list ("#;." monad)]
- ["." set]]]
- [math
- ["r" random ("#;." monad)]]
- ["." type
- ["." check]]
- [macro
- ["." code]]
- [compiler
- [default
- ["." phase
- ["." analysis
- ["." module]
- [".A" type]
- ["/" case]]]]]
- test]
- [//
- ["_." primitive]
- ["_." structure]])
-
-(def: (exhaustive-weaving branchings)
- (-> (List (List Code)) (List (List Code)))
- (case branchings
- #.Nil
- #.Nil
-
- (#.Cons head+ #.Nil)
- (list;map (|>> list) head+)
-
- (#.Cons head+ tail++)
- (do list.monad
- [tail+ (exhaustive-weaving tail++)
- head head+]
- (wrap (#.Cons head tail+)))))
-
-(def: #export (exhaustive-branches allow-literals? variantTC inputC)
- (-> Bit (List [Code Code]) Code (r.Random (List Code)))
- (case inputC
- [_ (#.Bit _)]
- (r;wrap (list (' #1) (' #0)))
-
- (^template [<tag> <gen> <wrapper>]
- [_ (<tag> _)]
- (if allow-literals?
- (do r.monad
- [?sample (r.maybe <gen>)]
- (case ?sample
- (#.Some sample)
- (do @
- [else (exhaustive-branches allow-literals? variantTC inputC)]
- (wrap (list& (<wrapper> sample) else)))
-
- #.None
- (wrap (list (' _)))))
- (r;wrap (list (' _)))))
- ([#.Nat r.nat code.nat]
- [#.Int r.int code.int]
- [#.Rev r.rev code.rev]
- [#.Frac r.frac code.frac]
- [#.Text (r.unicode 5) code.text])
-
- (^ [_ (#.Tuple (list))])
- (r;wrap (list (' [])))
-
- (^ [_ (#.Record (list))])
- (r;wrap (list (' {})))
-
- [_ (#.Tuple members)]
- (do r.monad
- [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)]
- (wrap (|> member-wise-patterns
- exhaustive-weaving
- (list;map code.tuple))))
-
- [_ (#.Record kvs)]
- (do r.monad
- [#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
- (list;map (|>> (list.zip2 ks) code.record)))))
-
- (^ [_ (#.Form (list [_ (#.Tag _)] _))])
- (do r.monad
- [bundles (monad.map @
- (function (_ [_tag _code])
- (do @
- [v-branches (exhaustive-branches allow-literals? variantTC _code)]
- (wrap (list;map (function (_ pattern) (` ((~ _tag) (~ pattern))))
- v-branches))))
- variantTC)]
- (wrap (list;join bundles)))
-
- _
- (r;wrap (list))
- ))
-
-(def: #export (input variant-tags record-tags primitivesC)
- (-> (List Code) (List Code) (List Code) (r.Random Code))
- (r.rec
- (function (_ input)
- ($_ r.either
- (r;map product.right _primitive.primitive)
- (do r.monad
- [choice (|> r.nat (:: @ map (n/% (list.size variant-tags))))
- #let [choiceT (maybe.assume (list.nth choice variant-tags))
- choiceC (maybe.assume (list.nth choice primitivesC))]]
- (wrap (` ((~ choiceT) (~ choiceC)))))
- (do r.monad
- [size (|> r.nat (:: @ map (n/% 3)))
- elems (r.list size input)]
- (wrap (code.tuple elems)))
- (r;wrap (code.record (list.zip2 record-tags primitivesC)))
- ))))
-
-(def: (branch body pattern)
- (-> Code Code [Code Code])
- [pattern body])
-
-(context: "Pattern-matching."
- ## #seed 9253409297339902486
- ## #seed 3793366152923578600
- (<| (seed 5004137551292836565)
- ## (times 100)
- (do @
- [module-name (r.unicode 5)
- variant-name (r.unicode 5)
- record-name (|> (r.unicode 5) (r.filter (|>> (text;= variant-name) not)))
- size (|> r.nat (:: @ map (|>> (n/% 10) (n/max 2))))
- variant-tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list))
- record-tags (|> (r.set text.hash 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+ (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] _primitive.primitive
- [heterogeneousT heterogeneousC] (r.filter (|>> product.left (check.checks? outputT) not)
- _primitive.primitive)
- exhaustive-patterns (exhaustive-branches #1 variantTC inputC)
- redundant-patterns (exhaustive-branches #0 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 (list;map (branch outputC)
- exhaustive-patterns)
- non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC))
- exhaustive-branchesC)
- redundant-branchesC (<| (list;map (branch outputC))
- list.concat
- (list (list.take 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] (maybe.assume (list.nth heterogeneous-idx exhaustive-branchesC))]
- [_pattern heterogeneousC]))
- (list.drop (inc heterogeneous-idx) exhaustive-branchesC)))
- analyse-pm (|>> (/.case _primitive.phase inputC)
- (typeA.with-type outputT)
- analysis.with-scope
- (do phase.monad
- [_ (module.declare-tags variant-tags #0
- (#.Named [module-name variant-name]
- (type.variant primitivesT)))
- _ (module.declare-tags record-tags #0
- (#.Named [module-name record-name]
- (type.tuple primitivesT)))])
- (module.with-module 0 module-name))]]
- ($_ seq
- (test "Will reject empty pattern-matching (no branches)."
- (|> (analyse-pm (list))
- _structure.check-fails))
- (test "Can analyse exhaustive pattern-matching."
- (|> (analyse-pm exhaustive-branchesC)
- _structure.check-succeeds))
- (test "Will reject non-exhaustive pattern-matching."
- (|> (analyse-pm non-exhaustive-branchesC)
- _structure.check-fails))
- (test "Will reject redundant pattern-matching."
- (|> (analyse-pm redundant-branchesC)
- _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)
- _structure.check-fails)))
- )))
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-12 19:04:42 +0000