Pattern-matching can now handle universally quantified sums.

2 files changed, 40 insertions, 27 deletions

diff --git a/stdlib/source/lux/data/collection/dictionary.lux b/stdlib/source/lux/data/collection/dictionary.lux
index 3580b0ddd..2f07ceb3e 100644
--- a/stdlib/source/lux/data/collection/dictionary.lux
+++ b/stdlib/source/lux/data/collection/dictionary.lux
@@ -1,6 +1,9 @@
 (.module:
   [lux #*
    [abstract
+    [monoid (#+)]
+    [fold (#+)]
+    [monad (#+)]
     [hash (#+ Hash)]
     [equivalence (#+ Equivalence)]
     [functor (#+ Functor)]]
@@ -681,28 +684,29 @@
                           #0))
                       (keys test)))))
 
+(structure: functor'
+  (All [k] (Functor (Node k)))
+  (def: (map f fa)
+    (case fa
+      (#Hierarchy size hierarchy)
+      (#Hierarchy size (array@map (map f) hierarchy))
+      
+      (#Base bitmap base)
+      (#Base bitmap (array@map (function (_ either)
+                                 (case either
+                                   (#.Left fa')
+                                   (#.Left (map f fa'))
+                                   
+                                   (#.Right [k v])
+                                   (#.Right [k (f v)])))
+                               base))
+      
+      (#Collisions hash collisions)
+      (#Collisions hash (array@map (function (_ [k v])
+                                     [k (f v)])
+                                   collisions)))))
+
 (structure: #export functor
   (All [k] (Functor (Dictionary k)))
   (def: (map f fa)
-    (update@ #root
-             (function (recur node)
-               (case node
-                 (#Hierarchy size hierarchy)
-                 (#Hierarchy size (array@map recur hierarchy))
-                 
-                 (#Base bitmap base)
-                 (#Base bitmap (array@map (function (_ either)
-                                            (case either
-                                              (#.Left node)
-                                              (#.Left (recur node))
-                                              
-                                              (#.Right [k v])
-                                              (#.Right [k (f v)])))
-                                          base))
-                 
-                 (#Collisions hash collisions)
-                 (#Collisions hash (array@map (function (_ [k v])
-                                                [k (f v)])
-                                              collisions))))
-             fa)
-    ))
+    (update@ #root (:: ..functor' map f) fa)))
diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/case.lux b/stdlib/source/lux/tool/compiler/phase/analysis/case.lux
index 9d7c9ea7f..dff106eb7 100644
--- a/stdlib/source/lux/tool/compiler/phase/analysis/case.lux
+++ b/stdlib/source/lux/tool/compiler/phase/analysis/case.lux
@@ -90,9 +90,9 @@
 
       (#.ExQ _)
       (do ///.monad
-        [[ex-id exT] (//type.with-env
-                       check.existential)]
-        (recur envs (maybe.assume (type.apply (list exT) caseT))))
+        [[var-id varT] (//type.with-env
+                         check.var)]
+        (recur envs (maybe.assume (type.apply (list varT) caseT))))
 
       (#.Apply inputT funcT)
       (.case funcT
@@ -215,7 +215,7 @@
                      thenA])))
 
           _
-          (/.throw cannot-match-with-pattern [inputT pattern])
+          (/.throw cannot-match-with-pattern [inputT' pattern])
           )))
 
     [cursor (#.Record record)]
@@ -260,8 +260,17 @@
               _
               (/.throw sum-has-no-case [idx inputT])))
 
+          (#.UnivQ _)
+          (do ///.monad
+            [[ex-id exT] (//type.with-env
+                           check.existential)]
+            (analyse-pattern num-tags
+                             (maybe.assume (type.apply (list exT) inputT'))
+                             pattern
+                             next))
+          
           _
-          (/.throw cannot-match-with-pattern [inputT pattern]))))
+          (/.throw cannot-match-with-pattern [inputT' pattern]))))
 
     (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))])
     (/.with-cursor cursor