From 95682837c58809ed98071acb6a1c2730b2ee1862 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 15 Oct 2011 10:19:50 -0400 Subject: Improved unification of record literals in type class resolution --- src/elab_env.sml | 20 ++++++++++++++++---- tests/tcrec.ur | 5 +++++ 2 files changed, 21 insertions(+), 4 deletions(-) create mode 100644 tests/tcrec.ur diff --git a/src/elab_env.sml b/src/elab_env.sml index 23f3df01..e53c1538 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -545,8 +545,14 @@ fun eqCons (c1, c2) = | (CRecord (k1, xcs1), CRecord (k2, xcs2)) => (unifyKinds (k1, k2); - ListPair.appEq (fn ((x1, c1), (x2, c2)) => (eqCons (x1, x2); eqCons (c1, c2))) (xcs1, xcs2) - handle ListPair.UnequalLengths => raise Unify) + if length xcs1 <> length xcs2 then + raise Unify + else + List.app (fn (x1, c1) => + if List.exists (fn (x2, c2) => (eqCons (x1, x2); eqCons (c1, c2); true) handle Unify => false) xcs2 then + () + else + raise Unify) xcs1) | (CConcat (f1, x1), CConcat (f2, x2)) => (eqCons (f1, f2); eqCons (x1, x2)) | (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2)) @@ -606,8 +612,14 @@ fun unifyCons (hnorm : con -> con) rs = | (CRecord (k1, xcs1), CRecord (k2, xcs2)) => (unifyKinds (k1, k2); - ListPair.appEq (fn ((x1, c1), (x2, c2)) => (unify d (x1, x2); unify d (c1, c2))) (xcs1, xcs2) - handle ListPair.UnequalLengths => raise Unify) + if length xcs1 <> length xcs2 then + raise Unify + else + app (fn (x1, c1) => + if List.exists (fn (x2, c2) => (unify d (x1, x2); unify d (c1, c2); true) handle Unify => false) xcs2 then + () + else + raise Unify) xcs1) | (CConcat (f1, x1), CConcat (f2, x2)) => (unify d (f1, f2); unify d (x1, x2)) | (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2)) diff --git a/tests/tcrec.ur b/tests/tcrec.ur new file mode 100644 index 00000000..3d3e6e64 --- /dev/null +++ b/tests/tcrec.ur @@ -0,0 +1,5 @@ +type r1 = {A : string, B : string} +type r2 = {B : string, A : string} + +val show_r1 : show r1 = mkShow (fn r => r.A ^ "+" ^ r.B) +val show_r2 : show r2 = _ -- cgit v1.2.3