Mercurial > urweb
changeset 2190:22117edf8fd3
After a tricky debugging session, limit visibility of type-class instances from anonymous modules
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Sun, 01 Nov 2015 16:33:14 -0500 |
| parents | 43393a4a66ce |
| children | 849404a3af27 |
| files | src/elab.sml src/elab_env.sml src/elab_print.sml src/elab_util.sml src/elaborate.sml src/explify.sml |
| diffstat | 6 files changed, 55 insertions(+), 37 deletions(-) [+] |
line wrap: on
line diff
--- a/src/elab.sml Sun Nov 01 14:17:09 2015 -0500 +++ b/src/elab.sml Sun Nov 01 16:33:14 2015 -0500 @@ -138,13 +138,19 @@ withtype exp = exp' located and edecl = edecl' located +(* We have to be careful about crawling automatically generated signatures recursively, + * importing all type-class instances that we find. + * The reason is that selfification will add signatures of anonymous structures, + * and it's counterintuitive for instances to escape anonymous structures! *) +datatype import_mode = Import | Skip + datatype sgn_item' = SgiConAbs of string * int * kind | SgiCon of string * int * kind * con | SgiDatatype of (string * int * string list * (string * int * con option) list) list | SgiDatatypeImp of string * int * int * string list * string * string list * (string * int * con option) list | SgiVal of string * int * con - | SgiStr of string * int * sgn + | SgiStr of import_mode * string * int * sgn | SgiSgn of string * int * sgn | SgiConstraint of con * con | SgiClassAbs of string * int * kind
--- a/src/elab_env.sml Sun Nov 01 14:17:09 2015 -0500 +++ b/src/elab_env.sml Sun Nov 01 16:33:14 2015 -0500 @@ -990,7 +990,7 @@ | SgiDatatypeImp (x, n, _, _, _, _, _) => (sgns, strs, IM.insert (cons, n, x)) | SgiVal _ => (sgns, strs, cons) | SgiSgn (x, n, _) => (IM.insert (sgns, n, x), strs, cons) - | SgiStr (x, n, _) => (sgns, IM.insert (strs, n, x), cons) + | SgiStr (_, x, n, _) => (sgns, IM.insert (strs, n, x), cons) | SgiConstraint _ => (sgns, strs, cons) | SgiClassAbs (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) | SgiClass (x, n, _, _) => (sgns, strs, IM.insert (cons, n, x)) @@ -1143,13 +1143,13 @@ else traverse (ms, sgi :: pre, rest) - | (sgi as (SgiStr (x', n, sgn'), loc)) :: rest => + | (sgi as (SgiStr (im, 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, + (SgiStr (im, x', n, rewrite (sgn', ms')), loc) :: rest) else traverse (ms, sgi :: pre, rest)) @@ -1186,7 +1186,7 @@ fun default () = (classes, newClasses, sgiSeek (#1 sgi, fmap), env) in case #1 sgi of - SgiStr (x, _, sgn) => + SgiStr (Import, x, _, sgn) => let val str = manifest (m1, ms, #2 sgi) val sgn' = sgnSubSgn (str, fmap) sgn @@ -1360,7 +1360,7 @@ env xncs end | SgiVal (x, n, t) => pushENamedAs env x n t - | SgiStr (x, n, sgn) => pushStrNamedAs env x n sgn + | SgiStr (_, x, n, sgn) => pushStrNamedAs env x n sgn | SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn | SgiConstraint _ => env @@ -1374,7 +1374,7 @@ fun projectStr env {sgn, str, field} = case #1 (hnormSgn env sgn) of SgnConst sgis => - (case sgnSeek (fn SgiStr (x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of + (case sgnSeek (fn SgiStr (_, x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of NONE => NONE | SOME (sgn, subs) => SOME (sgnSubSgn (str, subs) sgn)) | SgnError => SOME (SgnError, ErrorMsg.dummySpan) @@ -1544,7 +1544,7 @@ | SgiDatatypeImp (x, n, _, _, _, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) | SgiVal _ => seek (sgis, sgns, strs, cons, acc) | SgiSgn (x, n, _) => seek (sgis, IM.insert (sgns, n, x), strs, cons, acc) - | SgiStr (x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons, acc) + | SgiStr (_, x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons, acc) | SgiClassAbs (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) | SgiClass (x, n, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) in
--- a/src/elab_print.sml Sun Nov 01 14:17:09 2015 -0500 +++ b/src/elab_print.sml Sun Nov 01 16:33:14 2015 -0500 @@ -611,13 +611,13 @@ string ":", space, p_con env c] - | SgiStr (x, n, sgn) => box [string "structure", - space, - p_named x n, - space, - string ":", - space, - p_sgn env sgn] + | SgiStr (_, x, n, sgn) => box [string "structure", + space, + p_named x n, + space, + string ":", + space, + p_sgn env sgn] | SgiSgn (x, n, sgn) => box [string "signature", space, p_named x n,
--- a/src/elab_util.sml Sun Nov 01 14:17:09 2015 -0500 +++ b/src/elab_util.sml Sun Nov 01 16:33:14 2015 -0500 @@ -688,10 +688,10 @@ S.map2 (con ctx c, fn c' => (SgiVal (x, n, c'), loc)) - | SgiStr (x, n, s) => + | SgiStr (im, x, n, s) => S.map2 (sg ctx s, fn s' => - (SgiStr (x, n, s'), loc)) + (SgiStr (im, x, n, s'), loc)) | SgiSgn (x, n, s) => S.map2 (sg ctx s, fn s' => @@ -738,7 +738,7 @@ bind (ctx, NamedC (x, n, (KType, loc), SOME (CModProj (m1, ms, s), loc))) | SgiVal _ => ctx - | SgiStr (x, n, sgn) => + | SgiStr (_, x, n, sgn) => bind (ctx, Str (x, n, sgn)) | SgiSgn (x, n, sgn) => bind (ctx, Sgn (x, n, sgn)) @@ -1270,7 +1270,7 @@ foldl (fn ((_, n', _), m) => Int.max (n', m)) (Int.max (n1, n2)) ns | SgiVal (_, n, _) => n - | SgiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | SgiStr (_, _, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiConstraint _ => 0 | SgiClassAbs (_, n, _) => n
--- a/src/elaborate.sml Sun Nov 01 14:17:09 2015 -0500 +++ b/src/elaborate.sml Sun Nov 01 16:33:14 2015 -0500 @@ -2481,7 +2481,7 @@ L'.SgnConst sgis => foldl (fn (sgi, cs) => case #1 sgi of - L'.SgiStr (x, _, _) => + L'.SgiStr (L'.Import, x, _, _) => (case E.projectStr env {sgn = sgn, str = st, field = x} of NONE => raise Fail "Elaborate: projectStr in collect" | SOME sgn' => @@ -2494,6 +2494,18 @@ D.assert env denv (c1, c2)) denv (collect true (st, sgn)) end +fun tcdump env = + Print.preface("Instances", p_list_sep Print.PD.newline + (fn (cl, ls) => + box [p_con env cl, + box [Print.PD.string "{", + p_list (fn (t, e) => + box [p_exp env e, + Print.PD.string " : ", + p_con env t]) ls, + Print.PD.string "}"]]) + (E.listClasses env)) + fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ((*Print.preface ("elabSgi", SourcePrint.p_sgn_item (sgi, loc));*) case sgi of @@ -2695,7 +2707,7 @@ val (env', n) = E.pushStrNamed env x sgn' val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []} in - ([(L'.SgiStr (x, n, sgn'), loc)], (env', denv', gs' @ gs)) + ([(L'.SgiStr (L'.Import, x, n, sgn'), loc)], (env', denv', gs' @ gs)) end | L.SgiSgn (x, sgn) => @@ -2814,7 +2826,7 @@ else (); (cons, vals, SS.add (sgns, x), strs)) - | L'.SgiStr (x, _, _) => + | L'.SgiStr (_, x, _, _) => (if SS.member (strs, x) then sgnError env (DuplicateStr (loc, x)) else @@ -2865,7 +2877,7 @@ (unifyKinds env k ck handle KUnify x => sgnError env (WhereWrongKind x); true) - | (L'.SgiStr (x', _, sgn''), _) => + | (L'.SgiStr (_, x', _, sgn''), _) => (case ms of [] => false | m :: ms' => @@ -2914,8 +2926,8 @@ map (fn (x, n, xs, xncs) => (L'.SgiDatatypeImp (x, n, str, strs, x, xs, xncs), loc)) dts | (L'.SgiClassAbs (x, n, k), loc) => [(L'.SgiClass (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)] - | (L'.SgiStr (x, n, sgn), loc) => - [(L'.SgiStr (x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc)] + | (L'.SgiStr (im, x, n, sgn), loc) => + [(L'.SgiStr (im, x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc)] | x => [x], E.sgiBinds env sgi)) env sgis)), #2 sgn) | L'.SgnFun _ => sgn @@ -2987,7 +2999,7 @@ [(L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc)] else [] - | L'.SgiStr (x, n, sgn) => + | L'.SgiStr (_, x, n, sgn) => if isVisible x then [(L'.DStr (x, n, sgn, (L'.StrProj (m, x), loc)), loc)] else @@ -3033,8 +3045,8 @@ | L'.DVal (x, n, t, _) => [(L'.SgiVal (x, n, t), loc)] | L'.DValRec vis => map (fn (x, n, t, _) => (L'.SgiVal (x, n, t), loc)) vis | L'.DSgn (x, n, sgn) => [(L'.SgiSgn (x, n, sgn), loc)] - | L'.DStr (x, n, sgn, _) => [(L'.SgiStr (x, n, sgn), loc)] - | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (x, n, sgn), loc)] + | L'.DStr (x, n, sgn, _) => [(L'.SgiStr (L'.Import, x, n, sgn), loc)] + | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (L'.Import, x, n, sgn), loc)] | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)] | L'.DExport _ => [] | L'.DTable (tn, x, n, c, _, pc, _, cc) => @@ -3344,10 +3356,10 @@ NONE | _ => NONE) - | L'.SgiStr (x, n2, sgn2) => + | L'.SgiStr (_, x, n2, sgn2) => seek (fn (env, sgi1All as (sgi1, loc)) => case sgi1 of - L'.SgiStr (x', n1, sgn1) => + L'.SgiStr (_, x', n1, sgn1) => if x = x' then let (* Don't forget to save & restore the @@ -3749,7 +3761,7 @@ else nd end - | L'.SgiStr (x, _, s) => + | L'.SgiStr (_, x, _, s) => (case #1 (hnormSgn env' s) of L'.SgnConst sgis' => naddMod (nd, x, (env', buildNeeded env' sgis')) | _ => nd) @@ -4496,7 +4508,7 @@ ((L'.SgiSgn (x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) end - | L'.SgiStr (x, n, sgn) => + | L'.SgiStr (im, x, n, sgn) => let val (strs, x) = if SS.member (strs, x) then @@ -4504,7 +4516,7 @@ else (SS.add (strs, x), x) in - ((L'.SgiStr (x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) + ((L'.SgiStr (im, x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiConstraint _ => ((sgi, loc) :: sgis, cons, vals, sgns, strs) | L'.SgiClassAbs (x, n, k) => @@ -4610,7 +4622,7 @@ * question-mark identifiers generated previously by this * very code fragment. *) fun mungeName m = - if List.exists (fn (L'.SgiStr (x, _, _), _) => x = m + if List.exists (fn (L'.SgiStr (_, x, _, _), _) => x = m | _ => false) sgis then mungeName ("?" ^ m) else @@ -4619,7 +4631,7 @@ val m = mungeName m in ((L'.StrApp (str1', str2'), loc), - (L'.SgnConst ((L'.SgiStr (m, n, selfifyAt env {str = str2', sgn = sgn2}), loc) :: sgis), loc), + (L'.SgnConst ((L'.SgiStr (L'.Skip, m, n, selfifyAt env {str = str2', sgn = sgn2}), loc) :: sgis), loc), gs1 @ gs2) end | _ => raise Fail "Unable to hnormSgn in functor application") @@ -5001,7 +5013,7 @@ (); (*Print.preface("File", ElabPrint.p_file env file);*) - + (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan) :: ds @ (L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan)
--- a/src/explify.sml Sun Nov 01 14:17:09 2015 -0500 +++ b/src/explify.sml Sun Nov 01 16:33:14 2015 -0500 @@ -150,7 +150,7 @@ SOME (L'.SgiDatatypeImp (x, n, m1, ms, s, xs, map (fn (x, n, co) => (x, n, Option.map explifyCon co)) xncs), loc) | L.SgiVal (x, n, c) => SOME (L'.SgiVal (x, n, explifyCon c), loc) - | L.SgiStr (x, n, sgn) => SOME (L'.SgiStr (x, n, explifySgn sgn), loc) + | L.SgiStr (_, x, n, sgn) => SOME (L'.SgiStr (x, n, explifySgn sgn), loc) | L.SgiSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, explifySgn sgn), loc) | L.SgiConstraint _ => NONE | L.SgiClassAbs (x, n, k) => SOME (L'.SgiConAbs (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc)), loc)