From c0acd75d41ed0e927ec318d4b12c0ec4f5f2e1d3 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sun, 2 Jul 2017 15:52:36 -0400
Subject: - Adjusted compiler to the new lack of Char type. - WIP: PM/case
 synthesis.

---
 new-luxc/source/luxc/synthesizer.lux | 67 ++++++++++++++++++------------------
 1 file changed, 34 insertions(+), 33 deletions(-)

(limited to 'new-luxc/source/luxc/synthesizer.lux')

diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux
index 2f7344c6e..484864652 100644
--- a/new-luxc/source/luxc/synthesizer.lux
+++ b/new-luxc/source/luxc/synthesizer.lux
@@ -2,12 +2,14 @@
   lux
   (lux (data text/format
              [number]
+             [product]
              (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
                    ["d" dict])))
   (luxc ["&" base]
         (lang ["la" analysis]
               ["ls" synthesis])
         (synthesizer ["&&;" structure]
+                     ["&&;" case]
                      ["&&;" function]
                      ["&&;" loop])
         ))
@@ -37,7 +39,6 @@
        [#la;Int      #ls;Int]
        [#la;Deg      #ls;Deg]
        [#la;Real     #ls;Real]
-       [#la;Char     #ls;Char]
        [#la;Text     #ls;Text]
        [#la;Absolute #ls;Definition])
 
@@ -63,6 +64,38 @@
         (#ls;Variable (let [var (&&function;to-captured register)]
                         (default var (d;get var resolver)))))
 
+      (#la;Case inputA branchesA)
+      (let [inputS (recur +0 resolver num-locals inputA)]
+        (case (list;reverse branchesA)
+          (^multi (^ (list [(#la;BindP input-register)
+                            (#la;Relative (#;Local output-register))]))
+                  (n.= input-register output-register))
+          inputS
+
+          (^ (list [(#la;BindP register) bodyA]))
+          (#ls;Let register inputS (recur +0 resolver num-locals bodyA))
+          
+          (^or (^ (list [(#la;BoolP true) thenA] [(#la;BoolP false) elseA]))
+               (^ (list [(#la;BoolP false) elseA] [(#la;BoolP true) thenA])))
+          (#ls;If inputS
+                  (recur +0 resolver num-locals thenA)
+                  (recur +0 resolver num-locals elseA))
+
+          (#;Cons [lastP lastA] prevsPA)
+          (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path)
+                                    (function [pattern expr]
+                                      (|> (recur +0 resolver num-locals expr)
+                                          #ls;ExecP
+                                          (#ls;SeqP (&&case;path pattern)))))]
+            (#ls;Case inputS
+                      (L/fold &&case;weave
+                              (transform-branch lastP lastA)
+                              (L/map (product;uncurry transform-branch) prevsPA))))
+
+          _
+          (undefined)
+          ))
+      
       (#la;Function scope bodyA)
       (let [inner-arity (n.inc outer-arity)
             raw-env (&&function;environment scope)
@@ -111,36 +144,4 @@
 
       (#la;Procedure name args)
       (#ls;Procedure name (L/map (recur +0 resolver num-locals) args))
-
-      _
-      (undefined)
-      
-      ## (#la;Case inputA branchesA)
-      ## (let [inputS (recur +0 local-offset false inputA)]
-      ##   (case branchesA
-      ##     (^multi (^ (list [(#lp;Bind input-register)
-      ##                       (#la;Variable (#;Local output-register))]))
-      ##             (n.= input-register output-register))
-      ##     inputS
-
-      ##     (^ (list [(#lp;Bind register) bodyA]))
-      ##     (#ls;Let register inputS (recur +0 local-offset tail? bodyA))
-      
-      ##     (^or (^ (list [(#lp;Bool true) thenA] [(#lp;Bool false) elseA]))
-      ##          (^ (list [(#lp;Bool false) elseA] [(#lp;Bool true) thenA])))
-      ##     (#ls;If inputS
-      ##             (recur +0 local-offset tail? thenA)
-      ##             (recur +0 local-offset tail? elseA))
-
-      ##     (#;Cons [headP headA] tailPA)
-      ##     (let [headP+ (|> (recur +0 local-offset tail? headA)
-      ##                      #ls;ExecP
-      ##                      (#ls;SeqP (&&case;path headP)))
-      ##           tailP+ (L/map (function [[pattern bodyA]]
-      ##                           (|> (recur +0 local-offset tail? bodyA)
-      ##                               #ls;ExecP
-      ##                               (#ls;SeqP (&&case;path pattern))))
-      ##                         tailPA)]
-      ##       (#ls;Case inputS (&&case;weave-paths headP+ tailP+)))
-      ##     ))
       )))
-- 
cgit v1.2.3