- Adjusted compiler to the new lack of Char type.

- WIP: PM/case synthesis.

10 files changed, 301 insertions, 42 deletions

diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux
index 037f99feb..280c52245 100644
--- a/new-luxc/test/test/luxc/analyser/case.lux
+++ b/new-luxc/test/test/luxc/analyser/case.lux
@@ -62,7 +62,6 @@
      [#;Int  r;int       code;int]
      [#;Deg  r;deg       code;deg]
      [#;Real r;real      code;real]
-     [#;Char r;char      code;char]
      [#;Text (r;text +5) code;text])
     
     (^ [_ (#;Tuple (list))])
diff --git a/new-luxc/test/test/luxc/analyser/common.lux b/new-luxc/test/test/luxc/analyser/common.lux
index 9a17fbb45..683ede10f 100644
--- a/new-luxc/test/test/luxc/analyser/common.lux
+++ b/new-luxc/test/test/luxc/analyser/common.lux
@@ -25,7 +25,6 @@
                     [Int  code;int   r;int]
                     [Deg  code;deg   r;deg]
                     [Real code;real  r;real]
-                    [Char code;char  r;char]
                     [Text code;text  (r;text +5)]
                     )]
     ($_ r;either
diff --git a/new-luxc/test/test/luxc/analyser/primitive.lux b/new-luxc/test/test/luxc/analyser/primitive.lux
index 545b4e0fd..f291e2c7f 100644
--- a/new-luxc/test/test/luxc/analyser/primitive.lux
+++ b/new-luxc/test/test/luxc/analyser/primitive.lux
@@ -4,7 +4,6 @@
        (control monad
                 pipe)
        (data [bool "B/" Eq<Bool>]
-             [char "C/" Eq<Char>]
              [text "T/" Eq<Text>]
              (text format
                    ["l" lexer])
@@ -33,7 +32,6 @@
    %int% r;int
    %deg% r;deg
    %real% r;real
-   %char% r;char
    %text% (r;text +5)]
   (with-expansions
     [<tests> (do-template [<desc> <type> <tag> <value> <analyser>]
@@ -55,7 +53,6 @@
                ["int"  Int  #~;Int  %int%  @;analyse-int]
                ["deg"  Deg  #~;Deg  %deg%  @;analyse-deg]
                ["real" Real #~;Real %real% @;analyse-real]
-               ["char" Char #~;Char %char% @;analyse-char]
                ["text" Text #~;Text %text% @;analyse-text]
                )]
     ($_ seq
diff --git a/new-luxc/test/test/luxc/generator/primitive.lux b/new-luxc/test/test/luxc/generator/primitive.lux
index b1ea17f95..134ff312d 100644
--- a/new-luxc/test/test/luxc/generator/primitive.lux
+++ b/new-luxc/test/test/luxc/generator/primitive.lux
@@ -6,7 +6,6 @@
        (data text/format
              ["R" result]
              [bool "B/" Eq<Bool>]
-             [char "C/" Eq<Char>]
              [text "T/" Eq<Text>])
        ["r" math/random "R/" Monad<Random>]
        [macro]
@@ -26,7 +25,6 @@
    %int% r;int
    %deg% r;deg
    %real% r;real
-   %char% r;char
    %text% (r;text +5)]
   (with-expansions
     [<tests> (do-template [<desc> <type> <synthesis> <sample> <test>]
@@ -44,7 +42,6 @@
                ["int"  Int  #ls;Int  %int%  i.=]
                ["deg"  Deg  #ls;Deg  %deg%  d.=]
                ["real" Real #ls;Real %real% r.=]
-               ["char" Char #ls;Char %char% C/=]
                ["text" Text #ls;Text %text% T/=])]
     ($_ seq
         (test "Can generate unit."
diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux
index 1fcba59d4..51c6c80c7 100644
--- a/new-luxc/test/test/luxc/generator/structure.lux
+++ b/new-luxc/test/test/luxc/generator/structure.lux
@@ -6,7 +6,6 @@
        (data text/format
              ["R" result]
              [bool "B/" Eq<Bool>]
-             [char "C/" Eq<Char>]
              [text "T/" Eq<Text>]
              (coll ["a" array]
                    [list]))
@@ -33,8 +32,7 @@
                                 (r/map (|>. #ls;Int) r;int)))
             (r;either (r;either (r/map (|>. #ls;Deg) r;deg)
                                 (r/map (|>. #ls;Real) r;real))
-                      (r;either (r/map (|>. #ls;Char) r;char)
-                                (r/map (|>. #ls;Text) (r;text +5))))))
+                      (r/map (|>. #ls;Text) (r;text +5)))))
 
 (def: (corresponds? [prediction sample])
   (-> [ls;Synthesis Top] Bool)
@@ -55,7 +53,6 @@
      [#ls;Int  Int i.=]
      [#ls;Deg  Deg d.=]
      [#ls;Real Real r.=]
-     [#ls;Char Char C/=]
      [#ls;Text Text T/=])
 
     _
diff --git a/new-luxc/test/test/luxc/parser.lux b/new-luxc/test/test/luxc/parser.lux
index 21d34f7c0..b7eaa0ea5 100644
--- a/new-luxc/test/test/luxc/parser.lux
+++ b/new-luxc/test/test/luxc/parser.lux
@@ -2,8 +2,7 @@
   lux
   (lux [io]
        (control monad)
-       (data [char "C/" Eq<Char>]
-             [text "T/" Eq<Text>]
+       (data [text "T/" Eq<Text>]
              (text format
                    ["l" lexer])
              [number]
@@ -27,9 +26,9 @@
            delimiters "()[]{}#;"
            space "\t\v \n\r\f"
            invalid-range (format digits delimiters space)
-           char-gen (|> r;char
+           char-gen (|> r;nat
                         (r;filter (function [sample]
-                                    (not (text;contains? (char;as-text sample)
+                                    (not (text;contains? (text;from-code sample)
                                                          invalid-range)))))]
      size (|> r;nat (:: @ map (|>. (n.% +20) (n.max +1))))]
     (r;text' char-gen size)))
@@ -49,7 +48,6 @@
                         (|> r;real (r/map (|>. #;Real [default-cursor])))))
         textual^ (: (r;Random Code)
                     ($_ r;either
-                        (|> r;char (r/map (|>. #;Char [default-cursor])))
                         (do r;Monad<Random>
                           [size (|> r;nat (r/map (n.% +20)))]
                           (|> (r;text size) (r/map (|>. #;Text [default-cursor]))))
@@ -89,12 +87,11 @@
 
 (def: comment-text^
   (r;Random Text)
-  (let [char-gen (|> r;char (r;filter (function [value]
-                                        (not (or (char;space? value)
-                                                 (C/= #"\n" value)
-                                                 (C/= #"#" value)
-                                                 (C/= #"(" value)
-                                                 (C/= #")" value))))))]
+  (let [char-gen (|> r;nat (r;filter (function [value]
+                                       (not (or (text;space? value)
+                                                (n.= (char "#") value)
+                                                (n.= (char "(") value)
+                                                (n.= (char ")") value))))))]
     (do r;Monad<Random>
       [size (|> r;nat (r/map (n.% +20)))]
       (r;text' char-gen size))))
@@ -112,10 +109,9 @@
 
 (context: "Multi-line text & comments."
   #seed +13835085537605735783
-  [#let [char-gen (|> r;char (r;filter (function [value]
-                                         (not (or (char;space? value)
-                                                  (C/= #"\"" value)
-                                                  (C/= #"\n" value))))))]
+  [#let [char-gen (|> r;nat (r;filter (function [value]
+                                        (not (or (text;space? value)
+                                                 (n.= (char "\"") value))))))]
    x char-gen
    y char-gen
    z char-gen
@@ -126,9 +122,9 @@
    unbalanced-comment comment-text^]
   ($_ seq
       (test "Will reject invalid multi-line text."
-            (let [bad-match (format (char;as-text x) "\n"
-                                    (char;as-text y) "\n"
-                                    (char;as-text z))]
+            (let [bad-match (format (text;from-code x) "\n"
+                                    (text;from-code y) "\n"
+                                    (text;from-code z))]
               (case (&;parse [default-cursor
                               (format "\"" bad-match "\"")])
                 (#R;Error error)
@@ -137,12 +133,12 @@
                 (#R;Success [_ parsed])
                 false)))
       (test "Will accept valid multi-line text"
-            (let [good-input (format (char;as-text x) "\n"
-                                     offset (char;as-text y) "\n"
-                                     offset (char;as-text z))
-                  good-output (format (char;as-text x) "\n"
-                                      (char;as-text y) "\n"
-                                      (char;as-text z))]
+            (let [good-input (format (text;from-code x) "\n"
+                                     offset (text;from-code y) "\n"
+                                     offset (text;from-code z))
+                  good-output (format (text;from-code x) "\n"
+                                      (text;from-code y) "\n"
+                                      (text;from-code z))]
               (case (&;parse [(|> default-cursor
                                   (update@ #;column (n.+ (n.dec offset-size))))
                               (format "\"" good-input "\"")])
diff --git a/new-luxc/test/test/luxc/synthesizer/case.lux b/new-luxc/test/test/luxc/synthesizer/case.lux
new file mode 100644
index 000000000..5e1cf2a32
--- /dev/null
+++ b/new-luxc/test/test/luxc/synthesizer/case.lux
@@ -0,0 +1,213 @@
+(;module:
+  lux
+  (lux [io]
+       (control monad
+                pipe
+                eq)
+       (data [bool "B/" Eq<Bool>]
+             [text "T/" Eq<Text>]
+             [product]
+             [number]
+             text/format
+             (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
+                   ["s" set]))
+       ["r" math/random "r/" Monad<Random>]
+       test)
+  (luxc (lang ["la" analysis]
+              ["ls" synthesis])
+        [synthesizer]
+        (synthesizer ["@" case]))
+  (.. common))
+
+(struct: _ (Eq ls;Synthesis)
+  (def: (= reference sample)
+    (case [reference sample]
+      (^template [<tag> <test>]
+        [(<tag> reference') (<tag> sample')]
+        (<test> reference' sample'))
+      ([#ls;Unit is]
+       [#ls;Bool B/=]
+       [#ls;Nat  n.=]
+       [#ls;Int  i.=]
+       [#ls;Deg  d.=]
+       [#ls;Real r.=]
+       [#ls;Text T/=])
+
+      _
+      false)))
+
+(struct: _ (Eq ls;Path)
+  (def: (= reference sample)
+    (case [reference sample]
+      (^or [#ls;UnitP #ls;UnitP]
+           [(#ls;ExecP _) (#ls;ExecP _)])
+      true
+
+      (^template [<tag> <eq>]
+        [(<tag> reference') (<tag> sample')]
+        (<eq> reference' sample'))
+      ([#ls;BindP n.=]
+       [#ls;BoolP B/=]
+       [#ls;NatP  n.=]
+       [#ls;IntP  i.=]
+       [#ls;DegP  d.=]
+       [#ls;RealP r.=]
+       [#ls;TextP T/=])
+
+      (^template [<outer> <inner>]
+        [(<outer> (<inner> reference') reference-then)
+         (<outer> (<inner> sample') sample-then)]
+        (and (n.= reference' sample')
+             (= reference-then sample-then)))
+      ([#ls;VariantP #;Left]
+       [#ls;VariantP #;Right]
+       [#ls;TupleP   #;Left]
+       [#ls;TupleP   #;Right])
+      
+      (^template [<tag>]
+        [(<tag> referenceL referenceR) (<tag> sampleL sampleR)]
+        (and (= referenceL sampleL)
+             (= referenceR sampleR)))
+      ([#ls;AltP]
+       [#ls;SeqP])
+      
+      _
+      false)))
+
+(do-template [<name> <path> <sampler> <hash> <max>]
+  [(def: <name>
+     (r;Random ls;Path)
+     (do r;Monad<Random>
+       [num-alts (|> r;nat (:: @ map (|>. (n.% <max>) (n.max +1))))
+        samples (|> (r;set <hash> num-alts <sampler>)
+                    (:: @ map s;to-list))]
+       (case (|> samples
+                 (L/map (|>. <path>))
+                 list;reverse)
+         (#;Cons last prevs)
+         (wrap (L/fold (function [left right]
+                         (#ls;AltP left right))
+                       last
+                       prevs))
+
+         #;Nil
+         (undefined))))]
+
+  [gen-bool #ls;BoolP r;bool      bool;Hash<Bool>   +2]
+  [gen-nat  #ls;NatP  r;nat       number;Hash<Nat>  +5]
+  [gen-int  #ls;IntP  r;int       number;Hash<Int>  +5]
+  [gen-deg  #ls;DegP  r;deg       number;Hash<Deg>  +5]
+  [gen-real #ls;RealP r;real      number;Hash<Real> +5]
+  [gen-text #ls;TextP (r;text +5) text;Hash<Text>   +5]
+  )
+
+(def: gen-primitive-path
+  (r;Random ls;Path)
+  (r;either (r;either (r;either (r/wrap #ls;UnitP)
+                                gen-bool)
+                      (r;either gen-nat
+                                gen-int))
+            (r;either (r;either gen-deg
+                                gen-real)
+                      gen-text)))
+
+(do-template [<name> <tag> <join>]
+  [(def: (<name> gen-path)
+     (-> (-> (Maybe ls;Synthesis) (r;Random ls;Path))
+         (r;Random ls;Path))
+     (do r;Monad<Random>
+       [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2))))
+        members (r;list size (gen-path #;None))]
+       (case (list;reverse (list;enumerate members))
+         (#;Cons [last-idx last-path] prevs)
+         (wrap (L/fold (function [[left-idx left-path] right-path]
+                         (<join> (<tag> (#;Right left-idx) left-path)
+                                 right-path))
+                       (<tag> (#;Right last-idx) last-path)
+                       prevs))
+
+         #;Nil
+         (undefined))))]
+
+  [gen-tuple-path   #ls;TupleP   #ls;SeqP]
+  [gen-variant-path #ls;VariantP #ls;AltP]
+  )
+
+(def: (gen-path ?body)
+  (-> (Maybe ls;Synthesis) (r;Random ls;Path))
+  (do r;Monad<Random>
+    [pattern (r;either (r;either (r/wrap (#ls;BindP +0))
+                                 gen-primitive-path)
+                       (r;either (gen-tuple-path gen-path)
+                                 (gen-variant-path gen-path)))]
+    (case ?body
+      #;None
+      (wrap pattern)
+
+      (#;Some body)
+      (wrap (#ls;SeqP pattern (#ls;ExecP body))))))
+
+(def: (to-branches path)
+  (-> ls;Path (List la;Pattern))
+  (case path
+    (^template [<from> <to>]
+      (<from> value)
+      (list (<to> value)))
+    ([#ls;UnitP #la;UnitP]
+     [#ls;BoolP #la;BoolP]
+     [#ls;NatP  #la;NatP]
+     [#ls;IntP  #la;IntP]
+     [#ls;DegP  #la;DegP]
+     [#ls;RealP #la;RealP]
+     [#ls;TextP #la;TextP]
+     [#ls;BindP #la;BindP])
+
+    (#ls;AltP left right)
+    (L/append (to-branches left)
+              (to-branches right))
+
+    (#ls;SeqP (#ls;TupleP (#;Left +0) head)
+              tail)
+    (loop [head head
+           tail tail]
+      (case [(path-to-pattern head) tail]
+        [(#;Some =head) (#ls;SeqP (#ls;TupleP (#;Left idx) head')
+                                  tail')]
+        (list& =head (recur head' tail'))
+
+        [(#;Some =head) (#ls;SeqP (#ls;TupleP (#;Left idx) head')
+                                  tail')]
+        (list& =head (recur head' tail'))
+
+        [(#;Some =head) (#ls;SeqP (#ls;TupleP (#;Right last-idx))
+                                  tail')]
+        (do list;Monad<List>
+          [=tail' (to-branches tail')
+           =right (to-branches right)]
+          )))
+
+    (#ls;SeqP left right)
+    (do list;Monad<List>
+      [=left (to-branches left)
+       =right (to-branches right)]
+      )
+
+    #PopP
+    (#VariantP (Either Nat Nat))
+    (#TupleP (Either Nat Nat))
+    
+    
+    (#ExecP s)
+    ))
+
+(context: "Pattern-matching."
+  [outputA gen-primitive
+   prediction (gen-path (#;Some (synthesizer;synthesize outputA)))
+   #let [branches (to-branches outputA prediction)]]
+  (test "Can efficiently synthesize pattern-matching trees."
+        (|> (synthesizer;synthesize (#la;Case #la;Unit branches))
+            (case> (#la;Case #ls;Unit pathS)
+                   (:: Eq<Path> prediction pathS)
+
+                   _
+                   false))))
diff --git a/new-luxc/test/test/luxc/synthesizer/case/special.lux b/new-luxc/test/test/luxc/synthesizer/case/special.lux
new file mode 100644
index 000000000..fe5ad20ac
--- /dev/null
+++ b/new-luxc/test/test/luxc/synthesizer/case/special.lux
@@ -0,0 +1,66 @@
+(;module:
+  lux
+  (lux [io]
+       (control monad
+                pipe)
+       (data [product]
+             [number]
+             text/format
+             (coll [list "L/" Functor<List> Fold<List>]
+                   ["D" dict]
+                   ["s" set]))
+       ["r" math/random "r/" Monad<Random>]
+       test)
+  (luxc (lang ["la" analysis]
+              ["ls" synthesis])
+        [synthesizer])
+  (../.. common))
+
+(context: "Dummy variables."
+  [maskedA gen-primitive
+   temp r;nat
+   #let [maskA (#la;Case maskedA
+                         (list [(#la;BindP temp)
+                                (#la;Relative (#;Local temp))]))]]
+  (test "Dummy variables created to mask expressions get eliminated during synthesis."
+        (|> (synthesizer;synthesize maskA)
+            (corresponds? maskedA))))
+
+(context: "Let expressions."
+  [registerA r;nat
+   inputA gen-primitive
+   outputA gen-primitive
+   #let [letA (#la;Case inputA
+                        (list [(#la;BindP registerA)
+                               outputA]))]]
+  (test "Can detect and reify simple 'let' expressions."
+        (|> (synthesizer;synthesize letA)
+            (case> (#ls;Let registerS inputS outputS)
+                   (and (n.= registerA registerS)
+                        (corresponds? inputA inputS)
+                        (corresponds? outputA outputS))
+
+                   _
+                   false))))
+
+(context: "If expressions."
+  [then|else r;bool
+   inputA gen-primitive
+   thenA gen-primitive
+   elseA gen-primitive
+   #let [ifA (if then|else
+               (#la;Case inputA
+                         (list [(#la;BoolP true) thenA]
+                               [(#la;BoolP false) elseA]))
+               (#la;Case inputA
+                         (list [(#la;BoolP false) elseA]
+                               [(#la;BoolP true) thenA])))]]
+  (test "Can detect and reify simple 'if' expressions."
+        (|> (synthesizer;synthesize ifA)
+            (case> (#ls;If inputS thenS elseS)
+                   (and (corresponds? inputA inputS)
+                        (corresponds? thenA thenS)
+                        (corresponds? elseA elseS))
+
+                   _
+                   false))))
diff --git a/new-luxc/test/test/luxc/synthesizer/common.lux b/new-luxc/test/test/luxc/synthesizer/common.lux
index c02e23c7c..88eeaea7c 100644
--- a/new-luxc/test/test/luxc/synthesizer/common.lux
+++ b/new-luxc/test/test/luxc/synthesizer/common.lux
@@ -1,7 +1,6 @@
 (;module:
   lux
   (lux (data [bool "B/" Eq<Bool>]
-             [char "C/" Eq<Char>]
              [text "T/" Eq<Text>])
        ["r" math/random "r/" Monad<Random>])
   (luxc (lang ["la" analysis]
@@ -15,8 +14,7 @@
                                 (r/map (|>. #la;Int) r;int)))
             (r;either (r;either (r/map (|>. #la;Deg) r;deg)
                                 (r/map (|>. #la;Real) r;real))
-                      (r;either (r/map (|>. #la;Char) r;char)
-                                (r/map (|>. #la;Text) (r;text +5))))))
+                      (r/map (|>. #la;Text) (r;text +5)))))
 
 (def: #export (corresponds? analysis synthesis)
   (-> la;Analysis ls;Synthesis Bool)
@@ -30,7 +28,6 @@
      [#la;Int  #ls;Int  i.=]
      [#la;Deg  #ls;Deg  d.=]
      [#la;Real #ls;Real r.=]
-     [#la;Char #ls;Char C/=]
      [#la;Text #ls;Text T/=])
 
     _
diff --git a/new-luxc/test/test/luxc/synthesizer/primitive.lux b/new-luxc/test/test/luxc/synthesizer/primitive.lux
index c17d41a78..e1e37e469 100644
--- a/new-luxc/test/test/luxc/synthesizer/primitive.lux
+++ b/new-luxc/test/test/luxc/synthesizer/primitive.lux
@@ -17,7 +17,6 @@
    %int% r;int
    %deg% r;deg
    %real% r;real
-   %char% r;char
    %text% (r;text +5)]
   (with-expansions
     [<tests> (do-template [<desc> <analysis> <synthesis> <sample>]
@@ -35,7 +34,6 @@
                ["int"  #la;Int  #ls;Int  %int%]
                ["deg"  #la;Deg  #ls;Deg  %deg%]
                ["real" #la;Real #ls;Real %real%]
-               ["char" #la;Char #ls;Char %char%]
                ["text" #la;Text #ls;Text %text%])]
     ($_ seq
         <tests>)))