Haskell Program Coverage

[ghc-hetmet.git] / compiler / typecheck / TcRnDriver.lhs

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 8cb815f..bd4eb9b 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -37,6 +37,7 @@ import TcExpr
 import TcRnMonad
 import TcType
 import Inst
+import FamInst
 import InstEnv
 import FamInstEnv
 import TcBinds
@@ -167,9 +168,17 @@ tcRnModule hsc_env hsc_src save_rn_syntax
         traceIf (text "rdr_env: " <+> ppr rdr_env) ;
        failIfErrsM ;
 
-               -- Load any orphan-module interfaces, so that
-               -- their rules and instance decls will be found
-       loadOrphanModules (imp_orphs imports) ;
+               -- Load any orphan-module and family instance-module
+               -- interfaces, so that their rules and instance decls will be
+               -- found.
+       loadOrphanModules (imp_orphs  imports) False ;
+       loadOrphanModules (imp_finsts imports) True  ;
+
+       let { directlyImpMods =   map (\(mod, _, _) -> mod) 
+                               . moduleEnvElts 
+                               . imp_mods 
+                               $ imports } ;
+       checkFamInstConsistency (imp_finsts imports) directlyImpMods ;
 
        traceRn (text "rn1a") ;
                -- Rename and type check the declarations
@@ -191,6 +200,8 @@ tcRnModule hsc_env hsc_src save_rn_syntax
                -- Process the export list
        (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ;
                  
+       traceRn (text "rn4") ;
+
                -- Rename the Haddock documentation header 
        rn_module_doc <- rnMbHsDoc maybe_doc ;
 
@@ -292,7 +303,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                mg_rdr_env   = emptyGlobalRdrEnv,
                                mg_fix_env   = emptyFixityEnv,
                                mg_deprecs   = NoDeprecs,
-                               mg_foreign   = NoStubs
+                               mg_foreign   = NoStubs,
+                               mg_hpc_info = noHpcInfo
                    } } ;
 
    tcCoreDump mod_guts ;
@@ -452,7 +464,7 @@ tcRnHsBootDecls decls
        ; gbl_env <- getGblEnv 
        
                -- Make the final type-env
-               -- Include the dfun_ids so that their type sigs get
+               -- Include the dfun_ids so that their type sigs
                -- are written into the interface file
        ; let { type_env0 = tcg_type_env gbl_env
              ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
@@ -480,7 +492,7 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id)
 
 checkHiBootIface
        (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts,
-                   tcg_type_env = local_type_env, tcg_imports = imports })
+                   tcg_type_env = local_type_env })
        (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
                      md_types = boot_type_env })
   = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ;
@@ -495,8 +507,11 @@ checkHiBootIface
        ; return (unionManyBags dfun_binds) }
   where
     check_one boot_thing
-      | no_check name
-      = return ()      
+      | isImplicitTyThing boot_thing = return ()
+      | name `elem` dfun_names       = return ()       
+      | isWiredInName name          = return ()        -- No checking for wired-in names.  In particular,
+                                                       -- 'error' is handled by a rather gross hack
+                                                       -- (see comments in GHC.Err.hs-boot)
       | Just real_thing <- lookupTypeEnv local_type_env name
       = do { let boot_decl = tyThingToIfaceDecl boot_thing
                 real_decl = tyThingToIfaceDecl real_thing
@@ -509,17 +524,6 @@ checkHiBootIface
       where
        name = getName boot_thing
 
-    avail_env = imp_parent imports
-    is_implicit name = case lookupNameEnv avail_env name of
-                         Just (AvailTC tc _) | tc /= name -> True
-                         _otherwise -> False
-
-    no_check name = isWiredInName name -- No checking for wired-in names.  In particular,
-                                       -- 'error' is handled by a rather gross hack
-                                       -- (see comments in GHC.Err.hs-boot)
-                 || name `elem` dfun_names
-                 || is_implicit name   -- Has a parent, which we'll check
-
     dfun_names = map getName boot_insts
 
     check_inst boot_inst
@@ -1098,9 +1102,12 @@ tcGetModuleExports :: Module -> TcM [AvailInfo]
 tcGetModuleExports mod = do
   let doc = ptext SLIT("context for compiling statements")
   iface <- initIfaceTcRn $ loadSysInterface doc mod
-  loadOrphanModules (dep_orphs (mi_deps iface))
+  loadOrphanModules (dep_orphs (mi_deps iface)) False 
                -- Load any orphan-module interfaces,
                -- so their instances are visible
+  loadOrphanModules (dep_finsts (mi_deps iface)) True
+               -- Load any family instance-module interfaces,
+               -- so all family instances are visible
   ifaceExportNames (mi_exports iface)
 
 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
@@ -1272,6 +1279,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
                        tcg_rules     = rules,
                        tcg_imports   = imports })
   = vcat [ ppr_types insts type_env
+        , ppr_tycons fam_insts type_env
         , ppr_insts insts
         , ppr_fam_insts fam_insts
         , vcat (map ppr rules)
@@ -1300,6 +1308,17 @@ ppr_types insts type_env
        -- that the type checker has invented.  Top-level user-defined things 
        -- have External names.
 
+ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
+ppr_tycons fam_insts type_env
+  = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons)
+  where
+    fi_tycons = map famInstTyCon fam_insts
+    tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
+    want_tycon tycon | opt_PprStyle_Debug = True
+                    | otherwise          = not (isImplicitTyCon tycon) &&
+                                           isExternalName (tyConName tycon) &&
+                                           not (tycon `elem` fi_tycons)
+
 ppr_insts :: [Instance] -> SDoc
 ppr_insts []     = empty
 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
@@ -1317,6 +1336,16 @@ ppr_sigs ids
     le_sig id1 id2 = getOccName id1 <= getOccName id2
     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
 
+ppr_tydecls :: [TyCon] -> SDoc
+ppr_tydecls tycons
+       -- Print type constructor info; sort by OccName 
+  = vcat (map ppr_tycon (sortLe le_sig tycons))
+  where
+    le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
+    ppr_tycon tycon 
+      | isCoercionTyCon tycon = ptext SLIT("coercion") <+> ppr tycon
+      | otherwise             = ppr (tyThingToIfaceDecl (ATyCon tycon))
+
 ppr_rules :: [CoreRule] -> SDoc
 ppr_rules [] = empty
 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),