import TcRnMonad
import TcType
import Inst
+import FamInst
import InstEnv
import FamInstEnv
import TcBinds
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
-- 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 ;
mg_rdr_env = emptyGlobalRdrEnv,
mg_fix_env = emptyFixityEnv,
mg_deprecs = NoDeprecs,
- mg_foreign = NoStubs
+ mg_foreign = NoStubs,
+ mg_hpc_info = noHpcInfo
} } ;
tcCoreDump mod_guts ;
; 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
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)) ;
; 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
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
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])
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)
-- 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)
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"),