1 files changed, 105 insertions, 0 deletions
diff --git a/new-luxc/test/test/luxc/lang/translation/jvm/case.lux b/new-luxc/test/test/luxc/lang/translation/jvm/case.lux
new file mode 100644
index 000000000..91071be6c
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/jvm/case.lux
@@ -0,0 +1,105 @@
+(.module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (data ["e" error]
+             text/format
+             (coll [list]))
+       ["r" math/random "r/" Monad<Random>]
+       [macro]
+       (macro [code])
+       test)
+  (luxc [lang]
+        (lang ["ls" synthesis]
+              (translation (jvm ["@" case]
+                                [".T" expression]
+                                ["@." eval]
+                                ["@." runtime]
+                                ["@." common]))))
+  (test/luxc common))
+
+(def: struct-limit Nat +10)
+
+(def: (tail? size idx)
+  (-> Nat Nat Bool)
+  (n/= (n/dec size) idx))
+
+(def: gen-case
+  (r.Random [ls.Synthesis ls.Path])
+  (<| r.rec (function [gen-case])
+      (`` ($_ r.either
+              (r/wrap [(' []) (' ("lux case pop"))])
+              (~~ (do-template [<gen> <synth>]
+                    [(do r.Monad<Random>
+                       [value <gen>]
+                       (wrap [(<synth> value) (<synth> value)]))]
+
+                    [r.bool code.bool]
+                    [r.nat code.nat]
+                    [r.int code.int]
+                    [r.deg code.deg]
+                    [r.frac code.frac]
+                    [(r.text +5) code.text]))
+              (do r.Monad<Random>
+                [size (|> r.nat (:: @ map (|>> (n/% struct-limit) (n/max +2))))
+                 idx (|> r.nat (:: @ map (n/% size)))
+                 [subS subP] gen-case
+                 #let [caseS (` [(~+ (list.concat (list (list.repeat idx (' []))
+                                                        (list subS)
+                                                        (list.repeat (|> size n/dec (n/- idx)) (' [])))))])
+                       caseP (if (tail? size idx)
+                               (` ("lux case tuple right" (~ (code.nat idx)) (~ subP)))
+                               (` ("lux case tuple left" (~ (code.nat idx)) (~ subP))))]]
+                (wrap [caseS caseP]))
+              (do r.Monad<Random>
+                [size (|> r.nat (:: @ map (|>> (n/% struct-limit) (n/max +2))))
+                 idx (|> r.nat (:: @ map (n/% size)))
+                 [subS subP] gen-case
+                 #let [caseS (` ((~ (code.nat idx)) (~ (code.bool (tail? size idx))) (~ subS)))
+                       caseP (if (tail? size idx)
+                               (` ("lux case variant right" (~ (code.nat idx)) (~ subP)))
+                               (` ("lux case variant left" (~ (code.nat idx)) (~ subP))))]]
+                (wrap [caseS caseP]))
+              ))))
+
+(context: "Pattern-matching."
+  (<| (seed +517905247826)
+      ## (times +100)
+      (do @
+        [[valueS pathS] gen-case
+         to-bind r.nat]
+        ($_ seq
+            (test "Can translate pattern-matching."
+                  (|> (do macro.Monad<Meta>
+                        [runtime-bytecode @runtime.translate
+                         sampleI (@.translate-case expressionT.translate
+                                                   valueS
+                                                   (` ("lux case alt"
+                                                       ("lux case seq" (~ pathS)
+                                                        ("lux case exec" true))
+                                                       ("lux case seq" ("lux case bind" +0)
+                                                        ("lux case exec" false)))))]
+                        (@eval.eval sampleI))
+                      (lang.with-current-module "")
+                      (macro.run (init-compiler []))
+                      (case> (#e.Success valueT)
+                             (:! Bool valueT)
+
+                             (#e.Error error)
+                             false)))
+            (test "Can bind values."
+                  (|> (do macro.Monad<Meta>
+                        [runtime-bytecode @runtime.translate
+                         sampleI (@.translate-case expressionT.translate
+                                                   (code.nat to-bind)
+                                                   (` ("lux case seq" ("lux case bind" +0)
+                                                       ("lux case exec" (0)))))]
+                        (@eval.eval sampleI))
+                      (lang.with-current-module "")
+                      (macro.run (init-compiler []))
+                      (case> (#e.Success valueT)
+                             (n/= to-bind (:! Nat valueT))
+
+                             _
+                             false)))))))