Distribute applications of "arrow type" ECase across branches.

1 files changed, 39 insertions, 9 deletions

diff --git a/src/reduce.sml b/src/reduce.sml
index c18c698b..77863bdb 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -371,6 +371,15 @@ fun kindConAndExp (namedC, namedE) =
                          else
                              ()*)
 
+                fun patBinds (p, _) =
+                    case p of
+                        PWild => 0
+                      | PVar _ => 1
+                      | PPrim _ => 0
+                      | PCon (_, _, _, NONE) => 0
+                      | PCon (_, _, _, SOME p) => patBinds p
+                      | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
+
                 val r = case e of
                             EPrim _ => all
                           | ERel n =>
@@ -458,6 +467,20 @@ fun kindConAndExp (namedC, namedE) =
                                                                ("r", CorePrint.p_exp CoreEnv.empty r)];*)
                                         r
                                     end
+                                  | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) =>
+                                    let
+                                        val pes' = map (fn (p, body) =>
+                                                           let
+                                                               val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ (deKnown env)
+                                                               val body' = exp env' (EApp (body, multiLiftExpInExp (patBinds p) e2), #2 body)
+                                                           in
+                                                               (p, body')
+                                                           end) pes
+
+                                        val cc' = {disc = disc, result = c2}
+                                    in
+                                        (ECase (e, pes', cc'), loc)
+                                    end
                                   | _ => (EApp (e1, e2), loc)
                             end
 
@@ -480,6 +503,22 @@ fun kindConAndExp (namedC, namedE) =
                                                                ("r", CorePrint.p_exp CoreEnv.empty r)];*)
                                         r
                                     end
+                                  | ECase (e, pes, cc as {disc, result = res as (TCFun (_, _, c'), _)}) =>
+                                    let
+                                        val pes' = map (fn (p, body) =>
+                                                        let
+                                                            val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ (deKnown env)
+
+                                                            val body' = exp env' (ECApp (body, c), #2 body)
+                                                        in
+                                                            (p, body')
+                                                        end) pes
+
+                                        val c' = E.subConInCon (0, c) c'
+                                        val cc' = {disc = disc, result = c'}
+                                    in
+                                        (ECase (e, pes', cc'), loc)
+                                    end
                                   | _ => (ECApp (e, c), loc)
                             end
 
@@ -611,15 +650,6 @@ fun kindConAndExp (namedC, namedE) =
 
                           | ECase (e, pes, {disc, result}) =>
                             let
-                                fun patBinds (p, _) =
-                                    case p of
-                                        PWild => 0
-                                      | PVar _ => 1
-                                      | PPrim _ => 0
-                                      | PCon (_, _, _, NONE) => 0
-                                      | PCon (_, _, _, SOME p) => patBinds p
-                                      | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
-
                                 fun pat (all as (p, loc)) =
                                     case p of
                                         PWild => all