tcRnLookupName,
tcRnGetInfo,
getModuleExports,
+ tcRnRecoverDataCon,
#endif
tcRnModule,
tcTopSrcDecls,
import TcRnMonad
import TcType
import Inst
+import FamInst
import InstEnv
import FamInstEnv
import TcBinds
import UniqFM
import Name
import NameSet
-import NameEnv
import TyCon
import SrcLoc
import HscTypes
import Outputable
+import Breakpoints
#ifdef GHCI
+import Linker
+import DataCon
import TcHsType
import TcMType
import TcMatches
loadOrphanModules (imp_orphs imports) False ;
loadOrphanModules (imp_finsts imports) True ;
+ traceRn (text "rn1: checking family instance consistency") ;
+ let { directlyImpMods = map (\(mod, _, _) -> mod)
+ . moduleEnvElts
+ . imp_mods
+ $ imports } ;
+ checkFamInstConsistency (imp_finsts imports) directlyImpMods ;
+
traceRn (text "rn1a") ;
-- Rename and type check the declarations
tcg_env <- if isHsBoot hsc_src then
tcRnSrcDecls local_decls ;
setGblEnv tcg_env $ do {
+ failIfErrsM ; -- reportDeprecations crashes sometimes
+ -- as a result of typechecker repairs (e.g. unboundNames)
traceRn (text "rn3") ;
-- Report the use of any deprecated things
-- 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_types = final_type_env,
mg_insts = tcg_insts tcg_env,
mg_fam_insts = tcg_fam_insts tcg_env,
+ mg_fam_inst_env = tcg_fam_inst_env tcg_env,
mg_rules = [],
mg_binds = core_binds,
mg_rdr_env = emptyGlobalRdrEnv,
mg_fix_env = emptyFixityEnv,
mg_deprecs = NoDeprecs,
- mg_foreign = NoStubs
+ mg_foreign = NoStubs,
+ mg_hpc_info = noHpcInfo,
+ mg_dbg_sites = noDbgSites
} } ;
tcCoreDump mod_guts ;
boot_iface <- tcHiBootIface mod ;
-- Do all the declarations
- (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ;
+ (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ;
+ -- Finish simplifying class constraints
+ --
-- tcSimplifyTop deals with constant or ambiguous InstIds.
-- How could there be ambiguous ones? They can only arise if a
- -- top-level decl falls under the monomorphism
- -- restriction, and no subsequent decl instantiates its
- -- type. (Usually, ambiguous type variables are resolved
- -- during the generalisation step.)
+ -- top-level decl falls under the monomorphism restriction
+ -- and no subsequent decl instantiates its type.
+ --
+ -- We do this after checkMain, so that we use the type info
+ -- thaat checkMain adds
+ --
+ -- We do it with both global and local env in scope:
+ -- * the global env exposes the instances to tcSimplifyTop
+ -- * the local env exposes the local Ids to tcSimplifyTop,
+ -- so that we get better error messages (monomorphism restriction)
traceTc (text "Tc8") ;
inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
- -- Setting the global env exposes the instances to tcSimplifyTop
- -- Setting the local env exposes the local Ids to tcSimplifyTop,
- -- so that we get better error messages (monomorphism restriction)
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
traceTc (text "Tc9") ;
- let { (tcg_env, _) = tc_envs ;
- TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
- tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
+ let { (tcg_env, _) = tc_envs
+ ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
+ tcg_rules = rules, tcg_fords = fords } = tcg_env
+ ; all_binds = binds `unionBags` inst_binds } ;
- (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
- rules fords ;
+ (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
let { final_type_env = extendTypeEnvWithIds type_env bind_ids
; tcg_env' = tcg_env { tcg_type_env = final_type_env,
= do { let { (first_group, group_tail) = findSplice ds } ;
-- If ds is [] we get ([], Nothing)
- -- Type check the decls up to, but not including, the first splice
- tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ;
+ -- Deal with decls up to, but not including, the first splice
+ (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ;
+ -- checkNoErrs: stop if renaming fails
- -- Bale out if errors; for example, error recovery when checking
- -- the RHS of 'main' can mean that 'main' is not in the envt for
- -- the subsequent checkMain test
- failIfErrsM ;
-
- setEnvs tc_envs $
+ (tcg_env, tcl_env) <- setGblEnv tcg_env $
+ tcTopSrcDecls boot_details rn_decls ;
-- If there is no splice, we're nearly done
+ setEnvs (tcg_env, tcl_env) $
case group_tail of {
- Nothing -> do { -- Last thing: check for `main'
- tcg_env <- checkMain ;
+ Nothing -> do { tcg_env <- checkMain ; -- Check for `main'
return (tcg_env, tcl_env)
} ;
#else
-- Rename the splice expression, and get its supporting decls
- (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
- failIfErrsM ; -- Don't typecheck if renaming failed
+ (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
+ -- checkNoErrs: don't typecheck if renaming failed
rnDump (ppr rn_splice_expr) ;
-- Execute the splice
setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
#endif /* GHCI */
- }}}
+ } } }
\end{code}
%************************************************************************
; 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
monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
- -- Returns the variables free in the decls, for unused-binding reporting
-tcRnGroup boot_details decls
- = do { -- Rename the declarations
- (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
- setGblEnv tcg_env $ do {
-
- -- Typecheck the declarations
- tcTopSrcDecls boot_details rn_decls
- }}
-
------------------------------------------------
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
rnTopSrcDecls group
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
- ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
+ ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
tcSimplifyInteractive lie_top ;
- qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
- let { all_expr_ty = mkForAllTys qtvs' $
- mkFunTys (map idType dict_ids) $
+ let { all_expr_ty = mkForAllTys qtvs $
+ mkFunTys (map (idType . instToId) dict_insts) $
res_ty } ;
zonkTcType all_expr_ty
}
-- could not be found.
getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
getModuleExports hsc_env mod
- = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
-
-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)) False
- -- Load any orphan-module interfaces,
- -- so their instances are visible
- loadOrphanModules (dep_finsts (mi_finsts iface)) True
- -- Load any family instance-module interfaces,
- -- so all family instances are visible
- ifaceExportNames (mi_exports iface)
+ = let
+ ic = hsc_IC hsc_env
+ checkMods = ic_toplev_scope ic ++ ic_exports ic
+ in
+ initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod checkMods)
+
+-- Get the export avail info and also load all orphan and family-instance
+-- modules. Finally, check that the family instances of all modules in the
+-- interactive context are consistent (these modules are in the second
+-- argument).
+tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo]
+tcGetModuleExports mod directlyImpMods
+ = do { let doc = ptext SLIT("context for compiling statements")
+ ; iface <- initIfaceTcRn $ loadSysInterface doc mod
+
+ -- Load any orphan-module and family instance-module
+ -- interfaces, so their instances are visible.
+ ; loadOrphanModules (dep_orphs (mi_deps iface)) False
+ ; loadOrphanModules (dep_finsts (mi_deps iface)) True
+
+ -- Check that the family instances of all directly loaded
+ -- modules are consistent.
+ ; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods
+
+ ; ifaceExportNames (mi_exports iface)
+ }
tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
tcRnLookupRdrName hsc_env rdr_name
return good_names
}
+tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon)
+tcRnRecoverDataCon hsc_env a
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $
+ do name <- recoverDataCon a
+ tcLookupDataCon name
tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
tcRnLookupName hsc_env name
ispecs <- lookupInsts (icPrintUnqual ictxt) thing
return (thing, fixity, ispecs)
-
lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
-- Filter the instances by the ones whose tycons (or clases resp)
-- are in scope unqualified. Otherwise we list a whole lot too many!
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"),
projects / ghc-hetmet.git / blobdiff