%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcModule]{Typechecking a whole module}
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
-import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
-import StaticFlags ( opt_PprStyle_Debug )
-import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
- SpliceDecl(..), HsBind(..), LHsBinds,
- emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds,
- nlHsApp, nlHsVar, pprLHsBinds, HaddockModInfo(..) )
-import RdrHsSyn ( findSplice )
-
-import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
- main_RDR_Unqual )
-import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )
-import TcHsSyn ( zonkTopDecls )
-import TcExpr ( tcInferRho )
+import DynFlags
+import StaticFlags
+import HsSyn
+import RdrHsSyn
+
+import PrelNames
+import RdrName
+import TcHsSyn
+import TcExpr
import TcRnMonad
-import TcType ( tidyTopType, tcEqType )
-import Inst ( showLIE )
-import InstEnv ( extendInstEnvList, Instance, pprInstances,
- instanceDFunId )
-import FamInstEnv ( FamInst, pprFamInsts )
-import TcBinds ( tcTopBinds, tcHsBootSigs )
-import TcDefaults ( tcDefaults )
-import TcEnv ( tcExtendGlobalValEnv, iDFunId )
-import TcRules ( tcRules )
-import TcForeign ( tcForeignImports, tcForeignExports )
-import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcIface ( tcExtCoreBindings, tcHiBootIface )
-import MkIface ( tyThingToIfaceDecl )
-import IfaceSyn ( checkBootDecl, IfaceExtName(..) )
-import TcSimplify ( tcSimplifyTop )
-import TcTyClsDecls ( tcTyAndClassDecls )
-import LoadIface ( loadOrphanModules )
-import RnNames ( importsFromLocalDecls, rnImports, rnExports,
- mkRdrEnvAndImports, mkExportNameSet,
- reportUnusedNames, reportDeprecations )
-import RnEnv ( lookupSrcOcc_maybe )
-import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
-import RnHsDoc ( rnMbHsDoc )
-import PprCore ( pprRules, pprCoreBindings )
-import CoreSyn ( CoreRule, bindersOfBinds )
-import ErrUtils ( Messages, mkDumpDoc, showPass )
-import Id ( Id, mkExportedLocalId, isLocalId, idName, idType )
-import Var ( Var )
+import TcType
+import Inst
+import FamInst
+import InstEnv
+import FamInstEnv
+import TcBinds
+import TcDefaults
+import TcEnv
+import TcRules
+import TcForeign
+import TcInstDcls
+import TcIface
+import MkIface
+import IfaceSyn
+import TcSimplify
+import TcTyClsDecls
+import LoadIface
+import RnNames
+import RnEnv
+import RnSource
+import RnHsDoc
+import PprCore
+import CoreSyn
+import ErrUtils
+import Id
+import Var
import Module
-import UniqFM ( elemUFM, eltsUFM )
-import OccName ( mkVarOccFS, plusOccEnv )
-import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
- nameModule, nameOccName, isImplicitName, mkExternalName )
+import UniqFM
+import Name
import NameSet
-import TyCon ( tyConHasGenerics )
-import SrcLoc ( srcLocSpan, Located(..), noLoc )
-import DriverPhases ( HscSource(..), isHsBoot )
-import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails,
- HscEnv(..), ExternalPackageState(..),
- IsBootInterface, noDependencies,
- Deprecs( NoDeprecs ), plusDeprecs,
- ForeignStubs(NoStubs),
- TypeEnv, lookupTypeEnv, hptInstances,
- extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts,
- emptyFixityEnv
- )
+import TyCon
+import SrcLoc
+import HscTypes
import Outputable
#ifdef GHCI
-import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..),
- HsLocalBinds(..), HsValBinds(..),
- LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds,
- collectLStmtsBinders, collectLStmtBinders, nlVarPat,
- mkFunBind, placeHolderType, noSyntaxExpr, nlHsTyApp )
-import RdrName ( GlobalRdrElt(..), globalRdrEnvElts,
- unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
-import RnSource ( addTcgDUs )
-import TcHsSyn ( mkHsDictLet, zonkTopLExpr, zonkTopBndrs )
-import TcHsType ( kcHsType )
-import TcMType ( zonkTcType, zonkQuantifiedTyVar )
-import TcMatches ( tcStmts, tcDoStmt )
-import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
-import TcGadt ( emptyRefinement )
-import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy,
- isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy )
-import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
-import TypeRep ( TyThing(..) )
-import RnTypes ( rnLHsType )
-import Inst ( tcGetInstEnvs )
-import InstEnv ( classInstances, instEnvElts )
-import RnExpr ( rnStmts, rnLExpr )
-import LoadIface ( loadSysInterface )
-import IfaceEnv ( ifaceExportNames )
-import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
-import Id ( setIdType )
-import MkId ( unsafeCoerceId )
-import TyCon ( tyConName )
-import TysWiredIn ( mkListTy, unitTy )
-import IdInfo ( GlobalIdDetails(..) )
-import {- Kind parts of -} Type ( Kind )
-import Var ( globaliseId )
-import Name ( isBuiltInSyntax, isInternalName )
-import OccName ( isTcOcc )
-import NameEnv ( delListFromNameEnv )
-import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName,
- bindIOName, thenIOName, returnIOName )
-import HscTypes ( InteractiveContext(..),
- ModIface(..), icPrintUnqual,
- Dependencies(..) )
-import BasicTypes ( Fixity, RecFlag(..) )
-import SrcLoc ( unLoc )
-import Data.Maybe ( isNothing )
+import TcHsType
+import TcMType
+import TcMatches
+import TcGadt
+import RnTypes
+import RnExpr
+import IfaceEnv
+import MkId
+import TysWiredIn
+import IdInfo
+import {- Kind parts of -} Type
+import BasicTypes
+import Data.Maybe
#endif
-import FastString ( mkFastString )
-import Util ( sortLe )
-import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
+import FastString
+import Util
+import Bag
import Control.Monad ( unless )
import Data.Maybe ( isJust )
setSrcSpan loc $
do {
-- Deal with imports;
- rn_imports <- rnImports import_decls ;
- (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ;
+ (rn_imports, rdr_env, imports) <- rnImports import_decls ;
let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
; dep_mods = imp_dep_mods imports
-- Fail if there are any errors so far
-- The error printing (if needed) takes advantage
-- of the tcg_env we have now set
+ 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
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
reportDeprecations (hsc_dflags hsc_env) tcg_env ;
-- Process the export list
- rn_exports <- rnExports export_ies ;
+ (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ;
+ traceRn (text "rn4") ;
+
-- Rename the Haddock documentation header
rn_module_doc <- rnMbHsDoc maybe_doc ;
rn_description <- rnMbHsDoc (hmi_description module_info) ;
let { rn_module_info = module_info { hmi_description = rn_description } } ;
- let { liftM2' fn a b = do a' <- a; b' <- b; return (fn a' b') } ;
- exports <- mkExportNameSet (isJust maybe_mod)
- (liftM2' (,) rn_exports export_ies) ;
-
-- Check whether the entire module is deprecated
-- This happens only once per module
let { mod_deprecs = checkModDeprec mod_deprec } ;
tcg_rn_exports = if save_rn_syntax then
rn_exports
else Nothing,
- tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
+ tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (availsToNameSet exports),
tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
mod_deprecs,
tcg_doc = rn_module_doc,
-- Wrap up
let {
bndrs = bindersOfBinds core_binds ;
- my_exports = mkNameSet (map idName bndrs) ;
+ my_exports = map (Avail . idName) bndrs ;
-- ToDo: export the data types also?
final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
mg_rdr_env = emptyGlobalRdrEnv,
mg_fix_env = emptyFixityEnv,
mg_deprecs = NoDeprecs,
- mg_foreign = NoStubs
+ mg_foreign = NoStubs,
+ mg_hpc_info = noHpcInfo
} } ;
tcCoreDump mod_guts ;
boot_iface <- tcHiBootIface mod ;
-- Do all the declarations
- (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ;
-
- -- 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.)
- 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)
+ tcg_env <- tc_rn_src_decls boot_iface decls ;
-- 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,
+ let { TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
- (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
- rules fords ;
+ (bind_ids, binds', fords', rules') <- zonkTopDecls binds rules fords ;
let { final_type_env = extendTypeEnvWithIds type_env bind_ids
; tcg_env' = tcg_env { tcg_type_env = final_type_env,
return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds })
}
-tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
+tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
-- Loops around dealing with each top level inter-splice group
-- in turn, until it's dealt with the entire module
tc_rn_src_decls boot_details ds
= 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) <- rnTopSrcDecls first_group ;
+ ((tcg_env, tcl_env), lie) <- getLIE $ setGblEnv tcg_env $
+ tcTopSrcDecls boot_details rn_decls ;
- -- 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 ;
+ -- 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.
+ traceTc (text "Tc8") ;
+ inst_binds <- setEnvs (tcg_env, tcl_env) (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)
+
+ let { tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` inst_binds } } ;
- setEnvs tc_envs $
+ setEnvs (tcg_env', tcl_env) $
-- If there is no splice, we're nearly done
case group_tail of {
- Nothing -> do { -- Last thing: check for `main'
- tcg_env <- checkMain ;
- return (tcg_env, tcl_env)
- } ;
+ Nothing -> -- Last thing: check for `main'
+ checkMain ;
-- If there's a splice, we must carry on
- Just (SpliceDecl splice_expr, rest_ds) -> do {
+ Just (SpliceDecl splice_expr, rest_ds) ->
+ do {
#ifndef GHCI
failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
#else
; 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
; 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 ext_nm boot_thing
- real_decl = tyThingToIfaceDecl ext_nm real_thing
+ = do { let boot_decl = tyThingToIfaceDecl boot_thing
+ real_decl = tyThingToIfaceDecl real_thing
; checkTc (checkBootDecl boot_decl real_decl)
(bootMisMatch boot_thing boot_decl real_decl) }
-- The easiest way to check compatibility is to convert to
where
name = getName boot_thing
- ext_nm name = ExtPkg (nameModule name) (nameOccName name)
- -- Just enough to compare; no versions etc needed
-
- 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
- || isImplicitName name -- Has a parent, which we'll check
-
dfun_names = map getName boot_insts
check_inst boot_inst
where
boot_dfun = instanceDFunId boot_inst
boot_inst_ty = idType boot_dfun
- local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty
+ local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
----------------
missingBootThing thing
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
; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
(mkVarOccFS FSLIT("main"))
- (Just main_name) (getSrcLoc main_name)
- ; root_main_id = mkExportedLocalId root_main_name ty
+ (getSrcLoc main_name)
+ ; root_main_id = Id.mkExportedLocalId root_main_name ty
; main_bind = noLoc (VarBind root_main_id main_expr) }
; return (tcg_env { tcg_binds = tcg_binds tcg_env
globaliseAndTidy :: Id -> Id
globaliseAndTidy id
-- Give the Id a Global Name, and tidy its type
- = setIdType (globaliseId VanillaGlobal id) tidy_type
+ = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
where
tidy_type = tidyTopType (idType id)
\end{code}
-- a package module with an interface on disk. If neither of these is
-- true, then the result will be an error indicating the interface
-- could not be found.
-getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe NameSet)
+getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
getModuleExports hsc_env mod
= initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
-tcGetModuleExports :: Module -> TcM NameSet
+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])
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"),