Mercurial > urweb
diff src/elaborate.sml @ 75:88ffb3d61817
Folding through a functor
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Thu, 26 Jun 2008 12:35:26 -0400 |
parents | 144d082b47ae |
children | 522f4bd3955e |
line wrap: on
line diff
--- a/src/elaborate.sml Thu Jun 26 12:12:06 2008 -0400 +++ b/src/elaborate.sml Thu Jun 26 12:35:26 2008 -0400 @@ -1082,6 +1082,7 @@ | SgiWrongCon of L'.sgn_item * L'.con * L'.sgn_item * L'.con * cunify_error | SgnWrongForm of L'.sgn * L'.sgn | UnWhereable of L'.sgn * string + | WhereWrongKind of L'.kind * L'.kind * kunify_error | NotIncludable of L'.sgn | DuplicateCon of ErrorMsg.span * string | DuplicateVal of ErrorMsg.span * string @@ -1117,6 +1118,11 @@ (ErrorMsg.errorAt (#2 sgn) "Unavailable field for 'where'"; eprefaces' [("Signature", p_sgn env sgn), ("Field", PD.string x)]) + | WhereWrongKind (k1, k2, kerr) => + (ErrorMsg.errorAt (#2 k1) "Wrong kind for 'where'"; + eprefaces' [("Have", p_kind k1), + ("Need", p_kind k2)]; + kunifyError kerr) | NotIncludable sgn => (ErrorMsg.errorAt (#2 sgn) "Invalid signature to 'include'"; eprefaces' [("Signature", p_sgn env sgn)]) @@ -1134,6 +1140,7 @@ | NotFunctor of L'.sgn | FunctorRebind of ErrorMsg.span | UnOpenable of L'.sgn + | NotType of L'.kind * (L'.kind * L'.kind * kunify_error) fun strError env err = case err of @@ -1147,6 +1154,12 @@ | UnOpenable sgn => (ErrorMsg.errorAt (#2 sgn) "Un-openable structure"; eprefaces' [("Signature", p_sgn env sgn)]) + | NotType (k, (k1, k2, ue)) => + (ErrorMsg.errorAt (#2 k) "'val' type kind is not 'Type'"; + eprefaces' [("Kind", p_kind k), + ("Subkind 1", p_kind k1), + ("Subkind 2", p_kind k2)]; + kunifyError ue) val hnormSgn = E.hnormSgn @@ -1209,7 +1222,8 @@ val (env', n) = E.pushENamed env x c' in - unifyKinds ck ktype; + (unifyKinds ck ktype + handle KUnify ue => strError env (NotType (ck, ue))); if ErrorMsg.anyErrors () then () @@ -1316,8 +1330,10 @@ case #1 (hnormSgn env sgn') of L'.SgnError => sgnerror | L'.SgnConst sgis => - if List.exists (fn (L'.SgiConAbs (x, _, k), _) => - (unifyKinds k ck; + if List.exists (fn (L'.SgiConAbs (x', _, k), _) => + x' = x andalso + (unifyKinds k ck + handle KUnify x => sgnError env (WhereWrongKind x); true) | _ => false) sgis then (L'.SgnWhere (sgn', x, c'), loc)