module TcRnDriver (
tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
tcRnImportDecls,
tcRnLookupRdrName,
getModuleInterface,
tcRnDeclsi,
isGHCiMonad,
runTcInteractive,
tcRnLookupName,
tcRnGetInfo,
tcRnModule, tcRnModuleTcRnM,
tcTopSrcDecls,
rnTopSrcDecls,
checkBootDecl, checkHiBootIface',
findExtraSigImports,
implicitRequirements,
checkUnitId,
mergeSignatures,
tcRnMergeSignatures,
instantiateSignature,
tcRnInstantiateSignature,
loadUnqualIfaces,
badReexportedBootThing,
checkBootDeclM,
missingBootThing,
getRenamedStuff, RenamedStuff
) where
import GhcPrelude
import TcSplice ( finishTH, runRemoteModFinalizers )
import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
import IfaceEnv( externaliseName )
import TcHsType
import TcValidity( checkValidType )
import TcMatches
import Inst( deeplyInstantiate )
import TcUnify( checkConstraints )
import RnTypes
import RnExpr
import RnUtils ( HsDocContext(..) )
import RnFixity ( lookupFixityRn )
import MkId
import TysWiredIn ( unitTy, mkListTy )
import Plugins
import DynFlags
import GHC.Hs
import IfaceSyn ( ShowSub(..), showToHeader )
import IfaceType( ShowForAllFlag(..) )
import PatSyn( pprPatSynType )
import PrelNames
import PrelInfo
import RdrName
import TcHsSyn
import TcExpr
import TcRnMonad
import TcRnExports
import TcEvidence
import Constraint
import TcOrigin
import qualified BooleanFormula as BF
import PprTyThing( pprTyThingInContext )
import CoreFVs( orphNamesOfFamInst )
import FamInst
import InstEnv
import FamInstEnv( FamInst, pprFamInst, famInstsRepTyCons
, famInstEnvElts, extendFamInstEnvList, normaliseType )
import TcAnnotations
import TcBinds
import MkIface ( coAxiomToIfaceDecl )
import HeaderInfo ( mkPrelImports )
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
import TcMType
import TcType
import TcSimplify
import TcTyClsDecls
import TcTypeable ( mkTypeableBinds )
import TcBackpack
import LoadIface
import RnNames
import RnEnv
import RnSource
import ErrUtils
import Id
import IdInfo( IdDetails(..) )
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 BasicTypes hiding( SuccessFlag(..) )
import CoAxiom
import Annotations
import Data.List ( sortBy, sort )
import Data.Ord
import FastString
import Maybes
import Util
import Bag
import Inst (tcGetInsts)
import qualified GHC.LanguageExtensions as LangExt
import Data.Data ( Data )
import GHC.Hs.Dump
import qualified Data.Set as S
import Control.DeepSeq
import Control.Monad
import TcHoleFitTypes ( HoleFitPluginR (..) )
#include "HsVersions.h"
tcRnModule :: HscEnv
-> ModSummary
-> Bool
-> HsParsedModule
-> IO (Messages, Maybe TcGblEnv)
tcRnModule hsc_env mod_sum save_rn_syntax
parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)}
| RealSrcSpan real_loc <- loc
= withTiming dflags
(text "Renamer/typechecker"<+>brackets (ppr this_mod))
(const ()) $
initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $
tcRnModuleTcRnM hsc_env mod_sum parsedModule pair
| otherwise
= return ((emptyBag, unitBag err_msg), Nothing)
where
hsc_src = ms_hsc_src mod_sum
dflags = hsc_dflags hsc_env
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 (dL->L mod_loc mod) <- hsmodName this_module
= (mkModule this_pkg mod, mod_loc)
| otherwise
= (mAIN, srcLocSpan (srcSpanStart loc))
tcRnModuleTcRnM :: HscEnv
-> ModSummary
-> HsParsedModule
-> (Module, SrcSpan)
-> TcRn TcGblEnv
tcRnModuleTcRnM hsc_env mod_sum
(HsParsedModule {
hpm_module =
(dL->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 { explicit_mod_hdr = isJust maybe_mod
; hsc_src = ms_hsc_src mod_sum }
;
tcg_env <- getGblEnv
; boot_info <- tcHiBootIface hsc_src this_mod
; setGblEnv (tcg_env { tcg_self_boot = boot_info })
$ do
{
implicit_prelude <- xoptM LangExt.ImplicitPrelude
; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
implicit_prelude import_decls }
; whenWOptM Opt_WarnImplicitPrelude $
when (notNull prel_imports) $
addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn)
;
let { simplifyImport (dL->L _ idecl) =
( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl)
}
; raw_sig_imports <- liftIO
$ findExtraSigImports hsc_env hsc_src
(moduleName this_mod)
; raw_req_imports <- liftIO
$ implicitRequirements hsc_env
(map simplifyImport (prel_imports
++ import_decls))
; let { mkImport (Nothing, dL->L _ mod_name) = noLoc
$ (simpleImportDecl mod_name)
{ ideclHiding = Just (False, noLoc [])}
; mkImport _ = panic "mkImport" }
; let { all_imports = prel_imports ++ import_decls
++ map mkImport (raw_sig_imports ++ raw_req_imports) }
;
tcg_env <-
tcRnImports hsc_env all_imports
;
let { tcg_env1 = case mod_deprec of
Just (dL->L _ txt) ->
tcg_env {tcg_warns = WarnAll txt}
Nothing -> tcg_env
}
; setGblEnv tcg_env1
$ do {
traceRn "rn1a" empty
; tcg_env <- if isHsBootOrSig hsc_src
then tcRnHsBootDecls hsc_src local_decls
else
tcRnSrcDecls explicit_mod_hdr local_decls
; setGblEnv tcg_env
$ do {
traceRn "rn4a: before exports" empty
; tcg_env <- tcRnExports explicit_mod_hdr export_ies
tcg_env
; traceRn "rn4b: after exports" empty
;
when explicit_mod_hdr $ checkMainExported tcg_env
;
tcg_env <- checkHiBootIface tcg_env boot_info
;
tcg_env <- return (tcg_env
{ tcg_doc_hdr = maybe_doc_hdr })
;
reportUnusedNames tcg_env
;
addDependentFiles src_files
; tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env
;
tcDump tcg_env
; return tcg_env }
}
}
}
implicitPreludeWarn :: SDoc
implicitPreludeWarn
= text "Module `Prelude' implicitly imported"
tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> 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_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 "rn1" (ppr (imp_dep_mods imports))
; failIfErrsM
; loadModuleInterfaces (text "Loading orphan modules")
(filter (/= this_mod) (imp_orphs imports))
; traceRn "rn1: checking family instance consistency {" empty
; let { dir_imp_mods = moduleEnvKeys
. imp_mods
$ imports }
; checkFamInstConsistency dir_imp_mods
; traceRn "rn1: } checking family instance consistency" empty
; getGblEnv } }
tcRnSrcDecls :: Bool
-> [LHsDecl GhcPs]
-> TcM TcGblEnv
tcRnSrcDecls explicit_mod_hdr decls
= do {
; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls
; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $
captureTopConstraints $
checkMain explicit_mod_hdr
; setEnvs (tcg_env, tcl_env) $ do {
; new_ev_binds <-
simplifyTop (lie `andWC` lie_main)
; tcg_env <- mkTypeableBinds
; traceTc "Tc9" empty
; failIfErrsM
; traceTc "Tc10" empty
; (bind_env, ev_binds', binds', fords', imp_specs', rules')
<- zonkTcGblEnv new_ev_binds tcg_env
; (tcg_env_mf, _) <- setGblEnv (clearTcGblEnv tcg_env)
run_th_modfinalizers
; finishTH
; traceTc "Tc11" empty
;
; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)
<- zonkTcGblEnv emptyBag tcg_env_mf
; let { final_type_env = plusTypeEnv (tcg_type_env tcg_env)
(plusTypeEnv bind_env_mf bind_env)
; tcg_env' = tcg_env_mf
{ tcg_binds = binds' `unionBags` binds_mf,
tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf ,
tcg_imp_specs = imp_specs' ++ imp_specs_mf ,
tcg_rules = rules' ++ rules_mf ,
tcg_fords = fords' ++ fords_mf } } ;
; setGlobalTypeEnv tcg_env' final_type_env
} }
zonkTcGblEnv :: Bag EvBind -> TcGblEnv
-> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,
[LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv new_ev_binds tcg_env =
let TcGblEnv { tcg_binds = binds,
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
in
zonkTopDecls all_ev_binds binds rules imp_specs fords
clearTcGblEnv :: TcGblEnv -> TcGblEnv
clearTcGblEnv tcg_env
= tcg_env { tcg_binds = emptyBag,
tcg_ev_binds = emptyBag ,
tcg_imp_specs = [],
tcg_rules = [],
tcg_fords = [] }
run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
run_th_modfinalizers = do
th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
th_modfinalizers <- readTcRef th_modfinalizers_var
if null th_modfinalizers
then getEnvs
else do
writeTcRef th_modfinalizers_var []
let run_finalizer (lcl_env, f) =
setLclEnv lcl_env (runRemoteModFinalizers f)
(_, lie_th) <- captureTopConstraints $
mapM_ run_finalizer th_modfinalizers
(tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls []
setEnvs (tcg_env, tcl_env) $ do
new_ev_binds <-
simplifyTop (lie_th `andWC` lie_top_decls)
addTopEvBinds new_ev_binds run_th_modfinalizers
tc_rn_src_decls :: [LHsDecl GhcPs]
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls ds
=
do { (first_group, group_tail) <- findSplice ds
; (tcg_env, rn_decls) <- rnTopSrcDecls first_group
; 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 _ (dL->L loc _) _, _) ->
setSrcSpan loc
$ addErr (text
("Declaration splices are not "
++ "permitted inside top-level "
++ "declarations added with addTopDecls"))
; Just (XSpliceDecl nec, _) -> noExtCon nec
}
; (tcg_env, th_rn_decls) <- setGblEnv tcg_env
$ rnTopSrcDecls th_group
; let msg = "top-level declarations added with addTopDecls"
; traceSplice
$ SpliceInfo { spliceDescription = msg
, spliceIsDecl = True
, spliceSource = Nothing
, spliceGenerated = ppr th_rn_decls }
; return (tcg_env, appendGroups rn_decls th_rn_decls)
}
; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $
captureTopConstraints $
tcTopSrcDecls rn_decls
; setEnvs (tcg_env, tcl_env) $
case group_tail of
{ Nothing -> return (tcg_env, tcl_env, lie1)
; Just (SpliceDecl _ (dL->L _ splice) _, rest_ds) ->
do {
; ev_binds1 <- simplifyTop lie1
; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice
; (tcg_env, tcl_env, lie2) <-
setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
addTopEvBinds ev_binds1 $
tc_rn_src_decls (spliced_decls ++ rest_ds)
; return (tcg_env, tcl_env, lie2)
}
; Just (XSpliceDecl nec, _) -> noExtCon nec
}
}
tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnHsBootDecls hsc_src decls
= do { (first_group, group_tail) <- findSplice decls
; (tcg_env, HsGroup { hs_tyclds = tycl_decls
, hs_derivds = deriv_decls
, hs_fords = for_decls
, hs_defds = def_decls
, hs_ruleds = rule_decls
, hs_annds = _
, hs_valds = XValBindsLR (NValBinds val_binds val_sigs) })
<- rnTopSrcDecls first_group
; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {
; case group_tail of
Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d
Just (XSpliceDecl nec, _) -> noExtCon nec
Nothing -> return ()
; mapM_ (badBootDecl hsc_src "foreign") for_decls
; mapM_ (badBootDecl hsc_src "default") def_decls
; mapM_ (badBootDecl hsc_src "rule") rule_decls
; traceTc "Tc2 (boot)" empty
; (tcg_env, inst_infos, _deriv_binds)
<- tcTyClsInstDecls tycl_decls deriv_decls val_binds
; setGblEnv tcg_env $ do {
; tcg_env <- mkTypeableBinds
; setGblEnv tcg_env $ do {
; traceTc "Tc5" empty
; val_ids <- tcHsBootSigs val_binds val_sigs
; 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
; 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 (dL->L loc _)
= addErrAt loc (char 'A' <+> text what
<+> text "declaration is not (currently) allowed in a"
<+> (case hsc_src of
HsBootFile -> text "hs-boot"
HsigFile -> text "hsig"
_ -> panic "badBootDecl: should be an hsig or hs-boot file")
<+> text "file")
checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
checkHiBootIface tcg_env boot_info
| NoSelfBoot <- boot_info
= return tcg_env
| HsBootFile <- tcg_src tcg_env
= return tcg_env
| SelfBoot { sb_mds = boot_details } <- boot_info
, TcGblEnv { tcg_binds = binds
, tcg_insts = local_insts
, tcg_type_env = local_type_env
, tcg_exports = local_exports } <- tcg_env
= do {
; dfun_prs <- checkHiBootIface' local_insts local_type_env
local_exports boot_details
; let boot_dfuns = map fst dfun_prs
type_env' = extendTypeEnvWithIds local_type_env boot_dfuns
dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
| (boot_dfun, dfun) <- dfun_prs ]
tcg_env_w_binds
= tcg_env { tcg_binds = binds `unionBags` dfun_binds }
; type_env' `seq`
setGlobalTypeEnv tcg_env_w_binds type_env' }
| otherwise = panic "checkHiBootIface: unreachable code"
checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
-> ModDetails -> TcM [(Id, Id)]
checkHiBootIface'
local_insts local_type_env local_exports
(ModDetails { md_types = boot_type_env
, md_fam_insts = boot_fam_insts
, md_exports = boot_exports })
= do { traceTc "checkHiBootIface" $ vcat
[ ppr boot_type_env, 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_cls_inst boot_dfuns
; failIfErrsM
; return (catMaybes mb_dfun_prs) }
where
boot_dfun_names = map idName boot_dfuns
boot_dfuns = filter isDFunId $ typeEnvIds boot_type_env
check_export boot_avail
| name `elem` boot_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
local_export_env :: NameEnv AvailInfo
local_export_env = availsToNameEnv local_exports
check_cls_inst :: DFunId -> TcM (Maybe (Id, Id))
check_cls_inst boot_dfun
| (real_dfun : _) <- find_real_dfun boot_dfun
, let local_boot_dfun = Id.mkExportedVanillaId
(idName boot_dfun) (idType real_dfun)
= return (Just (local_boot_dfun, real_dfun))
| otherwise
= setSrcSpan (getLoc (getName boot_dfun)) $
do { traceTc "check_cls_inst" $ vcat
[ text "local_insts" <+>
vcat (map (ppr . idType . instanceDFunId) local_insts)
, text "boot_dfun_ty" <+> ppr (idType boot_dfun) ]
; addErrTc (instMisMatch boot_dfun)
; return Nothing }
find_real_dfun :: DFunId -> [DFunId]
find_real_dfun boot_dfun
= [dfun | inst <- local_insts
, let dfun = instanceDFunId inst
, idType dfun `eqType` boot_dfun_ty ]
where
boot_dfun_ty = idType boot_dfun
checkBootDeclM :: Bool
-> TyThing -> TyThing -> TcM ()
checkBootDeclM is_boot boot_thing real_thing
= whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err ->
addErrAt span
(bootMisMatch is_boot err real_thing boot_thing)
where
span
| let span = nameSrcSpan (getName boot_thing)
, isGoodSrcSpan span
= span
| otherwise
= nameSrcSpan (getName real_thing)
checkBootDecl :: Bool -> 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 is_boot (ATyCon tc1) (ATyCon tc2)
= checkBootTyCon is_boot 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 :: Bool -> TyCon -> TyCon -> Maybe SDoc
checkBootTyCon is_boot tc1 tc2
| not (eqType (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 <- eqVarBndrs 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`
if is_boot
then check (eqMaybeBy eqDM def_meth1 def_meth2)
(text "The default methods associated with" <+> pname1 <+>
text "are different")
else check (subDM op_ty1 def_meth1 def_meth2)
(text "The default methods associated with" <+> pname1 <+>
text "are not compatible")
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 is_boot tc1 tc2 `andThenCheck`
check (eqATDef def_ats1 def_ats2)
(text "The associated type defaults differ")
eqDM (_, VanillaDM) (_, VanillaDM) = True
eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2
eqDM _ _ = False
subDM _ Nothing _ = True
subDM _ _ Nothing = False
subDM t1 (Just (_, GenericDM t2)) (Just (_, VanillaDM))
= eqTypeX env t1 t2
subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2))
= eqTypeX env t1 t2
subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True
subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2))
= eqTypeX env t1 t2
eqATDef Nothing Nothing = True
eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = 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
checkRoles roles1 roles2 `andThenCheck`
check (eqListBy eqFD clas_fds1 clas_fds2)
(text "The functional dependencies do not match") `andThenCheck`
checkUnless (isAbstractTyCon tc1) $
check (eqListBy (eqTypeX 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") `andThenCheck`
check (classMinimalDef c1 `BF.implies` classMinimalDef c2)
(text "The MINIMAL pragmas are not compatible")
| Just syn_rhs1 <- synTyConRhs_maybe tc1
, Just syn_rhs2 <- synTyConRhs_maybe tc2
, Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
= ASSERT(tc1 == tc2)
checkRoles roles1 roles2 `andThenCheck`
check (eqTypeX env syn_rhs1 syn_rhs2) empty
| not is_boot
, isAbstractTyCon tc1
, Just (tvs, ty) <- synTyConDefn_maybe tc2
, Just (tc2', args) <- tcSplitTyConApp_maybe ty
= checkSynAbsData tvs ty tc2' args
| not is_boot
, isAbstractTyCon tc1
, Just (_,ty2) <- synTyConDefn_maybe tc2
, isJust (isLitTy ty2)
= Nothing
| Just fam_flav1 <- famTyConFlav_maybe tc1
, Just fam_flav2 <- famTyConFlav_maybe tc2
= ASSERT(tc1 == tc2)
let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True
eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True
eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True
eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
= eqClosedFamilyAx ax1 ax2
eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2
eqFamFlav _ _ = False
injInfo1 = tyConInjectivityInfo tc1
injInfo2 = tyConInjectivityInfo tc2
in
checkRoles roles1 roles2 `andThenCheck`
check (eqFamFlav fam_flav1 fam_flav2)
(whenPprDebug $
text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+>
text "do not match") `andThenCheck`
check (injInfo1 == injInfo2) (text "Injectivities do not match")
| isAlgTyCon tc1 && isAlgTyCon tc2
, Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
= ASSERT(tc1 == tc2)
checkRoles roles1 roles2 `andThenCheck`
check (eqListBy (eqTypeX 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 on abstract types default to" <+>
quotes (text "representational") <+> text "in boot files.")
roles_subtype_msg = text "The roles are not compatible:" $$
text "Main module:" <+> ppr roles2 $$
text "Hsig file:" <+> ppr roles1
checkRoles r1 r2
| is_boot || isInjectiveTyCon tc1 Representational
= check (r1 == r2) roles_msg
| otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg
rolesSubtypeOf [] [] = True
rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys
rolesSubtypeOf _ _ = False
checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc
checkSynAbsData tvs ty tc2' args =
check (null (tcTyFamInsts ty))
(text "Illegal type family application in implementation of abstract data.")
`andThenCheck`
check (null tvs)
(text "Illegal parameterized type synonym in implementation of abstract data." $$
text "(Try eta reducing your type synonym so that it is nullary.)")
`andThenCheck`
checkUnless (not (null tvs)) $
ASSERT( null roles2 )
checkRoles roles1 (drop (length args) (tyConRoles tc2'))
eqAlgRhs _ AbstractTyCon _rhs2
= 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 (dataConImplBangs c1) (dataConImplBangs c2))
(text "The strictness annotations for" <+> pname1 <+>
text "differ") `andThenCheck`
check (map flSelector (dataConFieldLabels c1) == map flSelector (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 Nothing Nothing = True
eqClosedFamilyAx Nothing (Just _) = False
eqClosedFamilyAx (Just _) Nothing = False
eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 }))
(Just (CoAxiom { co_ax_branches = branches2 }))
= numBranches branches1 == numBranches branches2
&& (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2)
where
branch_list1 = fromBranches branches1
branch_list2 = fromBranches branches2
eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1
, cab_lhs = lhs1, cab_rhs = rhs1 })
(CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2
, cab_lhs = lhs2, cab_rhs = rhs2 })
| Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2
, Just env <- eqVarBndrs env1 cvs1 cvs2
= 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
= quotes (ppr name) <+> text "is exported by the"
<+> (if is_boot then text "hs-boot" else text "hsig")
<+> text "file, but not"
<+> text what <+> text "the module"
badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc
badReexportedBootThing dflags is_boot name name'
= withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ vcat
[ text "The" <+> (if is_boot then text "hs-boot" else text "hsig")
<+> text "file (re)exports" <+> quotes (ppr name)
, text "but the implementing module exports a different identifier" <+> quotes (ppr name')
]
bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc
bootMisMatch is_boot extra_info real_thing boot_thing
= pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc
where
to_doc
= pprTyThingInContext $ showToHeader { ss_forall =
if is_boot
then ShowForAllMust
else ShowForAllWhen }
real_doc = to_doc real_thing
boot_doc = to_doc boot_thing
pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc
= vcat
[ ppr real_thing <+>
text "has conflicting definitions in the module",
text "and its" <+>
(if is_boot
then text "hs-boot file"
else text "hsig file"),
text "Main module:" <+> real_doc,
(if is_boot
then text "Boot file: "
else text "Hsig file: ")
<+> boot_doc,
extra_info
]
instMisMatch :: DFunId -> SDoc
instMisMatch dfun
= hang (text "instance" <+> ppr (idType dfun))
2 (text "is defined in the hs-boot file, but not in the module itself")
rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
rnTopSrcDecls group
= do {
traceRn "rn12" empty ;
(tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
traceRn "rn13" empty ;
(tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ;
traceRn "rn13-plugin" 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 rn_decls ;
return (tcg_env', rn_decls)
}
tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_annds = annotation_decls,
hs_ruleds = rule_decls,
hs_valds = hs_val_binds@(XValBindsLR
(NValBinds val_binds val_sigs)) })
= do {
traceTc "Tc2 (src)" empty ;
traceTc "Tc3" empty ;
(tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))
<- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
setGblEnv tcg_env $ do {
traceTc "Tc3b" empty ;
traceTc "Tc3c" empty ;
tcSemigroupWarnings ;
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 {
traceTc "Tc5" empty ;
tc_envs <- tcTopBinds val_binds val_sigs;
setEnvs tc_envs $ do {
tc_envs@(tcg_env, tcl_env)
<- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;
setEnvs tc_envs $ do {
traceTc "Tc6" empty ;
inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ;
traceTc "Tc7" empty ;
(foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;
annotations <- tcAnnotations annotation_decls ;
rules <- tcRules rule_decls ;
traceTc "Tc7a" empty ;
let { all_binds = inst_binds `unionBags`
foe_binds
; fo_gres = fi_gres `unionBags` foe_gres
; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` gre_name gre)
emptyFVs fo_gres
; sig_names = mkNameSet (collectHsValBinders hs_val_binds)
`minusNameSet` getTypeSigNames val_sigs
; 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_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 } } ;
addUsedGREs (bagToList fo_gres) ;
return (tcg_env', tcl_env)
}}}}}}
tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
tcSemigroupWarnings :: TcM ()
tcSemigroupWarnings = do
traceTc "tcSemigroupWarnings" empty
let warnFlag = Opt_WarnSemigroup
tcPreludeClashWarn warnFlag sappendName
tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName
tcPreludeClashWarn :: WarningFlag
-> Name
-> TcM ()
tcPreludeClashWarn warnFlag name = do
{ warn <- woptM warnFlag
; when warn $ do
{ traceTc "tcPreludeClashWarn/wouldBeImported" empty
; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv
; when (importedViaPrelude name rnImports) $ do
{ rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv
; let clashes :: GlobalRdrElt -> Bool
clashes x = isLocalDef && nameClashes && isNotInProperModule
where
isLocalDef = gre_lcl x == True
nameClashes = nameOccName (gre_name x) == nameOccName name
isNotInProperModule = gre_name x /= name
clashingElts :: [GlobalRdrElt]
clashingElts = filter clashes rdrElts
; traceTc "tcPreludeClashWarn/prelude_functions"
(hang (ppr name) 4 (sep [ppr clashingElts]))
; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep
[ text "Local definition of"
, (quotes . ppr . nameOccName . gre_name) x
, text "clashes with a future Prelude name." ]
$$
text "This will become an error in a future release." )
; mapM_ warn_msg clashingElts
}}}
where
importedViaPrelude :: Name
-> [ImportDecl GhcRn]
-> Bool
importedViaPrelude name = any importViaPrelude
where
isPrelude :: ImportDecl GhcRn -> Bool
isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME
isImplicit :: ImportDecl GhcRn -> Bool
isImplicit = ideclImplicit
isUnqualified :: ImportDecl GhcRn -> Bool
isUnqualified = not . isImportDeclQualified . ideclQualified
importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name])
importListOf = fmap toImportList . ideclHiding
where
toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc))
isExplicit :: ImportDecl GhcRn -> Bool
isExplicit x = case importListOf x of
Nothing -> False
Just (False, explicit)
-> nameOccName name `elem` map nameOccName explicit
Just (True, hidden)
-> nameOccName name `notElem` map nameOccName hidden
importViaPrelude :: ImportDecl GhcRn -> Bool
importViaPrelude x = isPrelude x
&& isUnqualified x
&& (isImplicit x || isExplicit x)
tcMissingParentClassWarn :: WarningFlag
-> Name
-> Name
-> TcM ()
tcMissingParentClassWarn warnFlag isName shouldName
= do { warn <- woptM warnFlag
; when warn $ do
{ traceTc "tcMissingParentClassWarn" empty
; isClass' <- tcLookupClass_maybe isName
; shouldClass' <- tcLookupClass_maybe shouldName
; case (isClass', shouldClass') of
(Just isClass, Just shouldClass) -> do
{ localInstances <- tcGetInsts
; let isInstance m = is_cls m == isClass
isInsts = filter isInstance localInstances
; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts)
; forM_ isInsts (checkShouldInst isClass shouldClass)
}
(is',should') ->
traceTc "tcMissingParentClassWarn/notIsShould"
(hang (ppr isName <> text "/" <> ppr shouldName) 2 (
(hsep [ quotes (text "Is"), text "lookup for"
, ppr isName
, text "resulted in", ppr is' ])
$$
(hsep [ quotes (text "Should"), text "lookup for"
, ppr shouldName
, text "resulted in", ppr should' ])))
}}
where
checkShouldInst :: Class
-> Class
-> ClsInst
-> TcM ()
checkShouldInst isClass shouldClass isInst
= do { instEnv <- tcGetInstEnvs
; let (instanceMatches, shouldInsts, _)
= lookupInstEnv False instEnv shouldClass (is_tys isInst)
; traceTc "tcMissingParentClassWarn/checkShouldInst"
(hang (ppr isInst) 4
(sep [ppr instanceMatches, ppr shouldInsts]))
; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst
warnMsg (Just name:_) =
addWarnAt (Reason warnFlag) instLoc $
hsep [ (quotes . ppr . nameOccName) name
, text "is an instance of"
, (ppr . nameOccName . className) isClass
, text "but not"
, (ppr . nameOccName . className) shouldClass ]
<> text "."
$$
hsep [ text "This will become an error in"
, text "a future release." ]
warnMsg _ = pure ()
; when (null shouldInsts && null instanceMatches) $
warnMsg (is_tcs isInst)
}
tcLookupClass_maybe :: Name -> TcM (Maybe Class)
tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case
Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls
_else -> pure Nothing
tcTyClsInstDecls :: [TyClGroup GhcRn]
-> [LDerivDecl GhcRn]
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM (TcGblEnv,
[InstInfo GhcRn],
HsValBinds GhcRn)
tcTyClsInstDecls tycl_decls deriv_decls binds
= tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $
tcAddPatSynPlaceholders (getPatSynBinds binds) $
do { (tcg_env, inst_info, deriv_info)
<- tcTyAndClassDecls tycl_decls ;
; setGblEnv tcg_env $ do {
; failIfErrsM
; (tcg_env', inst_info', val_binds)
<- tcInstDeclsDeriv deriv_info deriv_decls
; setGblEnv tcg_env' $ do {
failIfErrsM
; pure (tcg_env', inst_info' ++ inst_info, val_binds)
}}}
checkMain :: Bool
-> TcM TcGblEnv
checkMain explicit_mod_hdr
= do { dflags <- getDynFlags
; tcg_env <- getGblEnv
; check_main dflags tcg_env explicit_mod_hdr }
check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv
check_main dflags tcg_env explicit_mod_hdr
| 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
; let io_ty = mkTyConApp ioTyCon [res_ty]
skol_info = SigSkol (FunSigCtxt main_name False) io_ty []
; (ev_binds, main_expr)
<- checkConstraints skol_info [] [] $
addErrCtxt mainCtxt $
tcMonoExpr (cL loc (HsVar noExtField (cL loc main_name)))
(mkCheckExpType io_ty)
; run_main_id <- tcLookupId runMainIOName
; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
(mkVarOccFS (fsLit "main"))
(getSrcSpan main_name)
; root_main_id = Id.mkExportedVanillaId root_main_name
(mkTyConApp ioTyCon [res_ty])
; co = mkWpTyApps [res_ty]
; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $
mkHsDictLet ev_binds 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
interactive = ghcLink dflags == LinkInMemory
complain_no_main = unless (interactive && not explicit_mod_hdr)
(addErrTc noMainMsg)
mainCtxt = text "When checking the type of the" <+> pp_main_fn
noMainMsg = text "The" <+> pp_main_fn
<+> text "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)) $
text "The" <+> ppMainFn (nameRdrName main_name) <+>
text "is not exported by module" <+> quotes (ppr main_mod) }
ppMainFn :: RdrName -> SDoc
ppMainFn main_fn
| rdrNameOcc main_fn == mainOcc
= text "IO action" <+> quotes (ppr main_fn)
| otherwise
= text "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 $ withHoleFitPlugins 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 mb_pkg = fmap (\iface -> mi_module iface
: dep_orphs (mi_deps iface))
(loadSrcInterface (text "runTcInteractive") m
False mb_pkg)
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of
IIModule n -> getOrphans n Nothing
IIDecl i ->
let mb_pkg = sl_fs <$> ideclPkgQual i in
getOrphans (unLoc (ideclName i)) mb_pkg
; let imports = emptyImportAvails {
imp_orphs = orphs
}
; (gbl_env, lcl_env) <- getEnvs
; 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 = mkNameEnv con_fields
, tcg_fix_env = ic_fix_env icxt
, tcg_default = ic_default icxt
, tcg_imports = imports
}
lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids
; setEnvs (gbl_env', lcl_env') thing_inside }
where
(home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)
icxt = hsc_IC hsc_env
(ic_insts, ic_finsts) = ic_instances icxt
(lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt)
is_closed :: TyThing -> Either (Name, TcTyThing) TyThing
is_closed thing
| AnId id <- thing
, not (isTypeClosedLetBndr id)
= Left (idName id, ATcId { tct_id = id
, tct_info = NotLetBound })
| otherwise
= Right thing
type_env1 = mkTypeEnvWithImplicits top_ty_things
type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)
con_fields = [ (dataConName c, dataConFieldLabels c)
| ATyCon t <- top_ty_things
, c <- tyConDataCons t ]
tcRnStmt :: HscEnv -> GhciLStmt GhcPs
-> IO (Messages, Maybe ([Id], LHsExpr GhcTc, 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 ;
failIfErrsM ;
mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ;
traceTc "tcs 1" empty ;
this_mod <- getModule ;
global_ids <- mapM (externaliseAndTidyId this_mod) 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 [text "GHCi can't bind a variable of unlifted type:",
nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
type PlanResult = ([Id], LHsExpr GhcTc)
type Plan = TcM PlanResult
runPlans :: [Plan] -> TcM PlanResult
runPlans [] = panic "runPlans"
runPlans [p] = p
runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p
tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
tcUserStmt (dL->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 (mkPrefixFunRhs (cL loc fresh_it)) [] rn_expr
(noLoc emptyLocalBinds)]
the_bind = cL loc $ (mkTopFunBind FromSource
(cL loc fresh_it) matches)
{ fun_ext = fvs }
let_stmt = cL loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField
$ XValBindsLR
(NValBinds [(NonRecursive,unitBag the_bind)] [])
bind_stmt = cL loc $ BindStmt noExtField
(cL loc (VarPat noExtField (cL loc fresh_it)))
(nlHsApp ghciStep rn_expr)
(mkRnSyntaxExpr bindIOName)
noSyntaxExpr
print_it = cL loc $ BodyStmt noExtField
(nlHsApp (nlHsVar interPrintName)
(nlHsVar fresh_it))
(mkRnSyntaxExpr thenIOName)
noSyntaxExpr
no_it_a = cL loc $ BodyStmt noExtField (nlHsApps bindIOName
[rn_expr , nlHsVar interPrintName])
(mkRnSyntaxExpr thenIOName)
noSyntaxExpr
no_it_b = cL loc $ BodyStmt noExtField (rn_expr)
(mkRnSyntaxExpr thenIOName)
noSyntaxExpr
no_it_c = cL loc $ BodyStmt noExtField
(nlHsApp (nlHsVar interPrintName) rn_expr)
(mkRnSyntaxExpr thenIOName)
noSyntaxExpr
it_plans = [
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] } ]
no_it_plans = [
tcGhciStmts [no_it_a] ,
tcGhciStmts [no_it_b] ,
tcGhciStmts [no_it_c] ]
; generate_it <- goptM Opt_NoIt
; plan <- unsetGOptM Opt_DeferTypeErrors $
unsetGOptM Opt_DeferTypedHoles $
unsetGOptM Opt_DeferOutOfScopeVariables $
runPlans $ if generate_it
then no_it_plans
else it_plans
; fix_env <- getFixityEnv
; return (plan, fix_env) }
tcUserStmt rdr_stmt@(dL->L loc _)
= do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do
fix_env <- getFixityEnv
return (fix_env, emptyFVs)
; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
; rnDump rn_stmt ;
; ghciStep <- getGhciStepIO
; let gi_stmt
| (dL->L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt
= cL loc $ BindStmt ty 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 = cL loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName)
(nlHsVar v))
(mkRnSyntaxExpr thenIOName) noSyntaxExpr
tcGhciStmts :: [GhciLStmt GhcRn] -> 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
(mkCheckExpType io_ret_ty) ;
names = collectLStmtsBinders stmts ;
} ;
traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
((tc_stmts, ids), lie) <- captureTopConstraints $
tc_io_stmts $ \ _ ->
mapM tcLookupId names ;
traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
const_binds <- checkNoErrs (simplifyInteractive 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 = let ty_args = [idType id, unitTy] in
nlHsApp (nlHsTyApp unsafeCoerceId
(map getRuntimeRep ty_args ++ ty_args))
(nlHsVar id) ;
stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
} ;
return (ids, mkHsDictLet (EvBinds const_binds) $
noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts)))
}
getGhciStepIO :: TcM (LHsExpr GhcRn)
getGhciStepIO = do
ghciTy <- getGHCiMonad
a_tv <- newName (mkTyVarOccFS (fsLit "a"))
let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
step_ty = noLoc $ HsForAllTy
{ hst_fvf = ForallInvis
, hst_bndrs = [noLoc $ UserTyVar noExtField (noLoc a_tv)]
, hst_xforall = noExtField
, hst_body = nlHsFunTy ghciM ioM }
stepTy :: LHsSigWcType GhcRn
stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)
return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy)
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 "Ambiguous type!"
Nothing -> failWithTc $ text ("Can't find type:" ++ ty)
data TcRnExprMode = TM_Inst
| TM_NoInst
| TM_Default
tcRnExpr :: HscEnv
-> TcRnExprMode
-> LHsExpr GhcPs
-> IO (Messages, Maybe Type)
tcRnExpr hsc_env mode rdr_expr
= runTcInteractive hsc_env $
do {
(rn_expr, _fvs) <- rnLExpr rdr_expr ;
failIfErrsM ;
uniq <- newUnique ;
let { fresh_it = itName uniq (getLoc rdr_expr)
; orig = lexprCtOrigin rn_expr } ;
((tclvl, res_ty), lie)
<- captureTopConstraints $
pushTcLevelM $
do { (_tc_expr, expr_ty) <- tcInferSigma rn_expr
; if inst
then snd <$> deeplyInstantiate orig expr_ty
else return expr_ty } ;
(qtvs, dicts, _, residual, _)
<- simplifyInfer tclvl infer_mode
[]
[(fresh_it, res_ty)]
lie ;
_ <- perhaps_disable_default_warnings $
simplifyInteractive residual ;
let { all_expr_ty = mkInvForAllTys qtvs $
mkPhiTy (map idType dicts) res_ty } ;
ty <- zonkTcType all_expr_ty ;
fam_envs <- tcGetFamInstEnvs ;
return (snd (normaliseType fam_envs Nominal ty))
}
where
(inst, infer_mode, perhaps_disable_default_warnings) = case mode of
TM_Inst -> (True, NoRestrictions, id)
TM_NoInst -> (False, NoRestrictions, id)
TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults)
tcRnImportDecls :: HscEnv
-> [LImportDecl GhcPs]
-> 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
-> ZonkFlexi
-> Bool
-> LHsType GhcPs
-> IO (Messages, Maybe (Type, Kind))
tcRnType hsc_env flexi normalise rdr_type
= runTcInteractive hsc_env $
setXOptM LangExt.PolyKinds $
do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs)
<- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type)
; failIfErrsM
; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type])
; (ty, kind) <- pushTcLevelM_ $
solveEqualities $
tcNamedWildCardBinders wcs $ \ wcs' ->
do { emitNamedWildCardHoleConstraints wcs'
; tcLHsTypeUnsaturated rn_type }
; kvs <- kindGeneralizeAll kind
; e <- mkEmptyZonkEnv flexi
; ty <- zonkTcTypeToTypeX e ty
; checkValidType (GhciCtxt True) ty
; ty' <- if normalise
then do { fam_envs <- tcGetFamInstEnvs
; let (_, ty')
= normaliseType fam_envs Nominal ty
; return ty' }
else return ty ;
; return (ty', mkInvForAllTys kvs (tcTypeKind ty')) }
tcRnDeclsi :: HscEnv
-> [LHsDecl GhcPs]
-> IO (Messages, Maybe TcGblEnv)
tcRnDeclsi hsc_env local_decls
= runTcInteractive hsc_env $
tcRnSrcDecls False local_decls
externaliseAndTidyId :: Module -> Id -> TcM Id
externaliseAndTidyId this_mod id
= do { name' <- externaliseName this_mod (idName id)
; return $ globaliseId id
`setIdName` name'
`setIdType` tidyTopType (idType id) }
getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
getModuleInterface hsc_env mod
= runTcInteractive hsc_env $
loadModuleInterface (text "getModuleInterface") mod
tcRnLookupRdrName :: HscEnv -> Located RdrName
-> IO (Messages, Maybe [Name])
tcRnLookupRdrName hsc_env (dL->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 (text "Not in scope:" <+> quotes (ppr rdr_name)))
; return names }
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], SDoc))
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
; let info = lookupKnownNameInfo name
; return (thing, fixity, cls_insts, fam_insts, info) }
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
, nameIsFromExternalPackage this_pkg name
, isTcOcc (nameOccName name)
, unQualOK gre ]
doc = text "Need interface for module whose export(s) are in scope unqualified"
rnDump :: (Outputable a, Data a) => a -> TcRn ()
rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn)) }
tcDump :: TcGblEnv -> TcRn ()
tcDump env
= do { dflags <- getDynFlags ;
when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
(traceTcRnForUser Opt_D_dump_types short_dump) ;
traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump);
traceOptTcRn Opt_D_dump_tc_ast (mkDumpDoc "Typechecker" ast_dump)
}
where
short_dump = pprTcGblEnv env
full_dump = pprLHsBinds (tcg_binds env)
ast_dump = showAstData NoBlankSrcSpan (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_imports = imports })
= getPprDebug $ \debug ->
vcat [ ppr_types debug type_env
, ppr_tycons debug fam_insts type_env
, ppr_datacons debug type_env
, ppr_patsyns type_env
, ppr_insts insts
, ppr_fam_insts fam_insts
, ppr_rules rules
, text "Dependent modules:" <+>
pprUFM (imp_dep_mods imports) (ppr . sort)
, text "Dependent packages:" <+>
ppr (S.toList $ imp_dep_pkgs imports)]
where
ppr_rules :: [LRuleDecl GhcTc] -> SDoc
ppr_rules rules
= ppUnless (null rules) $
hang (text "RULES")
2 (vcat (map ppr rules))
ppr_types :: Bool -> TypeEnv -> SDoc
ppr_types debug type_env
= ppr_things "TYPE SIGNATURES" ppr_sig
(sortBy (comparing getOccName) ids)
where
ids = [id | id <- typeEnvIds type_env, want_sig id]
want_sig id
| debug = True
| otherwise = hasTopUserName id
&& case idDetails id of
VanillaId -> True
RecSelId {} -> True
ClassOpId {} -> True
FCallId {} -> True
_ -> False
ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc
ppr_tycons debug fam_insts type_env
= vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons
, ppr_things "COERCION AXIOMS" ppr_ax
(typeEnvCoAxioms type_env) ]
where
fi_tycons = famInstsRepTyCons fam_insts
tycons = sortBy (comparing getOccName) $
[tycon | tycon <- typeEnvTyCons type_env
, want_tycon tycon]
want_tycon tycon | debug = True
| otherwise = isExternalName (tyConName tycon) &&
not (tycon `elem` fi_tycons)
ppr_tc tc
= vcat [ hang (ppr (tyConFlavour tc) <+> ppr tc
<> braces (ppr (tyConArity tc)) <+> dcolon)
2 (ppr (tidyTopType (tyConKind tc)))
, nest 2 $
ppWhen show_roles $
text "roles" <+> (sep (map ppr roles)) ]
where
show_roles = debug || not (all (== boring_role) roles)
roles = tyConRoles tc
boring_role | isClassTyCon tc = Nominal
| otherwise = Representational
ppr_ax ax = ppr (coAxiomToIfaceDecl ax)
ppr_datacons :: Bool -> TypeEnv -> SDoc
ppr_datacons debug type_env
= ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs
where
ppr_dc dc = ppr dc <+> dcolon <+> ppr (dataConUserType dc)
all_dcs = typeEnvDataCons type_env
wanted_dcs | debug = all_dcs
| otherwise = filterOut is_cls_dc all_dcs
is_cls_dc dc = isClassTyCon (dataConTyCon dc)
ppr_patsyns :: TypeEnv -> SDoc
ppr_patsyns type_env
= ppr_things "PATTERN SYNONYMS" ppr_ps
(typeEnvPatSyns type_env)
where
ppr_ps ps = ppr ps <+> dcolon <+> pprPatSynType ps
ppr_insts :: [ClsInst] -> SDoc
ppr_insts ispecs
= ppr_things "CLASS INSTANCES" pprInstance ispecs
ppr_fam_insts :: [FamInst] -> SDoc
ppr_fam_insts fam_insts
= ppr_things "FAMILY INSTANCES" pprFamInst fam_insts
ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc
ppr_things herald ppr_one things
| null things = empty
| otherwise = text herald $$ nest 2 (vcat (map ppr_one things))
hasTopUserName :: NamedThing x => x -> Bool
hasTopUserName x
= isExternalName name && not (isDerivedOccName (nameOccName name))
where
name = getName x
withTcPlugins :: HscEnv -> TcM a -> TcM a
withTcPlugins hsc_env m =
do let plugins = getTcPlugins (hsc_dflags hsc_env)
case plugins of
[] -> m
_ -> do ev_binds_var <- newTcEvBinds
(solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins
eitherRes <- tryM $ do
updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m
mapM_ (flip runTcPluginM ev_binds_var) stops
case eitherRes of
Left _ -> failM
Right res -> return res
where
startPlugin ev_binds_var (TcPlugin start solve stop) =
do s <- runTcPluginM start ev_binds_var
return (solve s, stop s)
getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin]
getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args)
withHoleFitPlugins :: HscEnv -> TcM a -> TcM a
withHoleFitPlugins hsc_env m =
case (getHfPlugins (hsc_dflags hsc_env)) of
[] -> m
plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins
eitherRes <- tryM $ do
updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m
sequence_ stops
case eitherRes of
Left _ -> failM
Right res -> return res
where
startPlugin (HoleFitPluginR init plugin stop) =
do ref <- init
return (plugin ref, stop ref)
getHfPlugins :: DynFlags -> [HoleFitPluginR]
getHfPlugins dflags =
catMaybes $ mapPlugins dflags (\p args -> holeFitPlugin p args)
runRenamerPlugin :: TcGblEnv
-> HsGroup GhcRn
-> TcM (TcGblEnv, HsGroup GhcRn)
runRenamerPlugin gbl_env hs_group = do
dflags <- getDynFlags
withPlugins dflags
(\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g))
(gbl_env, hs_group)
type RenamedStuff =
(Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
Maybe LHsDocString))
getRenamedStuff :: TcGblEnv -> RenamedStuff
getRenamedStuff tc_result
= fmap (\decls -> ( decls, tcg_rn_imports tc_result
, tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) )
(tcg_rn_decls tc_result)
runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv
runTypecheckerPlugin sum hsc_env gbl_env = do
let dflags = hsc_dflags hsc_env
withPlugins dflags
(\p opts env -> mark_plugin_unsafe dflags
>> typeCheckResultAction p opts sum env)
gbl_env
mark_plugin_unsafe :: DynFlags -> TcM ()
mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $
recordUnsafeInfer pluginUnsafe
where
unsafeText = "Use of plugins makes the module unsafe"
pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan
(Outputable.text unsafeText) )