module TcRnDriver (
#ifdef GHCI
tcRnStmt, tcRnExpr, tcRnType,
tcRnImportDecls,
tcRnLookupRdrName,
getModuleInterface,
tcRnDeclsi,
isGHCiMonad,
runTcInteractive,
#endif
tcRnLookupName,
tcRnGetInfo,
tcRnModule, tcRnModuleTcRnM,
tcTopSrcDecls,
) where
#ifdef GHCI
import TcSplice ( runQuasi, traceSplice, SpliceInfo(..) )
import RnSplice ( rnTopSpliceDecls )
#endif
import DynFlags
import StaticFlags
import HsSyn
import PrelNames
import RdrName
import TcHsSyn
import TcExpr
import TcRnMonad
import TcEvidence
import PprTyThing( pprTyThing )
import Coercion( pprCoAxiom )
import FamInst
import InstEnv
import FamInstEnv
import TcAnnotations
import TcBinds
import HeaderInfo ( mkPrelImports )
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
import TcMType
import MkIface
import TcSimplify
import TcTyClsDecls
import LoadIface
import RnNames
import RnEnv
import RnSource
import ErrUtils
import Id
import IdInfo( IdDetails( VanillaId ) )
import VarEnv
import Module
import UniqFM
import Name
import NameEnv
import NameSet
import Avail
import TyCon
import SrcLoc
import HscTypes
import ListSetOps
import Outputable
import ConLike
import DataCon
import Type
import Class
import CoAxiom
import Annotations
import Data.List ( sortBy )
import Data.Ord
#ifdef GHCI
import BasicTypes hiding( SuccessFlag(..) )
import TcType ( isUnitTy, isTauTy )
import TcHsType
import TcMatches
import RnTypes
import RnExpr
import MkId
import TidyPgm ( globaliseAndTidyId )
import TysWiredIn ( unitTy, mkListTy )
import DynamicLoading ( loadPlugins )
import Plugins ( tcPlugin )
#endif
import TidyPgm ( mkBootModDetailsTc )
import FastString
import Maybes
import Util
import Bag
import Control.Monad
#include "HsVersions.h"
tcRnModule :: HscEnv
-> HscSource
-> Bool
-> HsParsedModule
-> IO (Messages, Maybe TcGblEnv)
tcRnModule hsc_env hsc_src save_rn_syntax
parsedModule@HsParsedModule {hpm_module=L loc this_module}
| RealSrcSpan real_loc <- loc
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
; initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
withTcPlugins hsc_env $
tcRnModuleTcRnM hsc_env hsc_src parsedModule pair }
| otherwise
= return ((emptyBag, unitBag err_msg), Nothing)
where
err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $
text "Module does not have a RealSrcSpan:" <+> ppr this_mod
this_pkg = thisPackage (hsc_dflags hsc_env)
pair :: (Module, SrcSpan)
pair@(this_mod,_)
| Just (L mod_loc mod) <- hsmodName this_module
= (mkModule this_pkg mod, mod_loc)
| otherwise
= (mAIN, srcLocSpan (srcSpanStart loc))
tcRnSignature :: DynFlags -> HscSource -> TcRn TcGblEnv
tcRnSignature dflags hsc_src
= do { tcg_env <- getGblEnv ;
case tcg_sig_of tcg_env of {
Just sof
| hsc_src /= HsigFile -> do
{ addErr (ptext (sLit "Illegal -sig-of specified for non hsig"))
; return tcg_env
}
| otherwise -> do
{ sig_iface <- initIfaceTcRn $ loadSysInterface (text "sig-of") sof
; let { gr = mkGlobalRdrEnv
(gresFromAvails LocalDef (mi_exports sig_iface))
; avails = calculateAvails dflags
sig_iface False False }
; return (tcg_env
{ tcg_impl_rdr_env = Just gr
, tcg_imports = tcg_imports tcg_env `plusImportAvails` avails
})
} ;
Nothing
| HsigFile <- hsc_src
, HscNothing <- hscTarget dflags -> do
{ return tcg_env
}
| HsigFile <- hsc_src -> do
{ addErr (ptext (sLit "Missing -sig-of for hsig"))
; failM }
| otherwise -> return tcg_env
}
}
checkHsigIface :: HscEnv -> TcGblEnv -> TcRn ()
checkHsigIface hsc_env tcg_env
= case tcg_impl_rdr_env tcg_env of
Just gr -> do { sig_details <- liftIO $ mkBootModDetailsTc hsc_env tcg_env
; checkHsigIface' gr sig_details
}
Nothing -> return ()
checkHsigIface' :: GlobalRdrEnv -> ModDetails -> TcRn ()
checkHsigIface' gr
ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
md_types = sig_type_env, md_exports = sig_exports}
= do { traceTc "checkHsigIface" $ vcat
[ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
; mapM_ check_export sig_exports
; unless (null sig_fam_insts) $
panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++
"instances in hsig files yet...")
; mapM_ check_inst sig_insts
; failIfErrsM
}
where
check_export sig_avail
| name `elem` dfun_names = return ()
| otherwise = do
{
env <- getGblEnv
; case lookupNameEnv (tcg_type_env env) name of
Nothing
| [GRE { gre_name = name' }]
<- lookupGlobalRdrEnv gr (nameOccName name)
, name == name' -> return ()
| otherwise -> addErrAt (nameSrcSpan name)
(missingBootThing False name "exported by")
Just sig_thing -> do {
; r <- tcLookupImported_maybe name
; case r of
Failed err -> addErr err
Succeeded real_thing -> checkBootDeclM False sig_thing real_thing
}}
where
name = availName sig_avail
dfun_names = map getName sig_insts
check_inst :: ClsInst -> TcM ()
check_inst sig_inst
= do eps <- getEps
when (not (memberInstEnv (eps_inst_env eps) sig_inst)) $
addErrTc (instMisMatch False sig_inst)
tcRnModuleTcRnM :: HscEnv
-> HscSource
-> HsParsedModule
-> (Module, SrcSpan)
-> TcRn TcGblEnv
tcRnModuleTcRnM hsc_env hsc_src
(HsParsedModule {
hpm_module =
(L loc (HsModule maybe_mod export_ies
import_decls local_decls mod_deprec
maybe_doc_hdr)),
hpm_src_files = src_files
})
(this_mod, prel_imp_loc)
= setSrcSpan loc $
do { let { dflags = hsc_dflags hsc_env } ;
tcg_env <- tcRnSignature dflags hsc_src ;
setGblEnv tcg_env $ do {
implicit_prelude <- xoptM Opt_ImplicitPrelude;
let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
implicit_prelude import_decls } ;
whenWOptM Opt_WarnImplicitPrelude $
when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;
tcg_env <-
tcRnImports hsc_env (prel_imports ++ import_decls) ;
let { tcg_env1 = case mod_deprec of
Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt }
Nothing -> tcg_env
} ;
setGblEnv tcg_env1 $ do {
boot_iface <- tcHiBootIface hsc_src this_mod ;
let { exports_occs =
maybe emptyBag
(listToBag . map (rdrNameOcc . ieName . unLoc) . unLoc)
export_ies
} ;
traceRn (text "rn1a") ;
tcg_env <- if isHsBootOrSig hsc_src then
tcRnHsBootDecls hsc_src local_decls
else
tcRnSrcDecls boot_iface exports_occs local_decls ;
setGblEnv tcg_env $ do {
traceRn (text "rn4a: before exports");
tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
traceRn (text "rn4b: after exports") ;
checkMainExported tcg_env ;
tcg_env <- checkHiBootIface tcg_env boot_iface ;
checkHsigIface hsc_env tcg_env ;
tcg_env <- (case tcg_sig_of tcg_env of
Just _ -> return tcg_env {
tcg_inst_env = emptyInstEnv,
tcg_fam_inst_env = emptyFamInstEnv,
tcg_insts = [],
tcg_fam_insts = []
}
Nothing -> return tcg_env) ;
tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
reportUnusedNames export_ies tcg_env ;
addDependentFiles src_files ;
tcDump tcg_env ;
return tcg_env
}}}}
implicitPreludeWarn :: SDoc
implicitPreludeWarn
= ptext (sLit "Module `Prelude' implicitly imported")
tcRnImports :: HscEnv -> [LImportDecl RdrName] -> TcM TcGblEnv
tcRnImports hsc_env import_decls
= do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
; this_mod <- getModule
; 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 = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
tcg_imports = tcg_imports gbl `plusImportAvails` imports,
tcg_rn_imports = rn_imports,
tcg_visible_orphan_mods = foldl extendModuleSet
(tcg_visible_orphan_mods gbl)
(imp_orphs 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
; loadModuleInterfaces (ptext (sLit "Loading orphan modules"))
(imp_orphs imports)
; traceRn (text "rn1: checking family instance consistency")
; let { dir_imp_mods = moduleEnvKeys
. imp_mods
$ imports }
; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
; getGblEnv } }
tcRnSrcDecls :: ModDetails -> Bag OccName -> [LHsDecl RdrName] -> TcM TcGblEnv
tcRnSrcDecls boot_iface exports decls
= do {
((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
; traceTc "Tc8" empty ;
; setEnvs (tcg_env, tcl_env) $
do {
stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
new_ev_binds <-
simplifyTop (andWC stWC lie) ;
traceTc "Tc9" empty ;
failIfErrsM ;
let { 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_vects = vects,
tcg_fords = fords } = tcg_env
; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
(bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
<-
zonkTopDecls all_ev_binds binds exports sig_ns rules vects
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_vects = vects',
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
; let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) }
; (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group
#ifdef GHCI
; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
; th_ds <- readTcRef th_topdecls_var
; writeTcRef th_topdecls_var []
; (tcg_env, rn_decls) <-
if null th_ds
then return (tcg_env, rn_decls)
else do { (th_group, th_group_tail) <- findSplice th_ds
; case th_group_tail of
{ Nothing -> return () ;
; Just (SpliceDecl (L loc _) _, _)
-> setSrcSpan loc $
addErr (ptext (sLit "Declaration splices are not permitted inside top-level declarations added with addTopDecls"))
} ;
; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $
rnTopSrcDecls extra_deps th_group
; let msg = "top-level declarations added with addTopDecls"
; traceSplice $ SpliceInfo True
msg
Nothing
Nothing
(ppr th_rn_decls)
; return (tcg_env, appendGroups rn_decls th_rn_decls)
}
#endif /* GHCI */
; (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
#ifdef GHCI
; th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
; modfinalizers <- readTcRef th_modfinalizers_var
; writeTcRef th_modfinalizers_var []
; mapM_ runQuasi modfinalizers
#endif /* GHCI */
; return (tcg_env, tcl_env)
}
#ifndef GHCI
; Just (SpliceDecl {}, _) ->
failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
}
#else
; Just (SpliceDecl (L _ splice) _, rest_ds) ->
do {
(spliced_decls, splice_fvs) <- checkNoErrs (rnTopSpliceDecls splice)
; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
}
}
#endif /* GHCI */
}
tcRnHsBootDecls :: HscSource -> [LHsDecl RdrName] -> TcM TcGblEnv
tcRnHsBootDecls hsc_src 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_vects = vect_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 hsc_src "splice" d
Nothing -> return ()
; mapM_ (badBootDecl hsc_src "foreign") for_decls
; mapM_ (badBootDecl hsc_src "default") def_decls
; mapM_ (badBootDecl hsc_src "rule") rule_decls
; mapM_ (badBootDecl hsc_src "vect") vect_decls
; traceTc "Tc2 (boot)" empty
; (tcg_env, inst_infos, _deriv_binds)
<- tcTyClsInstDecls emptyModDetails 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 | HsigFile <- hsc_src = type_env1
| otherwise = extendTypeEnvWithIds type_env1 dfun_ids
; dfun_ids = map iDFunId inst_infos
}
; setGlobalTypeEnv gbl_env type_env2
}}
; traceTc "boot" (ppr lie); return gbl_env }
badBootDecl :: HscSource -> String -> Located decl -> TcM ()
badBootDecl hsc_src what (L loc _)
= addErrAt loc (char 'A' <+> text what
<+> ptext (sLit "declaration is not (currently) allowed in a")
<+> (case hsc_src of
HsBootFile -> ptext (sLit "hs-boot")
HsigFile -> ptext (sLit "hsig")
_ -> panic "badBootDecl: should be an hsig or hs-boot file")
<+> ptext (sLit "file"))
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 })
boot_details
| HsBootFile <- hs_src
= return tcg_env
| otherwise
= do { mb_dfun_prs <- checkHiBootIface' local_insts local_type_env
local_exports boot_details
; 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 }
; setGlobalTypeEnv tcg_env' type_env' }
checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
-> ModDetails -> TcM [Maybe (Id, Id)]
checkHiBootIface'
local_insts local_type_env local_exports
(ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
md_types = boot_type_env, md_exports = boot_exports })
= 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
; failIfErrsM
; return mb_dfun_prs }
where
check_export boot_avail
| name `elem` dfun_names = return ()
| isWiredInName name = return ()
| not (null missing_names)
= addErrAt (nameSrcSpan (head missing_names))
(missingBootThing True (head missing_names) "exported by")
| isNothing mb_boot_thing = return ()
| Just real_thing <- lookupTypeEnv local_type_env name,
Just boot_thing <- mb_boot_thing
= checkBootDeclM True boot_thing real_thing
| otherwise
= addErrTc (missingBootThing True 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 :: ClsInst -> TcM (Maybe (Id, Id))
check_inst boot_inst
= case [dfun | inst <- local_insts,
let dfun = instanceDFunId inst,
idType dfun `eqType` 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 True 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 VanillaId (idName boot_dfun) boot_inst_ty
checkBootDeclM :: Bool
-> TyThing -> TyThing -> TcM ()
checkBootDeclM is_boot boot_thing real_thing
= whenIsJust (checkBootDecl boot_thing real_thing) $ \ err ->
addErrAt (nameSrcSpan (getName boot_thing))
(bootMisMatch is_boot err real_thing boot_thing)
checkBootDecl :: TyThing -> TyThing -> Maybe SDoc
checkBootDecl (AnId id1) (AnId id2)
= ASSERT(id1 == id2)
check (idType id1 `eqType` idType id2)
(text "The two types are different")
checkBootDecl (ATyCon tc1) (ATyCon tc2)
= checkBootTyCon tc1 tc2
checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
= pprPanic "checkBootDecl" (ppr dc1)
checkBootDecl _ _ = Just empty
andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
Nothing `andThenCheck` msg = msg
msg `andThenCheck` Nothing = msg
Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)
infixr 0 `andThenCheck`
checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc
checkUnless True _ = Nothing
checkUnless False k = k
checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
-> Maybe SDoc
checkListBy check_fun as bs whats = go [] as bs
where
herald = text "The" <+> whats <+> text "do not match"
go [] [] [] = Nothing
go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))
go docs (x:xs) (y:ys) = case check_fun x y of
Just doc -> go (doc:docs) xs ys
Nothing -> go docs xs ys
go _ _ _ = Just (hang (herald <> colon)
2 (text "There are different numbers of" <+> whats))
check :: Bool -> SDoc -> Maybe SDoc
check True _ = Nothing
check False doc = Just doc
checkSuccess :: Maybe SDoc
checkSuccess = Nothing
checkBootTyCon :: TyCon -> TyCon -> Maybe SDoc
checkBootTyCon tc1 tc2
| not (eqKind (tyConKind tc1) (tyConKind tc2))
= Just $ text "The types have different kinds"
| Just c1 <- tyConClass_maybe tc1
, Just c2 <- tyConClass_maybe tc2
, let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
= classExtraBigSig c1
(clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
= classExtraBigSig c2
, Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
= let
eqSig (id1, def_meth1) (id2, def_meth2)
= check (name1 == name2)
(text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
text "are different") `andThenCheck`
check (eqTypeX env op_ty1 op_ty2)
(text "The types of" <+> pname1 <+>
text "are different") `andThenCheck`
check (def_meth1 == def_meth2)
(text "The default methods associated with" <+> pname1 <+>
text "are different")
where
name1 = idName id1
name2 = idName id2
pname1 = quotes (ppr name1)
pname2 = quotes (ppr name2)
(_, rho_ty1) = splitForAllTys (idType id1)
op_ty1 = funResultTy rho_ty1
(_, rho_ty2) = splitForAllTys (idType id2)
op_ty2 = funResultTy rho_ty2
eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
= checkBootTyCon tc1 tc2 `andThenCheck`
check (eqATDef def_ats1 def_ats2)
(text "The associated type defaults differ")
eqATDef Nothing Nothing = True
eqATDef (Just ty1) (Just ty2) = eqTypeX env ty1 ty2
eqATDef _ _ = False
eqFD (as1,bs1) (as2,bs2) =
eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
in
check (roles1 == roles2) roles_msg `andThenCheck`
check (eqListBy eqFD clas_fds1 clas_fds2)
(text "The functional dependencies do not match") `andThenCheck`
checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $
check (eqListBy (eqPredX env) sc_theta1 sc_theta2)
(text "The class constraints do not match") `andThenCheck`
checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
checkListBy eqAT ats1 ats2 (text "associated types")
| Just syn_rhs1 <- synTyConRhs_maybe tc1
, Just syn_rhs2 <- synTyConRhs_maybe tc2
, Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
= ASSERT(tc1 == tc2)
check (roles1 == roles2) roles_msg `andThenCheck`
check (eqTypeX env syn_rhs1 syn_rhs2) empty
| Just fam_flav1 <- famTyConFlav_maybe tc1
, Just fam_flav2 <- famTyConFlav_maybe tc2
= ASSERT(tc1 == tc2)
let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True
eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
= eqClosedFamilyAx ax1 ax2
eqFamFlav (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
eqFamFlav _ _ = False
in
check (roles1 == roles2) roles_msg `andThenCheck`
check (eqFamFlav fam_flav1 fam_flav2) empty
| isAlgTyCon tc1 && isAlgTyCon tc2
, Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
= ASSERT(tc1 == tc2)
check (roles1 == roles2) roles_msg `andThenCheck`
check (eqListBy (eqPredX env)
(tyConStupidTheta tc1) (tyConStupidTheta tc2))
(text "The datatype contexts do not match") `andThenCheck`
eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2)
| otherwise = Just empty
where
roles1 = tyConRoles tc1
roles2 = tyConRoles tc2
roles_msg = text "The roles do not match." <+>
(text "Roles default to" <+>
quotes (text "representational") <+> text "in boot files")
eqAlgRhs tc (AbstractTyCon dis1) rhs2
| dis1 = check (isDistinctAlgRhs rhs2)
(text "The natures of the declarations for" <+>
quotes (ppr tc) <+> text "are different")
| otherwise = checkSuccess
eqAlgRhs _ DataFamilyTyCon{} DataFamilyTyCon{} = checkSuccess
eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} =
checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} =
eqCon (data_con tc1) (data_con tc2)
eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+>
text "definition with a" <+> quotes (text "newtype") <+>
text "definition")
eqCon c1 c2
= check (name1 == name2)
(text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
text "differ") `andThenCheck`
check (dataConIsInfix c1 == dataConIsInfix c2)
(text "The fixities of" <+> pname1 <+>
text "differ") `andThenCheck`
check (eqListBy eqHsBang
(dataConSrcBangs c1) (dataConSrcBangs c2))
(text "The strictness annotations for" <+> pname1 <+>
text "differ") `andThenCheck`
check (dataConFieldLabels c1 == dataConFieldLabels c2)
(text "The record label lists for" <+> pname1 <+>
text "differ") `andThenCheck`
check (eqType (dataConUserType c1) (dataConUserType c2))
(text "The types for" <+> pname1 <+> text "differ")
where
name1 = dataConName c1
name2 = dataConName c2
pname1 = quotes (ppr name1)
pname2 = quotes (ppr name2)
eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 })
(CoAxiom { co_ax_branches = branches2 })
= brListLength branches1 == brListLength branches2
&& (and $ brListZipWith eqClosedFamilyBranch branches1 branches2)
eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 })
(CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 })
| Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2
= eqListBy (eqTypeX env) lhs1 lhs2 &&
eqTypeX env rhs1 rhs2
| otherwise = False
emptyRnEnv2 :: RnEnv2
emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
missingBootThing :: Bool -> Name -> String -> SDoc
missingBootThing is_boot name what
= ppr name <+> ptext (sLit "is exported by the") <+>
(if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig"))
<+> ptext (sLit "file, but not")
<+> text what <+> ptext (sLit "the module")
bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc
bootMisMatch is_boot extra_info real_thing boot_thing
= vcat [ppr real_thing <+>
ptext (sLit "has conflicting definitions in the module"),
ptext (sLit "and its") <+>
(if is_boot then ptext (sLit "hs-boot file")
else ptext (sLit "hsig file")),
ptext (sLit "Main module:") <+> PprTyThing.pprTyThing real_thing,
(if is_boot
then ptext (sLit "Boot file: ")
else ptext (sLit "Hsig file: "))
<+> PprTyThing.pprTyThing boot_thing,
extra_info]
instMisMatch :: Bool -> ClsInst -> SDoc
instMisMatch is_boot inst
= hang (ppr inst)
2 (ptext (sLit "is defined in the") <+>
(if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig"))
<+> ptext (sLit "file, but not in the module itself"))
rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
rnTopSrcDecls extra_deps group
= do {
traceTc "rn12" empty ;
(tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps 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_vects = vect_decls,
hs_valds = val_binds })
= do {
traceTc "Tc2 (src)" empty ;
traceTc "Tc3" empty ;
(tcg_env, inst_infos, deriv_binds)
<- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ;
setGblEnv tcg_env $ do {
traceTc "Tc3b" empty ;
traceTc "Tc4" empty ;
(fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
tcExtendGlobalValEnv fi_ids $ do {
traceTc "Tc4a" empty ;
default_tys <- tcDefaults default_decls ;
updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
tc_envs <- discardWarnings (tcTopBinds deriv_binds) ;
setEnvs tc_envs $ do {
traceTc "Tc5" empty ;
tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds;
setEnvs tc_envs $ do {
traceTc "Tc6" empty ;
inst_binds <- tcInstDecls2 (tyClGroupConcat tycl_decls) inst_infos ;
traceTc "Tc7" empty ;
(foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;
annotations <- tcAnnotations annotation_decls ;
rules <- tcRules rule_decls ;
vects <- tcVectDecls vect_decls ;
traceTc "Tc7a" empty ;
let { all_binds = inst_binds `unionBags`
foe_binds
; fo_gres = fi_gres `unionBags` foe_gres
; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre)
emptyFVs fo_gres
; fo_rdr_names :: [RdrName]
; fo_rdr_names = foldrBag gre_to_rdr_name [] fo_gres
; sig_names = mkNameSet (collectHsValBinders val_binds)
`minusNameSet` getTypeSigNames val_binds
; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
, tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names
, tcg_rules = tcg_rules tcg_env
++ flattenRuleDecls rules
, tcg_vects = tcg_vects tcg_env ++ vects
, tcg_anns = tcg_anns tcg_env ++ annotations
, tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
, tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls
, tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
addUsedRdrNames fo_rdr_names ;
return (tcg_env', tcl_env)
}}}}}}
where
gre_to_rdr_name :: GlobalRdrElt -> [RdrName] -> [RdrName]
gre_to_rdr_name gre rdrs
= case gre_prov gre of
LocalDef -> rdrs
Imported [] -> panic "gre_to_rdr_name: Imported []"
Imported (is : _) -> mkRdrQual modName occName : rdrs
where
modName = is_as (is_decl is)
occName = nameOccName (gre_name gre)
tcTyClsInstDecls :: ModDetails
-> [TyClGroup Name]
-> [LInstDecl Name]
-> [LDerivDecl Name]
-> TcM (TcGblEnv,
[InstInfo Name],
HsValBinds Name)
tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls
= tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE)
| lid <- inst_decls, con <- get_cons lid ] $
do { tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
; setGblEnv tcg_env $
tcInstDecls1 (tyClGroupConcat tycl_decls) inst_decls deriv_decls }
where
get_cons :: LInstDecl Name -> [Name]
get_cons (L _ (TyFamInstD {})) = []
get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
= concatMap (get_fi_cons . unLoc) fids
get_fi_cons :: DataFamInstDecl Name -> [Name]
get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
= map unLoc $ concatMap (con_names . unLoc) cons
checkMain :: TcM TcGblEnv
checkMain
= do { tcg_env <- getGblEnv ;
dflags <- getDynFlags ;
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 VanillaId 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
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
= case tcg_main tcg_env of
Nothing -> return ()
Just main_name ->
do { dflags <- getDynFlags
; 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) }
ppMainFn :: RdrName -> SDoc
ppMainFn main_fn
| rdrNameOcc main_fn == mainOcc
= ptext (sLit "IO action") <+> quotes (ppr main_fn)
| otherwise
= ptext (sLit "main IO action") <+> quotes (ppr main_fn)
mainOcc :: OccName
mainOcc = mkVarOccFS (fsLit "main")
runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
runTcInteractive hsc_env thing_inside
= initTcInteractive hsc_env $ withTcPlugins hsc_env $
do { traceTc "setInteractiveContext" $
vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
, text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)
, text "ic_rn_gbl_env (LocalDef)" <+>
vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt)
, let local_gres = filter isLocalGRE gres
, not (null local_gres) ]) ]
; let getOrphans m = fmap (concatMap (\iface -> mi_module iface
: dep_orphs (mi_deps iface)))
(loadSrcInterface (text "runTcInteractive") m
False Nothing)
; ic_visible_mods <- fmap concat . forM (ic_imports icxt) $ \i ->
case i of
IIModule n -> getOrphans n
IIDecl i -> getOrphans (unLoc (ideclName i))
; gbl_env <- getGblEnv
; let gbl_env' = gbl_env {
tcg_rdr_env = ic_rn_gbl_env icxt
, tcg_type_env = type_env
, tcg_inst_env = extendInstEnvList
(extendInstEnvList (tcg_inst_env gbl_env) ic_insts)
home_insts
, tcg_fam_inst_env = extendFamInstEnvList
(extendFamInstEnvList (tcg_fam_inst_env gbl_env)
ic_finsts)
home_fam_insts
, tcg_field_env = RecFields (mkNameEnv con_fields)
(mkNameSet (concatMap snd con_fields))
, tcg_fix_env = ic_fix_env icxt
, tcg_default = ic_default icxt
, tcg_visible_orphan_mods = mkModuleSet ic_visible_mods
}
; setGblEnv gbl_env' $
tcExtendGhciIdEnv ty_things $
thing_inside }
where
(home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)
icxt = hsc_IC hsc_env
(ic_insts, ic_finsts) = ic_instances icxt
ty_things = ic_tythings icxt
type_env1 = mkTypeEnvWithImplicits ty_things
type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)
con_fields = [ (dataConName c, dataConFieldLabels c)
| ATyCon t <- ty_things
, c <- tyConDataCons t ]
#ifdef GHCI
tcRnStmt :: HscEnv -> GhciLStmt RdrName
-> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv))
tcRnStmt hsc_env rdr_stmt
= runTcInteractive hsc_env $ do {
((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_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 } ;
traceOptTcRn Opt_D_dump_tc
(vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
text "Typechecked expr" <+> ppr zonked_expr]) ;
return (global_ids, zonked_expr, fix_env)
}
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))])
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
tcUserStmt :: GhciLStmt RdrName -> TcM (PlanResult, FixityEnv)
tcUserStmt (L loc (BodyStmt expr _ _ _))
= do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
; ghciStep <- getGhciStepIO
; uniq <- newUnique
; interPrintName <- getInteractivePrintName
; let fresh_it = itName uniq loc
matches = [mkMatch [] rn_expr emptyLocalBinds]
the_bind = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs }
let_stmt = L loc $ LetStmt $ HsValBinds $
ValBindsOut [(NonRecursive,unitBag the_bind)] []
bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it))
(nlHsApp ghciStep rn_expr)
(HsVar bindIOName) noSyntaxExpr
print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it))
(HsVar thenIOName) noSyntaxExpr placeHolderType
; plan <- unsetGOptM Opt_DeferTypeErrors $ 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] } ]
; fix_env <- getFixityEnv
; return (plan, fix_env) }
tcUserStmt rdr_stmt@(L loc _)
= do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do
fix_env <- getFixityEnv
return (fix_env, emptyFVs)
; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
; rnDump (ppr rn_stmt) ;
; ghciStep <- getGhciStepIO
; let gi_stmt
| (L loc (BindStmt pat expr op1 op2)) <- rn_stmt
= L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2
| otherwise = rn_stmt
; opt_pr_flag <- goptM Opt_PrintBindResult
; let print_result_plan
| opt_pr_flag
, [v] <- collectLStmtBinders gi_stmt
= [mk_print_result_plan gi_stmt v]
| otherwise = []
; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])
; return (plan, fix_env) }
where
mk_print_result_plan stmt v
= 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 }
where
print_v = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
(HsVar thenIOName) noSyntaxExpr
placeHolderType
tcGhciStmts :: [GhciLStmt 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 = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts io_ret_ty ;
names = collectLStmtsBinders stmts ;
} ;
traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
((tc_stmts, ids), lie) <- captureConstraints $
tc_io_stmts $ \ _ ->
mapM tcLookupId names ;
stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
const_binds <- checkNoErrs (simplifyInteractive (andWC stWC lie)) ;
traceTc "TcRnDriver.tcGhciStmts: done" empty ;
let {
ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
(noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ;
mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
(nlHsVar id) ;
stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
} ;
return (ids, mkHsDictLet (EvBinds const_binds) $
noLoc (HsDo GhciStmtCtxt stmts io_ret_ty))
}
getGhciStepIO :: TcM (LHsExpr Name)
getGhciStepIO = do
ghciTy <- getGHCiMonad
fresh_a <- newUnique
let a_tv = mkTcTyVarName fresh_a (fsLit "a")
ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
stepTy :: LHsType Name
stepTy = noLoc $ HsForAllTy Implicit Nothing
(HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)]
, hsq_kvs = [] })
(noLoc [])
(nlHsFunTy ghciM ioM)
step = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy []
return step
isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
isGHCiMonad hsc_env ty
= runTcInteractive hsc_env $ do
rdrEnv <- getGlobalRdrEnv
let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
case occIO of
Just [n] -> do
let name = gre_name n
ghciClass <- tcLookupClass ghciIoClassName
userTyCon <- tcLookupTyCon name
let userTy = mkTyConApp userTyCon []
_ <- tcLookupInstance ghciClass [userTy]
return name
Just _ -> failWithTc $ text "Ambigous type!"
Nothing -> failWithTc $ text ("Can't find type:" ++ ty)
tcRnExpr :: HscEnv
-> LHsExpr RdrName
-> IO (Messages, Maybe Type)
tcRnExpr hsc_env rdr_expr
= runTcInteractive hsc_env $
do {
(rn_expr, _fvs) <- rnLExpr rdr_expr ;
failIfErrsM ;
uniq <- newUnique ;
let { fresh_it = itName uniq (getLoc rdr_expr) } ;
(((_tc_expr, res_ty), tclvl), lie) <- captureConstraints $
captureTcLevel $
tcInferRho rn_expr ;
((qtvs, dicts, _, _), lie_top) <- captureConstraints $
simplifyInfer tclvl
False
[(fresh_it, res_ty)]
lie ;
stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
_ <- simplifyInteractive (andWC stWC lie_top) ;
let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
ty <- zonkTcType all_expr_ty ;
fam_envs <- tcGetFamInstEnvs ;
return (snd (normaliseType fam_envs Nominal ty))
}
tcRnImportDecls :: HscEnv
-> [LImportDecl RdrName]
-> IO (Messages, Maybe GlobalRdrEnv)
tcRnImportDecls hsc_env import_decls
= runTcInteractive hsc_env $
do { gbl_env <- updGblEnv zap_rdr_env $
tcRnImports hsc_env import_decls
; return (tcg_rdr_env gbl_env) }
where
zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }
tcRnType :: HscEnv
-> Bool
-> LHsType RdrName
-> IO (Messages, Maybe (Type, Kind))
tcRnType hsc_env normalise rdr_type
= runTcInteractive hsc_env $
setXOptM Opt_PolyKinds $
do { (wcs, rdr_type') <- extractWildcards rdr_type
; (rn_type, wcs) <- bindLocatedLocalsRn wcs $ \wcs_new -> do {
; (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type'
; failIfErrsM
; return (rn_type, wcs_new) }
; nwc_tvs <- mapM newWildcardVarMetaKind wcs
; ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType GhciCtxt rn_type
; ty' <- if normalise
then do { fam_envs <- tcGetFamInstEnvs
; return (snd (normaliseType fam_envs Nominal ty)) }
else return ty ;
; return (ty', typeKind ty) }
tcRnDeclsi :: HscEnv
-> [LHsDecl RdrName]
-> IO (Messages, Maybe TcGblEnv)
tcRnDeclsi hsc_env local_decls =
runTcInteractive hsc_env $ do
((tcg_env, tclcl_env), lie) <-
captureConstraints $ tc_rn_src_decls emptyModDetails local_decls
setEnvs (tcg_env, tclcl_env) $ do
stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef
new_ev_binds <- simplifyTop (andWC stWC lie)
failIfErrsM
let 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_vects = vects,
tcg_fords = fords } = tcg_env
all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
(bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
<- zonkTopDecls all_ev_binds binds emptyBag sig_ns rules vects
imp_specs fords
let
final_type_env = extendTypeEnvWithIds type_env bind_ids --global_ids
tcg_env' = tcg_env { tcg_binds = binds',
tcg_ev_binds = ev_binds',
tcg_imp_specs = imp_specs',
tcg_rules = rules',
tcg_vects = vects',
tcg_fords = fords' }
setGlobalTypeEnv tcg_env' final_type_env
#endif /* GHCi */
#ifdef GHCI
getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
getModuleInterface hsc_env mod
= runTcInteractive hsc_env $
loadModuleInterface (ptext (sLit "getModuleInterface")) mod
tcRnLookupRdrName :: HscEnv -> Located RdrName
-> IO (Messages, Maybe [Name])
tcRnLookupRdrName hsc_env (L loc rdr_name)
= runTcInteractive hsc_env $
setSrcSpan loc $
do {
let rdr_names = dataTcOccs rdr_name
; names_s <- mapM lookupInfoOccRn rdr_names
; let names = concat names_s
; when (null names) (addErrTc (ptext (sLit "Not in scope:") <+> quotes (ppr rdr_name)))
; return names }
#endif
tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
tcRnLookupName hsc_env name
= runTcInteractive 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, [ClsInst], [FamInst]))
tcRnGetInfo hsc_env name
= runTcInteractive hsc_env $
do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)
; thing <- tcRnLookupName' name
; fixity <- lookupFixityRn name
; (cls_insts, fam_insts) <- lookupInsts thing
; return (thing, fixity, cls_insts, fam_insts) }
lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])
lookupInsts (ATyCon tc)
= do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs
; (pkg_fie, home_fie) <- tcGetFamInstEnvs
; let cls_insts =
[ ispec
| ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
, instIsVisible vis_mods ispec
, tc_name `elemNameSet` orphNamesOfClsInst ispec ]
; let fam_insts =
[ fispec
| fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
, tc_name `elemNameSet` orphNamesOfFamInst fispec ]
; return (cls_insts, fam_insts) }
where
tc_name = tyConName tc
lookupInsts _ = return ([],[])
loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
loadUnqualIfaces hsc_env ictxt
= initIfaceTcRn $ do
mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
where
this_pkg = thisPackage (hsc_dflags hsc_env)
unqual_mods = [ nameModule name
| gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)
, let name = gre_name gre
, from_external_package name
, isTcOcc (nameOccName name)
, unQualOK gre ]
doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
from_external_package name
| Just mod <- nameModule_maybe name
, modulePackageKey mod /= this_pkg
, not (isInteractiveModule mod)
= True
| otherwise
= False
rnDump :: SDoc -> TcRn ()
rnDump doc = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
tcDump :: TcGblEnv -> TcRn ()
tcDump env
= do { dflags <- getDynFlags ;
when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
(printForUserTcRn short_dump) ;
traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
}
where
short_dump = pprTcGblEnv env
full_dump = pprLHsBinds (tcg_binds env)
pprTcGblEnv :: TcGblEnv -> SDoc
pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
tcg_rules = rules,
tcg_vects = vects,
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)
, vcat (map ppr vects)
, ptext (sLit "Dependent modules:") <+>
ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
, ptext (sLit "Dependent packages:") <+>
ppr (sortBy stablePackageKeyCmp $ 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)
ppr_types :: [ClsInst] -> TypeEnv -> SDoc
ppr_types insts type_env
= text "TYPE SIGNATURES" $$ nest 2 (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
= vcat [ text "TYPE CONSTRUCTORS"
, nest 2 (ppr_tydecls tycons)
, text "COERCION AXIOMS"
, nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
where
fi_tycons = famInstsRepTyCons 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 :: [ClsInst] -> 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 (sortBy (comparing getOccName) ids))
where
ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
ppr_tydecls :: [TyCon] -> SDoc
ppr_tydecls tycons
= vcat (map ppr_tycon (sortBy (comparing getOccName) tycons))
where
ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ]
withTcPlugins :: HscEnv -> TcM a -> TcM a
withTcPlugins hsc_env m =
do plugins <- liftIO (loadTcPlugins hsc_env)
case plugins of
[] -> m
_ -> do (solvers,stops) <- unzip `fmap` mapM startPlugin plugins
eitherRes <- tryM $ do
updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m
mapM_ runTcPluginM stops
case eitherRes of
Left _ -> failM
Right res -> return res
where
startPlugin (TcPlugin start solve stop) =
do s <- runTcPluginM start
return (solve s, stop s)
loadTcPlugins :: HscEnv -> IO [TcPlugin]
#ifndef GHCI
loadTcPlugins _ = return []
#else
loadTcPlugins hsc_env =
do named_plugins <- loadPlugins hsc_env
return $ catMaybes $ map load_plugin named_plugins
where
load_plugin (_, plug, opts) = tcPlugin plug opts
#endif