From 0e3830be97930a01c38d8bca09a1ac9d5bf55465 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Wed, 22 Nov 2017 20:37:41 -0400
Subject: - Fixed some bugs. - Some refactoring. - Added some alternative
 snippets of code that new-luxc can handle better.

---
 new-luxc/source/luxc/lang/analysis/case.lux | 105 ++++++++++++++++++----------
 1 file changed, 68 insertions(+), 37 deletions(-)

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

diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux
index 5d4c592aa..949e18a26 100644
--- a/new-luxc/source/luxc/lang/analysis/case.lux
+++ b/new-luxc/source/luxc/lang/analysis/case.lux
@@ -35,6 +35,15 @@
   (format "   Type: " (%type type) "\n"
           "Pattern: " (%code pattern)))
 
+(def: (re-quantify envs baseT)
+  (-> (List (List Type)) Type Type)
+  (case envs
+    #;Nil
+    baseT
+
+    (#;Cons head tail)
+    (re-quantify tail (#;UnivQ head baseT))))
+
 ## Type-checking on the input value is done during the analysis of a
 ## "case" expression, to ensure that the patterns being used make
 ## sense for the type of the input value.
@@ -44,52 +53,74 @@
 ## type-check the input with respect to the patterns.
 (def: (simplify-case-type caseT)
   (-> Type (Meta Type))
-  (case caseT
-    (#;Var id)
-    (do macro;Monad<Meta>
-      [?caseT' (&;with-type-env
-                 (tc;read id))]
-      (case ?caseT'
-        (#;Some caseT')
-        (simplify-case-type caseT')
+  (loop [envs (: (List (List Type))
+                 (list))
+         caseT caseT]
+    (case caseT
+      (#;Var id)
+      (do macro;Monad<Meta>
+        [?caseT' (&;with-type-env
+                   (tc;read id))]
+        (case ?caseT'
+          (#;Some caseT')
+          (recur envs caseT')
 
-        _
-        (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
+          _
+          (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
 
-    (#;Named name unnamedT)
-    (simplify-case-type unnamedT)
+      (#;Named name unnamedT)
+      (recur envs unnamedT)
 
-    (^or (#;UnivQ _) (#;ExQ _))
-    (do macro;Monad<Meta>
-      [[ex-id exT] (&;with-type-env
-                     tc;existential)]
-      (simplify-case-type (maybe;assume (type;apply (list exT) caseT))))
+      (#;UnivQ env unquantifiedT)
+      (recur (#;Cons env envs) unquantifiedT)
 
-    (#;Apply inputT funcT)
-    (case funcT
-      (#;Var funcT-id)
+      ## (^template [<tag> <instancer>]
+      ##   (<tag> _)
+      ##   (do macro;Monad<Meta>
+      ##     [[_ instanceT] (&;with-type-env
+      ##                      <instancer>)]
+      ##     (recur (maybe;assume (type;apply (list instanceT) caseT)))))
+      ## ([#;UnivQ tc;var]
+      ##  [#;ExQ tc;existential])
+      
+      (#;ExQ _)
       (do macro;Monad<Meta>
-        [funcT' (&;with-type-env
-                  (do tc;Monad<Check>
-                    [?funct' (tc;read funcT-id)]
-                    (case ?funct'
-                      (#;Some funct')
-                      (wrap funct')
+        [[ex-id exT] (&;with-type-env
+                       tc;existential)]
+        (recur envs (maybe;assume (type;apply (list exT) caseT))))
 
-                      _
-                      (tc;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))]
-        (simplify-case-type (#;Apply inputT funcT')))
+      (#;Apply inputT funcT)
+      (case funcT
+        (#;Var funcT-id)
+        (do macro;Monad<Meta>
+          [funcT' (&;with-type-env
+                    (do tc;Monad<Check>
+                      [?funct' (tc;read funcT-id)]
+                      (case ?funct'
+                        (#;Some funct')
+                        (wrap funct')
 
-      _
-      (case (type;apply (list inputT) funcT)
-        (#;Some outputT)
-        (:: macro;Monad<Meta> wrap outputT)
+                        _
+                        (tc;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))]
+          (recur envs (#;Apply inputT funcT')))
 
-        #;None
-        (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
+        _
+        (case (type;apply (list inputT) funcT)
+          (#;Some outputT)
+          (recur envs outputT)
 
-    _
-    (:: macro;Monad<Meta> wrap caseT)))
+          #;None
+          (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
+
+      (#;Product _)
+      (|> caseT
+          type;flatten-tuple
+          (list/map (re-quantify envs))
+          type;tuple
+          (:: macro;Monad<Meta> wrap))
+
+      _
+      (:: macro;Monad<Meta> wrap (re-quantify envs caseT)))))
 
 ## This function handles several concerns at once, but it must be that
 ## way because those concerns are interleaved when doing
-- 
cgit v1.2.3