diff options
| -rw-r--r-- | src/prim.sml | 4 | ||||
| -rw-r--r-- | src/reduce.sml | 123 |
2 files changed, 67 insertions, 60 deletions
diff --git a/src/prim.sml b/src/prim.sml index 597b3fba..c84c557e 100644 --- a/src/prim.sml +++ b/src/prim.sml @@ -41,7 +41,7 @@ fun p_t t = Int n => string (Int64.toString n) | Float n => string (Real64.toString n) | String s => box [string "\"", string (String.toString s), string "\""] - | Char ch => box [string "#\"", string (String.str ch), string "\""] + | Char ch => box [string "#\"", string (String.toString (String.str ch)), string "\""] fun int2s n = if Int64.compare (n, Int64.fromInt 0) = LESS then @@ -73,7 +73,7 @@ fun p_t_GCC t = Int n => string (int2s n) | Float n => string (float2s n) | String s => box [string "\"", string (String.toString s), string "\""] - | Char ch => box [string "'", string (str ch), string "'"] + | Char ch => box [string "'", string (String.toString (str ch)), string "'"] fun equal x = case x of diff --git a/src/reduce.sml b/src/reduce.sml index 54977432..bcd502cc 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -104,65 +104,72 @@ val deKnown = ListUtil.mapConcat (fn KnownC _ => [] datatype result = Yes of env | No | Maybe fun match (env, p : pat, e : exp) = - case (#1 p, #1 e) of - (PWild, _) => Yes env - | (PVar (x, t), _) => Yes (KnownE e :: env) - - | (PPrim p, EPrim p') => - if Prim.equal (p, p') then - Yes env - else - No - - | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) => - if n1 = n2 then - Yes env - else - No - - | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) => - if n1 = n2 then - match (env, p, e) - else - No - - | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE), - ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) => - if m1 = m2 andalso con1 = con2 then - Yes env - else - No - - | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep), - ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) => - if m1 = m2 andalso con1 = con2 then - match (env, p, e) - else - No - - | (PRecord xps, ERecord xes) => - if List.exists (fn ((CName _, _), _, _) => false - | _ => true) xes then - Maybe - else - let - fun consider (xps, env) = - case xps of - [] => Yes env - | (x, p, _) :: rest => - case List.find (fn ((CName x', _), _, _) => x' = x - | _ => false) xes of - NONE => No - | SOME (_, e, _) => - case match (env, p, e) of - No => No - | Maybe => Maybe - | Yes env => consider (rest, env) - in - consider (xps, env) - end + let + val baseline = length env + + fun match (env, p, e) = + case (#1 p, #1 e) of + (PWild, _) => Yes env + | (PVar (x, t), _) => Yes (KnownE (multiLiftExpInExp (length env - baseline) e) :: env) + + | (PPrim p, EPrim p') => + if Prim.equal (p, p') then + Yes env + else + No + + | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) => + if n1 = n2 then + Yes env + else + No - | _ => Maybe + | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) => + if n1 = n2 then + match (env, p, e) + else + No + + | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE), + ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) => + if m1 = m2 andalso con1 = con2 then + Yes env + else + No + + | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep), + ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) => + if m1 = m2 andalso con1 = con2 then + match (env, p, e) + else + No + + | (PRecord xps, ERecord xes) => + if List.exists (fn ((CName _, _), _, _) => false + | _ => true) xes then + Maybe + else + let + fun consider (xps, env) = + case xps of + [] => Yes env + | (x, p, _) :: rest => + case List.find (fn ((CName x', _), _, _) => x' = x + | _ => false) xes of + NONE => No + | SOME (_, e, _) => + case match (env, p, e) of + No => No + | Maybe => Maybe + | Yes env => consider (rest, env) + in + consider (xps, env) + end + + | _ => Maybe + in + match (env, p, e) + end fun kindConAndExp (namedC, namedE) = let |