Mercurial > urweb
diff src/mono_reduce.sml @ 341:389399d65331
Crud update form
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Sun, 14 Sep 2008 19:03:55 -0400 |
parents | e976b187d73a |
children | 7abb28e9d51f |
line wrap: on
line diff
--- a/src/mono_reduce.sml Sun Sep 14 15:20:53 2008 -0400 +++ b/src/mono_reduce.sml Sun Sep 14 19:03:55 2008 -0400 @@ -111,6 +111,21 @@ bind = fn (lower, U.Exp.RelE _) => lower+1 | (lower, _) => lower} +val swapExpVarsPat = + U.Exp.mapB {typ = fn t => t, + exp = fn (lower, len) => fn e => + case e of + ERel xn => + if xn = lower then + ERel (lower + 1) + else if xn >= lower + 1 andalso xn < lower + 1 + len then + ERel (xn - 1) + else + e + | _ => e, + bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len) + | (st, _) => st} + datatype result = Yes of E.env | No | Maybe fun match (env, p : pat, e : exp) = @@ -272,15 +287,29 @@ else #1 (reduceExp env (subExpInExp (0, e2) e1))) - | ECase (disc, pes, _) => + | ECase (e', pes, {disc, result}) => let + fun push () = + case result of + (TFun (dom, result), loc) => + if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then + EAbs ("_", dom, result, + (ECase (liftExpInExp 0 e', + map (fn (p, (EAbs (_, _, _, e), _)) => + (p, swapExpVarsPat (0, patBinds p) e) + | _ => raise Fail "MonoReduce ECase") pes, + {disc = disc, result = result}), loc)) + else + e + | _ => e + fun search pes = case pes of - [] => e + [] => push () | (p, body) :: pes => - case match (env, p, disc) of + case match (env, p, e') of No => search pes - | Maybe => e + | Maybe => push () | Yes env => #1 (reduceExp env body) in search pes