Fix grouping by module in the mi_exports, for indexed data type families

[ghc-hetmet.git] / compiler / iface / MkIface.lhs

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index cca8ab5..99854d4 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -244,7 +244,8 @@ mkIface hsc_env maybe_old_iface
                      mg_deps      = deps,
                      mg_rdr_env   = rdr_env,
                      mg_fix_env   = fix_env,
-                     mg_deprecs   = src_deprecs})
+                     mg_deprecs   = src_deprecs,
+                     mg_hpc_info  = hpc_info })
        (ModDetails{  md_insts     = insts, 
                      md_fam_insts = fam_insts,
                      md_rules     = rules,
@@ -304,6 +305,7 @@ mkIface hsc_env maybe_old_iface
                         mi_finsts    = False,   -- Ditto
                        mi_decls     = deliberatelyOmitted "decls",
                        mi_ver_fn    = deliberatelyOmitted "ver_fn",
+                       mi_hpc       = isHpcUsed hpc_info,
 
                        -- And build the cached values
                        mi_dep_fn = mkIfaceDepCache deprecs,
@@ -339,8 +341,19 @@ mkIface hsc_env maybe_old_iface
      deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
      ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
 
-     flattenVectInfo (VectInfo ccVar) = 
-       IfaceVectInfo [Var.varName v | (v, _) <- varEnvElts ccVar]
+     flattenVectInfo (VectInfo { vectInfoVar   = vVar
+                               , vectInfoTyCon = vTyCon
+                               }) = 
+       IfaceVectInfo { 
+         ifaceVectInfoVar        = [ Var.varName v 
+                                   | (v, _) <- varEnvElts vVar],
+         ifaceVectInfoTyCon      = [ tyConName t 
+                                   | (t, t_v) <- nameEnvElts vTyCon
+                                   , t /= t_v],
+         ifaceVectInfoTyConReuse = [ tyConName t
+                                   | (t, t_v) <- nameEnvElts vTyCon
+                                   , t == t_v]
+       } 
 
 -----------------------------
 writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
@@ -461,7 +474,8 @@ addVersionInfo ver_fn (Just old_iface@(ModIface {
 
        -- If the usages havn't changed either, we don't need to write the interface file
     no_other_changes = mi_usages new_iface == mi_usages old_iface && 
-                      mi_deps new_iface == mi_deps old_iface
+                      mi_deps new_iface == mi_deps old_iface &&
+                      mi_hpc new_iface == mi_hpc old_iface
     no_change_at_all = no_output_change && no_other_changes
  
     pp_diffs = vcat [pp_change no_export_change "Export list" 
@@ -792,23 +806,54 @@ mkIfaceExports exports
     | (mod, avails) <- fmToList groupFM
     ]
   where
+       -- Group by the module where the exported entities are defined
+       -- (which may not be the same for all Names in an Avail)
        -- Deliberately use FiniteMap rather than UniqFM so we
        -- get a canonical ordering
     groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
     groupFM = foldl add emptyModuleEnv exports
 
-    add env avail
-      = extendModuleEnv_C add_avail env mod (unitFM avail_fs avail_occ)
+    add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
+           -> Module -> GenAvailInfo OccName
+           -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
+    add_one env mod avail 
+      =  extendModuleEnv_C plusFM env mod 
+               (unitFM (occNameFS (availName avail)) avail)
+
+       -- NB: we should not get T(X) and T(Y) in the export list
+       --     else the plusFM will simply discard one!  They
+       --     should have been combined by now.
+    add env (Avail n)
+      = add_one env (nameModule n) (Avail (nameOccName n))
+
+    add env (AvailTC tc ns)
+      = foldl add_for_mod env mods
       where
-       avail_occ = availToOccs avail
-       mod  = nameModule (availName avail)
-       avail_fs = occNameFS (availName avail_occ)
-       add_avail avail_fm _ = addToFM avail_fm avail_fs avail_occ
-
-    availToOccs (Avail n) = Avail (nameOccName n)
-    availToOccs (AvailTC tc ns) = AvailTC (nameOccName tc) (map nameOccName ns)
+       tc_occ = nameOccName tc
+       mods   = nub (map nameModule ns)
+               -- Usually just one, but see Note [Original module]
+
+       add_for_mod env mod
+           = add_one env mod (AvailTC tc_occ names_from_mod)
+           where
+             names_from_mod = [nameOccName n | n <- ns, nameModule n == mod]
 \end{code}
 
+Note [Orignal module]
+~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+       module X where { data family T }
+       module Y( T(..) ) where { import X; data instance T Int = MkT Int }
+The exported Avail from Y will look like
+       X.T{X.T, Y.MkT}
+That is, in Y, 
+  - only MkT is brought into scope by the data instance;
+  - but the parent (used for grouping and naming in T(..) exports) is X.T
+  - and in this case we export X.T too
+
+In the result of MkIfaceExports, the names are grouped by defining module,
+so we may need to split up a single Avail into multiple ones.
+
 
 %************************************************************************
 %*                                                                     *
@@ -1070,10 +1115,12 @@ tyThingToIfaceDecl (AClass clas)
 
 tyThingToIfaceDecl (ATyCon tycon)
   | isSynTyCon tycon
-  = IfaceSyn { ifName   = getOccName tycon,
-               ifTyVars = toIfaceTvBndrs tyvars,
+  = IfaceSyn { ifName    = getOccName tycon,
+               ifTyVars  = toIfaceTvBndrs tyvars,
                ifOpenSyn = syn_isOpen,
-               ifSynRhs  = toIfaceType syn_tyki }
+               ifSynRhs  = toIfaceType syn_tyki,
+                ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
+             }
 
   | isAlgTyCon tycon
   = IfaceData {        ifName    = getOccName tycon,
@@ -1346,6 +1393,8 @@ toIfaceVar v
   | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
          -- Foreign calls have special syntax
   | isExternalName name                    = IfaceExt name
+  | Just (TickBox m ix) <- isTickBoxOp_maybe v
+                                   = IfaceTick m ix
   | otherwise                      = IfaceLcl (getFS name)
   where
     name = idName v