After a tricky debugging session, limit visibility of type-class instances from anonymous modules

6 files changed, 55 insertions, 37 deletions

diff --git a/src/elab.sml b/src/elab.sml
index 249531f1..209d3307 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -138,13 +138,19 @@ and edecl' =
 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
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 9fbe7bd7..9c9cd14f 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -990,7 +990,7 @@ fun sgiSeek (sgi, (sgns, strs, cons)) =
       | 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 @@ and hnormSgn env (all as (sgn, loc)) =
 				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 enrichClasses env classes (m1, ms) sgn =
                               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 @@ fun sgiBinds env (sgi, loc) =
             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 sgnSubCon x =
 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 @@ fun sgnSeekConstraints (str, sgis) =
                   | 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
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 957d4646..5a41883f 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -611,13 +611,13 @@ fun p_sgn_item env (sgiAll as (sgi, _)) =
                                  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,
diff --git a/src/elab_util.sml b/src/elab_util.sml
index fef55852..acc696dd 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -688,10 +688,10 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} =
                 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 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} =
                                                    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 @@ and maxNameSgi (sgi, _) =
         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
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 1885345d..c3e81b65 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2481,7 +2481,7 @@ fun dopenConstraints (loc, env, denv) {str, strs} =
                         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 @@ fun dopenConstraints (loc, env, denv) {str, strs} =
                       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 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
              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 @@ and elabSgn (env, denv) (sgn, loc) =
                                    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 @@ and elabSgn (env, denv) (sgn, loc) =
                                     (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 @@ and selfify env {str, strs, sgn} =
                                                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 @@ and dopen env {str, strs, sgn} =
                                     [(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 @@ and sgiOfDecl (d, loc) =
       | 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 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
                                          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 @@ and wildifyStr env (str, sgn) =
                                             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 @@ and elabStr (env, denv) (str, loc) =
                                   ((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 @@ and elabStr (env, denv) (str, loc) =
                                       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 @@ and elabStr (env, denv) (str, loc) =
                           * 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 @@ and elabStr (env, denv) (str, loc) =
                          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 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file =
             ();
 
         (*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)
diff --git a/src/explify.sml b/src/explify.sml
index fd0f3277..f38151d2 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -150,7 +150,7 @@ fun explifySgi (sgi, loc) =
         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)