%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcModule]{Typechecking a whole module}
\begin{code}
module TcRnDriver (
#ifdef GHCI
tcRnStmt, tcRnExpr, tcRnType,
tcRnLookupRdrName,
getModuleExports,
#endif
tcRnLookupName,
tcRnGetInfo,
tcRnModule,
tcTopSrcDecls,
tcRnExtCore
) where
#ifdef GHCI
import TcSplice ( tcSpliceDecls )
#endif
import DynFlags
import StaticFlags
import HsSyn
import PrelNames
import RdrName
import TcHsSyn
import TcExpr
import TcRnMonad
import Coercion
import FamInst
import InstEnv
import FamInstEnv
import TcAnnotations
import TcBinds
import TcType ( tidyTopType )
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
import TcMType
import MkIface
import IfaceSyn
import TcSimplify
import TcTyClsDecls
import LoadIface
import RnNames
import RnEnv
import RnSource
import PprCore
import CoreSyn
import ErrUtils
import Id
import VarEnv
import Var
import Module
import UniqFM
import Name
import NameEnv
import NameSet
import TyCon
import TysPrim
import SrcLoc
import HscTypes
import ListSetOps
import Outputable
import DataCon
import Type
import Class
import TcType ( orphNamesOfDFunHead )
import Inst ( tcGetInstEnvs )
import Data.List ( sortBy )
#ifdef GHCI
import TcType ( isUnitTy, isTauTy )
import CoreUtils( mkPiTypes )
import TcHsType
import TcMatches
import RnTypes
import RnExpr
import IfaceEnv
import MkId
import BasicTypes
import TidyPgm ( globaliseAndTidyId )
import TysWiredIn ( unitTy, mkListTy )
#endif
import FastString
import Maybes
import Util
import Bag
import Control.Monad
#include "HsVersions.h"
\end{code}
%************************************************************************
%* *
Typecheck and rename a module
%* *
%************************************************************************
\begin{code}
tcRnModule :: HscEnv
-> HscSource
-> Bool
-> Located (HsModule RdrName)
-> IO (Messages, Maybe TcGblEnv)
tcRnModule hsc_env hsc_src save_rn_syntax
(L loc (HsModule maybe_mod export_ies
import_decls local_decls mod_deprec
maybe_doc_hdr))
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
this_mod = case maybe_mod of
Nothing -> mAIN
Just (L _ mod) -> mkModule this_pkg mod } ;
initTc hsc_env hsc_src save_rn_syntax this_mod $
setSrcSpan loc $
do {
tcg_env <- tcRnImports hsc_env this_mod import_decls ;
setGblEnv tcg_env $ do {
boot_iface <- tcHiBootIface hsc_src this_mod ;
traceRn (text "rn1a") ;
tcg_env <- if isHsBoot hsc_src then
tcRnHsBootDecls local_decls
else
tcRnSrcDecls boot_iface local_decls ;
setGblEnv tcg_env $ do {
traceRn (text "rn3") ;
failIfErrsM ;
tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ;
traceRn (text "rn4a: before exports");
tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
traceRn (text "rn4b: after exportss") ;
checkMainExported tcg_env ;
tcg_env <- checkHiBootIface tcg_env boot_iface ;
tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
reportUnusedNames export_ies tcg_env ;
tcDump tcg_env ;
return tcg_env
}}}}
\end{code}
%************************************************************************
%* *
Import declarations
%* *
%************************************************************************
\begin{code}
tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv
tcRnImports hsc_env this_mod import_decls
= do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ;
; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
; dep_mods = imp_dep_mods imports
; want_instances :: ModuleName -> Bool
; want_instances mod = mod `elemUFM` dep_mods
&& mod /= moduleName this_mod
; (home_insts, home_fam_insts) = hptInstances hsc_env
want_instances
} ;
; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
; updGblEnv ( \ gbl ->
gbl {
tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env,
tcg_imports = tcg_imports gbl `plusImportAvails` imports,
tcg_rn_imports = rn_imports,
tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
home_fam_insts,
tcg_hpc = hpc_info
}) $ do {
; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
; failIfErrsM
; loadOrphanModules (imp_orphs imports) False
; loadOrphanModules (imp_finsts imports) True
; traceRn (text "rn1: checking family instance consistency")
; let { dir_imp_mods = moduleEnvKeys
. imp_mods
$ imports }
; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
; getGblEnv } }
\end{code}
%************************************************************************
%* *
Type-checking external-core modules
%* *
%************************************************************************
\begin{code}
tcRnExtCore :: HscEnv
-> HsExtCore RdrName
-> IO (Messages, Maybe ModGuts)
tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
initTc hsc_env ExtCoreFile False this_mod $ do {
let { ldecls = map noLoc decls } ;
avails <- getLocalNonValBinders (mkFakeGroup ldecls) ;
tc_envs <- extendGlobalRdrEnvRn avails emptyFsEnv ;
setEnvs tc_envs $ do {
(rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ;
rnDump (ppr rn_decls) ;
(tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ;
setGblEnv tcg_env $ do {
core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
let {
bndrs = bindersOfBinds core_binds ;
my_exports = map (Avail . idName) bndrs ;
final_type_env =
extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
mod_guts = ModGuts { mg_module = this_mod,
mg_boot = False,
mg_used_names = emptyNameSet,
mg_dir_imps = emptyModuleEnv,
mg_deps = noDependencies,
mg_exports = my_exports,
mg_types = final_type_env,
mg_insts = tcg_insts tcg_env,
mg_fam_insts = tcg_fam_insts tcg_env,
mg_inst_env = tcg_inst_env tcg_env,
mg_fam_inst_env = tcg_fam_inst_env tcg_env,
mg_rules = [],
mg_anns = [],
mg_binds = core_binds,
mg_rdr_env = emptyGlobalRdrEnv,
mg_fix_env = emptyFixityEnv,
mg_warns = NoWarnings,
mg_foreign = NoStubs,
mg_hpc_info = emptyHpcInfo False,
mg_modBreaks = emptyModBreaks,
mg_vect_info = noVectInfo
} } ;
tcCoreDump mod_guts ;
return mod_guts
}}}}
mkFakeGroup :: [LTyClDecl a] -> HsGroup a
mkFakeGroup decls
= emptyRdrGroup { hs_tyclds = [decls] }
\end{code}
%************************************************************************
%* *
Type-checking the top level of a module
%* *
%************************************************************************
\begin{code}
tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
tcRnSrcDecls boot_iface decls
= do {
(tc_envs, lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
; traceTc "Tc8" empty ;
; setEnvs tc_envs $
do {
new_ev_binds <- simplifyTop lie ;
traceTc "Tc9" empty ;
failIfErrsM ;
let { (tcg_env, _) = tc_envs
; TcGblEnv { tcg_type_env = type_env,
tcg_binds = binds,
tcg_sigs = sig_ns,
tcg_ev_binds = cur_ev_binds,
tcg_imp_specs = imp_specs,
tcg_rules = rules,
tcg_fords = fords } = tcg_env
; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
(bind_ids, ev_binds', binds', fords', imp_specs', rules')
<- zonkTopDecls all_ev_binds binds sig_ns rules imp_specs fords ;
let { final_type_env = extendTypeEnvWithIds type_env bind_ids
; tcg_env' = tcg_env { tcg_binds = binds',
tcg_ev_binds = ev_binds',
tcg_imp_specs = imp_specs',
tcg_rules = rules',
tcg_fords = fords' } } ;
setGlobalTypeEnv tcg_env' final_type_env
} }
tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
tc_rn_src_decls boot_details ds
= do { (first_group, group_tail) <- findSplice ds ;
(tcg_env, rn_decls) <- rnTopSrcDecls first_group ;
(tcg_env, tcl_env) <- setGblEnv tcg_env $
tcTopSrcDecls boot_details rn_decls ;
setEnvs (tcg_env, tcl_env) $
case group_tail of {
Nothing -> do { tcg_env <- checkMain ;
return (tcg_env, tcl_env)
} ;
#ifndef GHCI
Just (SpliceDecl {}, _) -> do {
failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
#else
Just (SpliceDecl splice_expr _, rest_ds) -> do {
(rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
rnDump (ppr rn_splice_expr) ;
spliced_decls <- tcSpliceDecls rn_splice_expr ;
setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
#endif /* GHCI */
} } }
\end{code}
%************************************************************************
%* *
Compiling hs-boot source files, and
comparing the hi-boot interface with the real thing
%* *
%************************************************************************
\begin{code}
tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
tcRnHsBootDecls decls
= do { (first_group, group_tail) <- findSplice decls
; (tcg_env, HsGroup {
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_derivds = deriv_decls,
hs_fords = for_decls,
hs_defds = def_decls,
hs_ruleds = rule_decls,
hs_annds = _,
hs_valds = val_binds }) <- rnTopSrcDecls first_group
; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
; case group_tail of
Just (SpliceDecl d _, _) -> badBootDecl "splice" d
Nothing -> return ()
; mapM_ (badBootDecl "foreign") for_decls
; mapM_ (badBootDecl "default") def_decls
; mapM_ (badBootDecl "rule") rule_decls
; traceTc "Tc2" empty
; (tcg_env, aux_binds, dm_ids)
<- tcTyAndClassDecls emptyModDetails tycl_decls
; setGblEnv tcg_env $
tcExtendIdEnv dm_ids $ do {
; traceTc "Tc3" empty
; (tcg_env, inst_infos, _deriv_binds)
<- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls
; setGblEnv tcg_env $ do {
; traceTc "Tc5" empty
; val_ids <- tcHsBootSigs val_binds
; traceTc "Tc7a" empty
; gbl_env <- getGblEnv
; let { type_env0 = tcg_type_env gbl_env
; type_env1 = extendTypeEnvWithIds type_env0 val_ids
; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
; type_env3 = extendTypeEnvWithIds type_env2 aux_ids
; dfun_ids = map iDFunId inst_infos
; aux_ids = case aux_binds of
ValBindsOut _ sigs -> [id | L _ (IdSig id) <- sigs]
_ -> panic "tcRnHsBoodDecls"
}
; setGlobalTypeEnv gbl_env type_env3
}}}
; traceTc "boot" (ppr lie); return gbl_env }
badBootDecl :: String -> Located decl -> TcM ()
badBootDecl what (L loc _)
= addErrAt loc (char 'A' <+> text what
<+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file"))
\end{code}
Once we've typechecked the body of the module, we want to compare what
we've found (gathered in a TypeEnv) with the hi-boot details (if any).
\begin{code}
checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv
checkHiBootIface
tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds,
tcg_insts = local_insts,
tcg_type_env = local_type_env, tcg_exports = local_exports })
(ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
md_types = boot_type_env, md_exports = boot_exports })
| isHsBoot hs_src
= return tcg_env
| otherwise
= do { traceTc "checkHiBootIface" $ vcat
[ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
; mapM_ check_export boot_exports
; unless (null boot_fam_insts) $
panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
"instances in boot files yet...")
; mb_dfun_prs <- mapM check_inst boot_insts
; let dfun_prs = catMaybes mb_dfun_prs
boot_dfuns = map fst dfun_prs
dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
| (boot_dfun, dfun) <- dfun_prs ]
type_env' = extendTypeEnvWithIds local_type_env boot_dfuns
tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
; failIfErrsM
; setGlobalTypeEnv tcg_env' type_env' }
where
check_export boot_avail
| name `elem` dfun_names = return ()
| isWiredInName name = return ()
| not (null missing_names)
= addErrAt (nameSrcSpan (head missing_names))
(missingBootThing (head missing_names) "exported by")
| isNothing mb_boot_thing = return ()
| Just real_thing <- lookupTypeEnv local_type_env name,
Just boot_thing <- mb_boot_thing
= when (not (checkBootDecl boot_thing real_thing))
$ addErrAt (nameSrcSpan (getName boot_thing))
(let boot_decl = tyThingToIfaceDecl
(fromJust mb_boot_thing)
real_decl = tyThingToIfaceDecl real_thing
in bootMisMatch real_thing boot_decl real_decl)
| otherwise
= addErrTc (missingBootThing name "defined in")
where
name = availName boot_avail
mb_boot_thing = lookupTypeEnv boot_type_env name
missing_names = case lookupNameEnv local_export_env name of
Nothing -> [name]
Just avail -> availNames boot_avail `minusList` availNames avail
dfun_names = map getName boot_insts
local_export_env :: NameEnv AvailInfo
local_export_env = availsToNameEnv local_exports
check_inst :: Instance -> TcM (Maybe (Id, Id))
check_inst boot_inst
= case [dfun | inst <- local_insts,
let dfun = instanceDFunId inst,
idType dfun `tcEqType` boot_inst_ty ] of
[] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
, text "boot_inst" <+> ppr boot_inst
, text "boot_inst_ty" <+> ppr boot_inst_ty
])
; addErrTc (instMisMatch boot_inst); return Nothing }
(dfun:_) -> return (Just (local_boot_dfun, dfun))
where
boot_dfun = instanceDFunId boot_inst
boot_inst_ty = idType boot_dfun
local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
checkBootDecl :: TyThing -> TyThing -> Bool
checkBootDecl (AnId id1) (AnId id2)
= ASSERT(id1 == id2)
(idType id1 `tcEqType` idType id2)
checkBootDecl (ATyCon tc1) (ATyCon tc2)
= checkBootTyCon tc1 tc2
checkBootDecl (AClass c1) (AClass c2)
= let
(clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
= classExtraBigSig c1
(clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
= classExtraBigSig c2
env0 = mkRnEnv2 emptyInScopeSet
env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2
eqSig (id1, def_meth1) (id2, def_meth2)
= idName id1 == idName id2 &&
tcEqTypeX env op_ty1 op_ty2 &&
def_meth1 == def_meth2
where
(_, rho_ty1) = splitForAllTys (idType id1)
op_ty1 = funResultTy rho_ty1
(_, rho_ty2) = splitForAllTys (idType id2)
op_ty2 = funResultTy rho_ty2
eqFD (as1,bs1) (as2,bs2) =
eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2)
in
eqListBy same_kind clas_tyvars1 clas_tyvars2 &&
eqListBy eqFD clas_fds1 clas_fds2 &&
(null sc_theta1 && null op_stuff1 && null ats1
||
eqListBy (tcEqPredX env) sc_theta1 sc_theta2 &&
eqListBy eqSig op_stuff1 op_stuff2 &&
eqListBy checkBootTyCon ats1 ats2)
checkBootDecl (ADataCon dc1) (ADataCon _)
= pprPanic "checkBootDecl" (ppr dc1)
checkBootDecl _ _ = False
checkBootTyCon :: TyCon -> TyCon -> Bool
checkBootTyCon tc1 tc2
| not (eqKind (tyConKind tc1) (tyConKind tc2))
= False
| isSynTyCon tc1 && isSynTyCon tc2
= ASSERT(tc1 == tc2)
let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
env = rnBndrs2 env0 tvs1 tvs2
eqSynRhs SynFamilyTyCon SynFamilyTyCon
= True
eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
= tcEqTypeX env t1 t2
eqSynRhs _ _ = False
in
equalLength tvs1 tvs2 &&
eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2)
| isAlgTyCon tc1 && isAlgTyCon tc2
= ASSERT(tc1 == tc2)
eqKind (tyConKind tc1) (tyConKind tc2) &&
eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
| isForeignTyCon tc1 && isForeignTyCon tc2
= eqKind (tyConKind tc1) (tyConKind tc2) &&
tyConExtName tc1 == tyConExtName tc2
| otherwise = False
where
env0 = mkRnEnv2 emptyInScopeSet
eqAlgRhs AbstractTyCon _ = True
eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
eqListBy eqCon (data_cons tc1) (data_cons tc2)
eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
eqCon (data_con tc1) (data_con tc2)
eqAlgRhs _ _ = False
eqCon c1 c2
= dataConName c1 == dataConName c2
&& dataConIsInfix c1 == dataConIsInfix c2
&& dataConStrictMarks c1 == dataConStrictMarks c2
&& dataConFieldLabels c1 == dataConFieldLabels c2
&& let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1
tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2
env = rnBndrs2 env0 tvs1 tvs2
in
equalLength tvs1 tvs2 &&
eqListBy (tcEqPredX env)
(dataConEqTheta c1 ++ dataConDictTheta c1)
(dataConEqTheta c2 ++ dataConDictTheta c2) &&
eqListBy (tcEqTypeX env)
(dataConOrigArgTys c1)
(dataConOrigArgTys c2)
missingBootThing :: Name -> String -> SDoc
missingBootThing name what
= ppr name <+> ptext (sLit "is exported by the hs-boot file, but not")
<+> text what <+> ptext (sLit "the module")
bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc
bootMisMatch thing boot_decl real_decl
= vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"),
ptext (sLit "Main module:") <+> ppr real_decl,
ptext (sLit "Boot file: ") <+> ppr boot_decl]
instMisMatch :: Instance -> SDoc
instMisMatch inst
= hang (ppr inst)
2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
\end{code}
%************************************************************************
%* *
Type-checking the top level of a module
%* *
%************************************************************************
tcRnGroup takes a bunch of top-level source-code declarations, and
* renames them
* gets supporting declarations from interface files
* typechecks them
* zonks them
* and augments the TcGblEnv with the results
In Template Haskell it may be called repeatedly for each group of
declarations. It expects there to be an incoming TcGblEnv in the
monad; it augments it and returns the new TcGblEnv.
\begin{code}
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
rnTopSrcDecls group
= do {
traceTc "rn12" empty ;
(tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
traceTc "rn13" empty ;
let { tcg_env'
| Just grp <- tcg_rn_decls tcg_env
= tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
| otherwise
= tcg_env };
rnDump (ppr rn_decls) ;
return (tcg_env', rn_decls)
}
tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls boot_details
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_annds = annotation_decls,
hs_ruleds = rule_decls,
hs_valds = val_binds })
= do {
traceTc "Tc2" empty ;
(tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ;
setGblEnv tcg_env $
tcExtendIdEnv dm_ids $ do {
traceTc "Tc3" empty ;
(tcg_env, inst_infos, deriv_binds)
<- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls;
setGblEnv tcg_env $ do {
traceTc "Tc4" empty ;
(fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
tcExtendGlobalValEnv fi_ids $ do {
traceTc "Tc4a" empty ;
default_tys <- tcDefaults default_decls ;
updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
(tc_aux_binds, specs1, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ;
(tc_deriv_binds, specs2, tcl_env) <- setLclTypeEnv tcl_env $
discardWarnings (tcTopBinds deriv_binds) ;
traceTc "Tc5" empty ;
(tc_val_binds, specs3, tcl_env) <- setLclTypeEnv tcl_env $
tcTopBinds val_binds;
setLclTypeEnv tcl_env $ do {
traceTc "Tc6" empty ;
inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
traceTc "Tc7" empty ;
(foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
annotations <- tcAnnotations annotation_decls ;
rules <- tcRules rule_decls ;
traceTc "Tc7a" empty ;
tcg_env <- getGblEnv ;
let { all_binds = tc_val_binds `unionBags`
tc_deriv_binds `unionBags`
tc_aux_binds `unionBags`
inst_binds `unionBags`
foe_binds
; sig_names = mkNameSet (collectHsValBinders val_binds)
`minusNameSet` getTypeSigNames val_binds
; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
, tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++ specs3
, tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names
, tcg_rules = tcg_rules tcg_env ++ rules
, tcg_anns = tcg_anns tcg_env ++ annotations
, tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
return (tcg_env', tcl_env)
}}}}}}
\end{code}
%************************************************************************
%* *
Checking for 'main'
%* *
%************************************************************************
\begin{code}
checkMain :: TcM TcGblEnv
checkMain
= do { tcg_env <- getGblEnv ;
dflags <- getDOpts ;
check_main dflags tcg_env
}
check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv
check_main dflags tcg_env
| mod /= main_mod
= traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
return tcg_env
| otherwise
= do { mb_main <- lookupGlobalOccRn_maybe main_fn
; case mb_main of {
Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
; complain_no_main
; return tcg_env } ;
Just main_name -> do
{ traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
; let loc = srcLocSpan (getSrcLoc main_name)
; ioTyCon <- tcLookupTyCon ioTyConName
; res_ty <- newFlexiTyVarTy liftedTypeKind
; main_expr
<- addErrCtxt mainCtxt $
tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
; run_main_id <- tcLookupId runMainIOName
; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
(mkVarOccFS (fsLit "main"))
(getSrcSpan main_name)
; root_main_id = Id.mkExportedLocalId root_main_name
(mkTyConApp ioTyCon [res_ty])
; co = mkWpTyApps [res_ty]
; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
; main_bind = mkVarBind root_main_id rhs }
; return (tcg_env { tcg_main = Just main_name,
tcg_binds = tcg_binds tcg_env
`snocBag` main_bind,
tcg_dus = tcg_dus tcg_env
`plusDU` usesOnly (unitFV main_name)
})
}}}
where
mod = tcg_mod tcg_env
main_mod = mainModIs dflags
main_fn = getMainFun dflags
complain_no_main | ghcLink dflags == LinkInMemory = return ()
| otherwise = failWithTc noMainMsg
mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn
noMainMsg = ptext (sLit "The") <+> pp_main_fn
<+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
pp_main_fn = ppMainFn main_fn
ppMainFn :: RdrName -> SDoc
ppMainFn main_fn
| main_fn == main_RDR_Unqual
= ptext (sLit "function") <+> quotes (ppr main_fn)
| otherwise
= ptext (sLit "main function") <+> quotes (ppr main_fn)
getMainFun :: DynFlags -> RdrName
getMainFun dflags = case (mainFunIs dflags) of
Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
Nothing -> main_RDR_Unqual
checkMainExported :: TcGblEnv -> TcM ()
checkMainExported tcg_env = do
dflags <- getDOpts
case tcg_main tcg_env of
Nothing -> return ()
Just main_name -> do
let main_mod = mainModIs dflags
checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $
ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+>
ptext (sLit "is not exported by module") <+> quotes (ppr main_mod)
\end{code}
Note [Root-main Id]
~~~~~~~~~~~~~~~~~~~
The function that the RTS invokes is always :Main.main, which we call
root_main_id. (Because GHC allows the user to have a module not
called Main as the main module, we can't rely on the main function
being called "Main.main". That's why root_main_id has a fixed module
":Main".)
This is unusual: it's a LocalId whose Name has a Module from another
module. Tiresomely, we must filter it out again in MkIface, les we
get two defns for 'main' in the interface file!
%*********************************************************
%* *
GHCi stuff
%* *
%*********************************************************
\begin{code}
setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
setInteractiveContext hsc_env icxt thing_inside
= let
(home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)
in
updGblEnv (\env -> env {
tcg_rdr_env = ic_rn_gbl_env icxt,
tcg_inst_env = extendInstEnvList (tcg_inst_env env) home_insts,
tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env)
home_fam_insts
}) $
tcExtendGhciEnv (ic_tmp_ids icxt) $
do { traceTc "setIC" (ppr (ic_tmp_ids icxt))
; thing_inside }
\end{code}
\begin{code}
#ifdef GHCI
tcRnStmt :: HscEnv
-> InteractiveContext
-> LStmt RdrName
-> IO (Messages, Maybe ([Id], LHsExpr Id))
tcRnStmt hsc_env ictxt rdr_stmt
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env ictxt $ do {
(([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] (return ((), emptyFVs)) ;
traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
failIfErrsM ;
rnDump (ppr rn_stmt) ;
(bound_ids, tc_expr) <- mkPlan rn_stmt ;
zonked_expr <- zonkTopLExpr tc_expr ;
zonked_ids <- zonkTopBndrs bound_ids ;
mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
traceTc "tcs 1" empty ;
let { global_ids = map globaliseAndTidyId zonked_ids } ;
dumpOptTcRn Opt_D_dump_tc
(vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
text "Typechecked expr" <+> ppr zonked_expr]) ;
return (global_ids, zonked_expr)
}
where
bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"),
nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
\end{code}
Note [Interactively-bound Ids in GHCi]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Ids bound by previous Stmts in Template Haskell are currently
a) GlobalIds
b) with an Internal Name (not External)
c) and a tidied type
(a) They must be GlobalIds (not LocalIds) otherwise when we come to
compile an expression using these ids later, the byte code
generator will consider the occurrences to be free rather than
global.
(b) They retain their Internal names becuase we don't have a suitable
Module to name them with. We could revisit this choice.
(c) Their types are tidied. This is important, because :info may ask
to look at them, and :info expects the things it looks up to have
tidy types
--------------------------------------------------------------------------
Typechecking Stmts in GHCi
Here is the grand plan, implemented in tcUserStmt
What you type The IO [HValue] that hscStmt returns
------------- ------------------------------------
let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
bindings: [x,y,...]
pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
bindings: [x,y,...]
expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
[NB: result not printed] bindings: [it]
expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
result showable) bindings: [it]
expr (of non-IO type,
result not showable) ==> error
\begin{code}
type PlanResult = ([Id], LHsExpr Id)
type Plan = TcM PlanResult
runPlans :: [Plan] -> TcM PlanResult
runPlans [] = panic "runPlans"
runPlans [p] = p
runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
mkPlan :: LStmt Name -> TcM PlanResult
mkPlan (L loc (ExprStmt expr _ _))
= do { uniq <- newUnique
; let fresh_it = itName uniq
the_bind = L loc $ mkFunBind (L loc fresh_it) matches
matches = [mkMatch [] expr emptyLocalBinds]
let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
(HsVar bindIOName) noSyntaxExpr
print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
(HsVar thenIOName) placeHolderType
; runPlans [
do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
; it_ty <- zonkTcType (idType it_id)
; when (isUnitTy it_ty) failM
; return stuff },
tcGhciStmts [bind_stmt],
do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
; tcGhciStmts [let_stmt, print_it] }
]}
mkPlan stmt@(L loc (BindStmt {}))
| [v] <- collectLStmtBinders stmt
= do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
(HsVar thenIOName) placeHolderType
; print_bind_result <- doptM Opt_PrintBindResult
; let print_plan = do
{ stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
; v_ty <- zonkTcType (idType v_id)
; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
; return stuff }
; runPlans ((if print_bind_result then [print_plan] else []) ++
[tcGhciStmts [stmt]])
}
mkPlan stmt
= tcGhciStmts [stmt]
tcGhciStmts :: [LStmt Name] -> TcM PlanResult
tcGhciStmts stmts
= do { ioTyCon <- tcLookupTyCon ioTyConName ;
ret_id <- tcLookupId returnIOName ;
let {
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ;
names = collectLStmtsBinders stmts ;
mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty])
(noLoc $ ExplicitList unitTy (map mk_item ids)) ;
mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
(nlHsVar id)
} ;
traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ ->
mapM tcLookupId names ;
traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
const_binds <- checkNoErrs (simplifyInteractive lie) ;
traceTc "TcRnDriver.tcGhciStmts: done" empty ;
return (ids, mkHsDictLet (EvBinds const_binds) $
noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty))
}
\end{code}
tcRnExpr just finds the type of an expression
\begin{code}
tcRnExpr :: HscEnv
-> InteractiveContext
-> LHsExpr RdrName
-> IO (Messages, Maybe Type)
tcRnExpr hsc_env ictxt rdr_expr
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env ictxt $ do {
(rn_expr, _fvs) <- rnLExpr rdr_expr ;
failIfErrsM ;
uniq <- newUnique ;
let { fresh_it = itName uniq } ;
((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ;
((qtvs, dicts, _), lie_top) <- captureConstraints $
simplifyInfer TopLevel
False
[(fresh_it, res_ty)]
lie ;
_ <- simplifyInteractive lie_top ;
let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
zonkTcType all_expr_ty
}
\end{code}
tcRnType just finds the kind of a type
\begin{code}
tcRnType :: HscEnv
-> InteractiveContext
-> LHsType RdrName
-> IO (Messages, Maybe Kind)
tcRnType hsc_env ictxt rdr_type
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env ictxt $ do {
rn_type <- rnLHsType doc rdr_type ;
failIfErrsM ;
(_ty', kind) <- kcLHsType rn_type ;
return kind
}
where
doc = ptext (sLit "In GHCi input")
#endif /* GHCi */
\end{code}
%************************************************************************
%* *
More GHCi stuff, to do with browsing and getting info
%* *
%************************************************************************
\begin{code}
#ifdef GHCI
getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
getModuleExports hsc_env mod
= let
ic = hsc_IC hsc_env
checkMods = ic_toplev_scope ic ++ map fst (ic_exports ic)
in
initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods)
tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo]
tcGetModuleExports mod directlyImpMods
= do { let doc = ptext (sLit "context for compiling statements")
; iface <- initIfaceTcRn $ loadSysInterface doc mod
; loadOrphanModules (dep_orphs (mi_deps iface)) False
; loadOrphanModules (dep_finsts (mi_deps iface)) True
; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods
; ifaceExportNames (mi_exports iface)
}
tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name])
tcRnLookupRdrName hsc_env rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env (hsc_IC hsc_env) $
lookup_rdr_name rdr_name
lookup_rdr_name :: RdrName -> TcM [Name]
lookup_rdr_name rdr_name = do {
let { rdr_names = dataTcOccs rdr_name } ;
results <- mapM (tryTcErrs . lookupOccRn) rdr_names ;
traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
let { (warns_s, good_names) = unzip [ (msgs, name)
| (msgs, Just name) <- results] ;
errs_s = [msgs | (msgs, Nothing) <- results] } ;
if null good_names then
do { addMessages (head errs_s) ; failM }
else
mapM_ addMessages warns_s ;
return good_names
}
#endif
tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
tcRnLookupName hsc_env name
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env (hsc_IC hsc_env) $
tcRnLookupName' name
tcRnLookupName' :: Name -> TcRn TyThing
tcRnLookupName' name = do
tcthing <- tcLookup name
case tcthing of
AGlobal thing -> return thing
ATcId{tct_id=id} -> return (AnId id)
_ -> panic "tcRnLookupName'"
tcRnGetInfo :: HscEnv
-> Name
-> IO (Messages, Maybe (TyThing, Fixity, [Instance]))
tcRnGetInfo hsc_env name
= initTcPrintErrors hsc_env iNTERACTIVE $
tcRnGetInfo' hsc_env name
tcRnGetInfo' :: HscEnv
-> Name
-> TcRn (TyThing, Fixity, [Instance])
tcRnGetInfo' hsc_env name
= let ictxt = hsc_IC hsc_env in
setInteractiveContext hsc_env ictxt $ do
loadUnqualIfaces ictxt
thing <- tcRnLookupName' name
fixity <- lookupFixityRn name
ispecs <- lookupInsts thing
return (thing, fixity, ispecs)
lookupInsts :: TyThing -> TcM [Instance]
lookupInsts (AClass cls)
= do { inst_envs <- tcGetInstEnvs
; return (classInstances inst_envs cls) }
lookupInsts (ATyCon tc)
= do { (pkg_ie, home_ie) <- tcGetInstEnvs
; return [ ispec
| ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
, let dfun = instanceDFunId ispec
, relevant dfun ] }
where
relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df)
tc_name = tyConName tc
lookupInsts _ = return []
loadUnqualIfaces :: InteractiveContext -> TcM ()
loadUnqualIfaces ictxt
= initIfaceTcRn $
mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
where
unqual_mods = [ nameModule name
| gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
let name = gre_name gre,
not (isInternalName name),
isTcOcc (nameOccName name),
unQualOK gre ]
doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
\end{code}
%************************************************************************
%* *
Degugging output
%* *
%************************************************************************
\begin{code}
rnDump :: SDoc -> TcRn ()
rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
tcDump :: TcGblEnv -> TcRn ()
tcDump env
= do { dflags <- getDOpts ;
when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
(dumpTcRn short_dump) ;
dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
}
where
short_dump = pprTcGblEnv env
full_dump = pprLHsBinds (tcg_binds env)
tcCoreDump :: ModGuts -> TcM ()
tcCoreDump mod_guts
= do { dflags <- getDOpts ;
when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
(dumpTcRn (pprModGuts mod_guts)) ;
dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
where
full_dump = pprCoreBindings (mg_binds mod_guts)
pprTcGblEnv :: TcGblEnv -> SDoc
pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
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)
, ppr_gen_tycons (typeEnvTyCons type_env)
, ptext (sLit "Dependent modules:") <+>
ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
, ptext (sLit "Dependent packages:") <+>
ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
where
cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
= (mod_name1 `stableModuleNameCmp` mod_name2)
`thenCmp`
(is_boot1 `compare` is_boot2)
pprModGuts :: ModGuts -> SDoc
pprModGuts (ModGuts { mg_types = type_env,
mg_rules = rules })
= vcat [ ppr_types [] type_env,
ppr_rules rules ]
ppr_types :: [Instance] -> TypeEnv -> SDoc
ppr_types insts type_env
= text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
where
dfun_ids = map instanceDFunId insts
ids = [id | id <- typeEnvIds type_env, want_sig id]
want_sig id | opt_PprStyle_Debug = True
| otherwise = isLocalId id &&
isExternalName (idName id) &&
not (id `elem` dfun_ids)
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)
ppr_fam_insts :: [FamInst] -> SDoc
ppr_fam_insts [] = empty
ppr_fam_insts fam_insts =
text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
ppr_sigs :: [Var] -> SDoc
ppr_sigs ids
= vcat (map ppr_sig (sortLe le_sig ids))
where
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
= vcat (map ppr_tycon (sortLe le_sig tycons))
where
le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
ppr_tycon tycon
| isCoercionTyCon tycon
= sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs
, nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))]
| otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon))
where
tvs = take (tyConArity tycon) alphaTyVars
ppr_rules :: [CoreRule] -> SDoc
ppr_rules [] = empty
ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
nest 2 (pprRules rs),
ptext (sLit "#-}")]
ppr_gen_tycons :: [TyCon] -> SDoc
ppr_gen_tycons [] = empty
ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"),
nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
\end{code}