diff src/elaborate.sml @ 721:9864b64b1700

Classes as optional arguments to Basis.tag
author Adam Chlipala <adamc@hcoop.net>
date Sun, 12 Apr 2009 14:19:15 -0400
parents acb8537f58f0
children 059074c8d2fc
line wrap: on
line diff
--- a/src/elaborate.sml	Sun Apr 12 12:31:54 2009 -0400
+++ b/src/elaborate.sml	Sun Apr 12 14:19:15 2009 -0400
@@ -1493,26 +1493,28 @@
         end
       | _ => (c, loc)
 
-fun normClassKey envs c =
+fun normClassKey env c =
     let
-        val c = hnormCon envs c
+        val c = hnormCon env c
     in
         case #1 c of
             L'.CApp (c1, c2) =>
             let
-                val c1 = normClassKey envs c1
-                val c2 = normClassKey envs c2
+                val c1 = normClassKey env c1
+                val c2 = normClassKey env c2
             in
                 (L'.CApp (c1, c2), #2 c)
             end
-          | _ => c
+          | L'.CRecord (k, xcs) => (L'.CRecord (k, map (fn (x, c) => (normClassKey env x,
+                                                                      normClassKey env c)) xcs), #2 c)
+          | _ => unmodCon env c
     end
 
 fun normClassConstraint env (c, loc) =
     case c of
         L'.CApp (f, x) =>
         let
-            val f = unmodCon env f
+            val f = normClassKey env f
             val x = normClassKey env x
         in
             (L'.CApp (f, x), loc)
@@ -1526,7 +1528,7 @@
         end
       | L'.TCFun (expl, x, k, c1) => (L'.TCFun (expl, x, k, normClassConstraint env c1), loc)
       | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c
-      | _ => (c, loc)
+      | _ => unmodCon env (c, loc)
 
 fun elabExp (env, denv) (eAll as (e, loc)) =
     let
@@ -2047,6 +2049,7 @@
         let
             val (c', ck, gs') = elabCon (env, denv) c
 
+            val old = c'
             val c' = normClassConstraint env c'
             val (env', n) = E.pushENamed env x c'
         in