Mercurial > urweb
diff src/elaborate.sml @ 42:b3fbbc6cb1e5
Elaborating 'where'
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Thu, 19 Jun 2008 16:35:40 -0400 |
parents | 1405d8c26790 |
children | d94c484337d0 |
line wrap: on
line diff
--- a/src/elaborate.sml Thu Jun 19 16:04:28 2008 -0400 +++ b/src/elaborate.sml Thu Jun 19 16:35:40 2008 -0400 @@ -239,7 +239,7 @@ ((L'.CNamed n, loc), k)) | L.CVar (m1 :: ms, s) => (case E.lookupStr env m1 of - NONE => (conError env (UnboundStrInCon (loc, s)); + NONE => (conError env (UnboundStrInCon (loc, m1)); (cerror, kerror)) | SOME (n, sgn) => let @@ -824,7 +824,7 @@ | E.Named (n, t) => ((L'.ENamed n, loc), t)) | L.EVar (m1 :: ms, s) => (case E.lookupStr env m1 of - NONE => (expError env (UnboundStrInExp (loc, s)); + NONE => (expError env (UnboundStrInExp (loc, m1)); (eerror, cerror)) | SOME (n, sgn) => let @@ -969,6 +969,7 @@ | SgiWrongKind of L'.sgn_item * L'.kind * L'.sgn_item * L'.kind * kunify_error | 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 fun sgnError env err = case err of @@ -995,6 +996,10 @@ (ErrorMsg.errorAt (#2 sgn1) "Incompatible signatures:"; eprefaces' [("Sig 1", p_sgn env sgn1), ("Sig 2", p_sgn env sgn2)]) + | UnWhereable (sgn, x) => + (ErrorMsg.errorAt (#2 sgn) "Unavailable field for 'where'"; + eprefaces' [("Signature", p_sgn env sgn), + ("Field", PD.string x)]) datatype str_error = UnboundStr of ErrorMsg.span * string @@ -1004,6 +1009,7 @@ UnboundStr (loc, s) => ErrorMsg.errorAt loc ("Unbound structure variable " ^ s) +val hnormSgn = E.hnormSgn fun elabSgn_item ((sgi, loc), env) = let @@ -1110,6 +1116,25 @@ in (L'.SgnFun (m, n, dom', ran'), loc) end + | L.SgnWhere (sgn, x, c) => + let + val sgn' = elabSgn env sgn + val (c', ck) = elabCon env c + in + case #1 (hnormSgn env sgn') of + L'.SgnError => sgnerror + | L'.SgnConst sgis => + if List.exists (fn (L'.SgiConAbs (x, _, k), _) => + (unifyKinds k ck; + true) + | _ => false) sgis then + (L'.SgnWhere (sgn', x, c'), loc) + else + (sgnError env (UnWhereable (sgn', x)); + sgnerror) + | _ => (sgnError env (UnWhereable (sgn', x)); + sgnerror) + end fun sgiOfDecl (d, loc) = case d of @@ -1118,13 +1143,6 @@ | L'.DSgn _ => NONE | L'.DStr (x, n, sgn, _) => SOME (L'.SgiStr (x, n, sgn), loc) -fun hnormSgn env (all as (sgn, _)) = - case sgn of - L'.SgnError => all - | L'.SgnVar n => hnormSgn env (#2 (E.lookupSgnNamed env n)) - | L'.SgnConst _ => all - | L'.SgnFun _ => all - fun subSgn env sgn1 (sgn2 as (_, loc2)) = case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of (L'.SgnError, _) => () @@ -1240,6 +1258,7 @@ (L'.SgiStr (x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc) | x => x) sgis), #2 sgn) | L'.SgnFun _ => sgn + | L'.SgnWhere _ => sgn fun elabDecl ((d, loc), env) = let @@ -1384,7 +1403,7 @@ NONE => actual | SOME ran => let - val ran' = elabSgn env ran + val ran' = elabSgn env' ran in subSgn env' actual ran'; ran'