From 71d7a4c7206155e09f3e1e1d8699561ea6967382 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Wed, 1 Nov 2017 00:04:43 -0400
Subject: - Re-organized synthesis.

---
 new-luxc/source/luxc/lang/synthesis/case.lux | 70 ++++++++++++++++++++++++++++
 1 file changed, 70 insertions(+)
 create mode 100644 new-luxc/source/luxc/lang/synthesis/case.lux

(limited to 'new-luxc/source/luxc/lang/synthesis/case.lux')

diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux
new file mode 100644
index 000000000..15cb6eca3
--- /dev/null
+++ b/new-luxc/source/luxc/lang/synthesis/case.lux
@@ -0,0 +1,70 @@
+(;module:
+  lux
+  (lux (data [bool "bool/" Eq<Bool>]
+             [text "text/" Eq<Text>]
+             [number]
+             (coll [list "list/" Fold<List>]))
+       (meta [code "code/" Eq<Code>]))
+  (luxc (lang ["la" analysis]
+              ["ls" synthesis])))
+
+(def: #export (path pattern)
+  (-> la;Pattern ls;Path)
+  (case pattern
+    (^code [(~@ membersP)])
+    (case (list;reverse membersP)
+      #;Nil
+      (' ("lux case pop"))
+
+      (#;Cons singletonP #;Nil)
+      (path singletonP)
+
+      (#;Cons lastP prevsP)
+      (let [length (list;size membersP)
+            last-idx (n.dec length)
+            [_ tuple-path] (list/fold (function [current-pattern [current-idx next-path]]
+                                        [(n.dec current-idx)
+                                         (` ("lux case seq"
+                                             ("lux case tuple left" (~ (code;nat current-idx)) (~ (path current-pattern)))
+                                             (~ next-path)))])
+                                      [(n.dec last-idx)
+                                       (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path lastP))))]
+                                      prevsP)]
+        tuple-path))
+
+    (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP)))
+    (if (n.= (n.dec num-tags) tag)
+      (` ("lux case variant right" (~ (code;nat tag)) (~ (path memberP))))
+      (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP)))))
+
+    _
+    pattern))
+
+(def: #export (weave leftP rightP)
+  (-> ls;Path ls;Path ls;Path)
+  (with-expansions [<default> (as-is (` ("lux case alt" (~ leftP) (~ rightP))))]
+    (case [leftP rightP]
+      (^template [<special>]
+        (^ [[_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat left-idx)] left-then))]
+            [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat right-idx)] right-then))]])
+        (if (n.= left-idx right-idx)
+          (` (<special> (~ (code;nat left-idx)) (~ (weave left-then right-then))))
+          <default>))
+      (["lux case tuple left"]
+       ["lux case tuple right"]
+       ["lux case variant left"]
+       ["lux case variant right"])
+
+      (^ [[_ (#;Form (list [_ (#;Text "lux case seq")] left-pre left-post))]
+          [_ (#;Form (list [_ (#;Text "lux case seq")] right-pre right-post))]])
+      (case (weave left-pre right-pre)
+        (^ [_ (#;Form (list [_ (#;Text "lux case alt")] _ _))])
+        <default>
+
+        weavedP
+        (` ("lux case seq" (~ weavedP) (~ (weave left-post right-post)))))
+
+      _
+      (if (code/= leftP rightP)
+        leftP
+        <default>))))
-- 
cgit v1.2.3