Mercurial > urweb
diff src/elab_env.sml @ 1864:1aa9629e3a4c
Allow [where con] to descend within submodule structure; open submodule constraints while checking later signature items
author | Adam Chlipala <adam@chlipala.net> |
---|---|
date | Mon, 19 Aug 2013 12:25:32 -0400 |
parents | bb942416bf1c |
children | 403f0cc65b9c |
line wrap: on
line diff
--- a/src/elab_env.sml Sat Aug 10 10:13:40 2013 -0400 +++ b/src/elab_env.sml Mon Aug 19 12:25:32 2013 -0400 @@ -1126,26 +1126,44 @@ NONE => raise Fail "ElabEnv.hnormSgn: projectSgn failed" | SOME sgn => hnormSgn env sgn end - | SgnWhere (sgn, x, c) => - case #1 (hnormSgn env sgn) of - SgnError => (SgnError, loc) - | SgnConst sgis => - let - fun traverse (pre, post) = - case post of - [] => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [1]" - | (sgi as (SgiConAbs (x', n, k), loc)) :: rest => - if x = x' then - List.revAppend (pre, (SgiCon (x', n, k, c), loc) :: rest) - else - traverse (sgi :: pre, rest) - | sgi :: rest => traverse (sgi :: pre, rest) + | SgnWhere (sgn, ms, x, c) => + let + fun rewrite (sgn, ms) = + case #1 (hnormSgn env sgn) of + SgnError => (SgnError, loc) + | SgnConst sgis => + let + fun traverse (ms, pre, post) = + case post of + [] => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [1]" - val sgis = traverse ([], sgis) - in - (SgnConst sgis, loc) - end - | _ => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [2]" + | (sgi as (SgiConAbs (x', n, k), loc)) :: rest => + if List.null ms andalso x = x' then + List.revAppend (pre, (SgiCon (x', n, k, c), loc) :: rest) + else + traverse (ms, sgi :: pre, rest) + + | (sgi as (SgiStr (x', n, sgn'), loc)) :: rest => + (case ms of + [] => traverse (ms, sgi :: pre, rest) + | x :: ms' => + if x = x' then + List.revAppend (pre, + (SgiStr (x', n, + rewrite (sgn', ms')), loc) :: rest) + else + traverse (ms, sgi :: pre, rest)) + + | sgi :: rest => traverse (ms, sgi :: pre, rest) + + val sgis = traverse (ms, [], sgis) + in + (SgnConst sgis, loc) + end + | _ => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [2]" + in + rewrite (sgn, ms) + end fun manifest (m, ms, loc) = foldl (fn (m, str) => (StrProj (str, m), loc)) (StrVar m, loc) ms