- Added pattern-matching compilation.

3 files changed, 114 insertions, 11 deletions

diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux
index 3c05f5dad..983dff6f5 100644
--- a/new-luxc/test/test/luxc/analyser/case.lux
+++ b/new-luxc/test/test/luxc/analyser/case.lux
@@ -40,7 +40,7 @@
        head head+]
       (wrap (#;Cons head tail+)))))
 
-(def: (exhaustive-branches-for allow-literals? variantTC inputC)
+(def: #export (exhaustive-branches allow-literals? variantTC inputC)
   (-> Bool (List [Code Code]) Code (r;Random (List Code)))
   (case inputC
     [_ (#;Bool _)]
@@ -54,7 +54,7 @@
           (case ?sample
             (#;Some sample)
             (do @
-              [else (exhaustive-branches-for allow-literals? variantTC inputC)]
+              [else (exhaustive-branches allow-literals? variantTC inputC)]
               (wrap (list& (<wrapper> sample) else)))
 
             #;None
@@ -74,7 +74,7 @@
 
     [_ (#;Tuple members)]
     (do r;Monad<Random>
-      [member-wise-patterns (monad;map @ (exhaustive-branches-for allow-literals? variantTC) members)]
+      [member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) members)]
       (wrap (|> member-wise-patterns
                 exhaustive-weaving
                 (L/map code;tuple))))
@@ -83,7 +83,7 @@
     (do r;Monad<Random>
       [#let [ks (L/map product;left kvs)
              vs (L/map product;right kvs)]
-       member-wise-patterns (monad;map @ (exhaustive-branches-for allow-literals? variantTC) vs)]
+       member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) vs)]
       (wrap (|> member-wise-patterns
                 exhaustive-weaving
                 (L/map (|>. (list;zip2 ks) code;record)))))
@@ -93,7 +93,7 @@
       [bundles (monad;map @
                           (function [[_tag _code]]
                             (do @
-                              [v-branches (exhaustive-branches-for allow-literals? variantTC _code)]
+                              [v-branches (exhaustive-branches allow-literals? variantTC _code)]
                               (wrap (L/map (function [pattern] (` ((~ _tag) (~ pattern))))
                                            v-branches))))
                           variantTC)]
@@ -103,10 +103,10 @@
     (r/wrap (list))
     ))
 
-(def: (gen-input variant-tags record-tags primitivesC)
+(def: #export (input variant-tags record-tags primitivesC)
   (-> (List Code) (List Code) (List Code) (r;Random Code))
   (r;rec
-   (function [gen-input]
+   (function [input]
      ($_ r;either
          (r/map product;right gen-primitive)
          (do r;Monad<Random>
@@ -116,7 +116,7 @@
            (wrap (` ((~ choiceT) (~ choiceC)))))
          (do r;Monad<Random>
            [size (|> r;nat (:: @ map (n.% +3)))
-            elems (r;list size gen-input)]
+            elems (r;list size input)]
            (wrap (code;tuple elems)))
          (r/wrap (code;record (list;zip2 record-tags primitivesC)))
          ))))
@@ -141,12 +141,12 @@
          variant-tags+ (L/map (|>. [module-name] code;tag) variant-tags)
          record-tags+ (L/map (|>. [module-name] code;tag) record-tags)
          variantTC (list;zip2 variant-tags+ primitivesC)]
-   inputC (gen-input variant-tags+ record-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-for true variantTC inputC)
-   redundant-patterns (exhaustive-branches-for false variantTC inputC)
+   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)
diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux
new file mode 100644
index 000000000..9e6dbf928
--- /dev/null
+++ b/new-luxc/test/test/luxc/generator/case.lux
@@ -0,0 +1,102 @@
+(;module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (data text/format
+             [product]
+             ["R" result]
+             [bool "B/" Eq<Bool>]
+             [text "T/" Eq<Text>]
+             (coll ["a" array]
+                   [list "L/" Functor<List>]
+                   ["S" set]))
+       ["r" math/random "r/" Monad<Random>]
+       [macro #+ Monad<Lux>]
+       (macro [code])
+       [host]
+       test)
+  (luxc (lang ["ls" synthesis])
+        [analyser]
+        [synthesizer]
+        (generator ["@" case]
+                   ["@;" 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])
+      (with-expansions [<simple> (do-template [<gen> <synth> <path>]
+                                   [(do r;Monad<Random>
+                                      [value <gen>]
+                                      (wrap [(<synth> value) (<path> value)]))]
+
+                                   [r;bool #ls;Bool #ls;BoolP]
+                                   [r;nat #ls;Nat #ls;NatP]
+                                   [r;int #ls;Int #ls;IntP]
+                                   [r;deg #ls;Deg #ls;DegP]
+                                   [r;frac #ls;Frac #ls;FracP]
+                                   [(r;text +5) #ls;Text #ls;TextP])]
+        ($_ r;either
+            (r/wrap [#ls;Unit #ls;UnitP])
+            <simple>
+            (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 [dummyS (list;repeat (n.dec size) #ls;Unit)
+                     caseS (#ls;Tuple (list;concat (list (list;take idx dummyS)
+                                                         (list subS)
+                                                         (list;drop idx dummyS))))
+                     caseP (#ls;TupleP (if (tail? idx idx)
+                                         (#;Right idx)
+                                         (#;Left 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 (#ls;Variant idx (tail? idx idx) subS)
+                     caseP (#ls;VariantP (if (tail? idx idx)
+                                           (#;Right idx)
+                                           (#;Left idx))
+                                         subP)]]
+              (wrap [caseS caseP]))
+            ))))
+
+(context: "Pattern-matching."
+  [[valueS path] gen-case
+   to-bind r;nat]
+  ($_ seq
+      (test "Can generate pattern-matching."
+            (|> (do Monad<Lux>
+                  [runtime-bytecode @runtime;generate]
+                  (@eval;eval (@;generate valueS
+                                          (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true)))
+                                                    (#ls;SeqP (#ls;BindP +0) (#ls;ExecP (#ls;Bool false)))))))
+                (macro;run (init-compiler []))
+                (case> (#R;Success valueG)
+                       (:! Bool valueG)
+
+                       _
+                       false)))
+      (test "Can bind values."
+            (|> (do Monad<Lux>
+                  [runtime-bytecode @runtime;generate]
+                  (@eval;eval (@;generate (#ls;Nat to-bind)
+                                          (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1))))))
+                (macro;run (init-compiler []))
+                (case> (#R;Success valueG)
+                       (n.= to-bind (:! Nat valueG))
+
+                       _
+                       false)))))
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index 06f3e940e..d07822069 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -20,6 +20,7 @@
                            ["_;S" loop])
               (generator ["_;G" primitive]
                          ["_;G" structure]
+                         ["_;G" case]
                          (procedure ["_;G" common]))
               ))
   ## (luxc (generator ["_;G" function]))