- Migrated pattern-matching analysis to stdlib.

2 files changed, 0 insertions, 227 deletions

diff --git a/new-luxc/test/test/luxc/lang/analysis/case.lux b/new-luxc/test/test/luxc/lang/analysis/case.lux
deleted file mode 100644
index 63dd60e14..000000000
--- a/new-luxc/test/test/luxc/lang/analysis/case.lux
+++ /dev/null
@@ -1,196 +0,0 @@
-(.module:
-  lux
-  (lux [io]
-       (control [monad #+ do]
-                pipe)
-       (data [bool "B/" Eq<Bool>]
-             ["R" error]
-             [product]
-             [maybe]
-             [text "T/" Eq<Text>]
-             text/format
-             (coll [list "L/" Monad<List>]
-                   (set ["set" unordered])))
-       ["r" math/random "r/" Monad<Random>]
-       [macro #+ Monad<Meta>]
-       (macro [code])
-       (lang [type "type/" Eq<Type>]
-             (type ["tc" check]))
-       test)
-  (luxc ["&" lang]
-        (lang ["@." module]
-              ["la" analysis]
-              (analysis [".A" expression]
-                        ["@" case]
-                        ["@." common])))
-  (// common)
-  (test/luxc common))
-
-(def: (exhaustive-weaving branchings)
-  (-> (List (List Code)) (List (List Code)))
-  (case branchings
-    #.Nil
-    #.Nil
-
-    (#.Cons head+ #.Nil)
-    (L/map (|>> list) head+)
-
-    (#.Cons head+ tail++)
-    (do list.Monad<List>
-      [tail+ (exhaustive-weaving tail++)
-       head head+]
-      (wrap (#.Cons head tail+)))))
-
-(def: #export (exhaustive-branches allow-literals? variantTC inputC)
-  (-> Bool (List [Code Code]) Code (r.Random (List Code)))
-  (case inputC
-    [_ (#.Bool _)]
-    (r/wrap (list (' true) (' false)))
-
-    (^template [<tag> <gen> <wrapper>]
-      [_ (<tag> _)]
-      (if allow-literals?
-        (do r.Monad<Random>
-          [?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]
-     [#.Deg  r.deg       code.deg]
-     [#.Frac r.frac      code.frac]
-     [#.Text (r.text +5) code.text])
-    
-    (^ [_ (#.Tuple (list))])
-    (r/wrap (list (' [])))
-
-    (^ [_ (#.Record (list))])
-    (r/wrap (list (' {})))
-
-    [_ (#.Tuple members)]
-    (do r.Monad<Random>
-      [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)]
-      (wrap (|> member-wise-patterns
-                exhaustive-weaving
-                (L/map code.tuple))))
-
-    [_ (#.Record kvs)]
-    (do r.Monad<Random>
-      [#let [ks (L/map product.left kvs)
-             vs (L/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)))))
-
-    (^ [_ (#.Form (list [_ (#.Tag _)] _))])
-    (do r.Monad<Random>
-      [bundles (monad.map @
-                          (function (_ [_tag _code])
-                            (do @
-                              [v-branches (exhaustive-branches allow-literals? variantTC _code)]
-                              (wrap (L/map (function (_ pattern) (` ((~ _tag) (~ pattern))))
-                                           v-branches))))
-                          variantTC)]
-      (wrap (L/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 gen-primitive)
-         (do r.Monad<Random>
-           [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<Random>
-           [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.text +5)
-         variant-name (r.text +5)
-         record-name (|> (r.text +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)
-               code-tag (|>> [module-name] code.tag)
-               variant-tags+ (L/map code-tag variant-tags)
-               record-tags+ (L/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
-                                             (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))
-                                                   exhaustive-branchesC)
-               redundant-branchesC (<| (L/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 (n/inc heterogeneous-idx) exhaustive-branchesC)))
-               analyse-pm (|>> (@.analyse-case analyse inputC)
-                               (&.with-type outputT)
-                               &.with-scope
-                               (do Monad<Meta>
-                                 [_ (@module.declare-tags variant-tags false
-                                                          (#.Named [module-name variant-name]
-                                                                   (type.variant primitivesT)))
-                                  _ (@module.declare-tags record-tags false
-                                                          (#.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))
-                      check-failure))
-            (test "Can analyse exhaustive pattern-matching."
-                  (|> (analyse-pm exhaustive-branchesC)
-                      check-success))
-            (test "Will reject non-exhaustive pattern-matching."
-                  (|> (analyse-pm non-exhaustive-branchesC)
-                      check-failure))
-            (test "Will reject redundant pattern-matching."
-                  (|> (analyse-pm redundant-branchesC)
-                      check-failure))
-            (test "Will reject pattern-matching if the bodies of the branches do not all have the same type."
-                  (|> (analyse-pm heterogeneous-branchesC)
-                      check-failure))
-            ))))
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]
-  )