import TcRnTypes -- Re-export all
import IOEnv -- Re-export all
-#if defined(GHCI) && defined(BREAKPOINT)
-import TypeRep
-import Var
-import IdInfo
-import OccName
-import SrcLoc
-import TysWiredIn
-import PrelNames
-import NameEnv
-import TcEnv
-#endif
-
import HsSyn hiding (LIE)
import HscTypes
import Module
import InstEnv
import FamInstEnv
+import Coercion
import Var
import Id
import VarSet
import Bag
import Outputable
import UniqSupply
-import UniqFM
import Unique
import DynFlags
import StaticFlags
\end{code}
\begin{code}
+
initTc :: HscEnv
-> HscSource
+ -> Bool -- True <=> retain renamed syntax trees
-> Module
-> TcM r
-> IO (Messages, Maybe r)
-- Nothing => error thrown by the thing inside
-- (error messages should have been printed already)
-initTc hsc_env hsc_src mod do_this
+initTc hsc_env hsc_src keep_rn_syntax mod do_this
= do { errs_var <- newIORef (emptyBag, emptyBag) ;
tvs_var <- newIORef emptyVarSet ;
type_env_var <- newIORef emptyNameEnv ;
th_var <- newIORef False ;
dfun_n_var <- newIORef 1 ;
let {
+ maybe_rn_syntax empty_val
+ | keep_rn_syntax = Just empty_val
+ | otherwise = Nothing ;
+
gbl_env = TcGblEnv {
- tcg_mod = mod,
- tcg_src = hsc_src,
- tcg_rdr_env = hsc_global_rdr_env hsc_env,
- tcg_fix_env = emptyNameEnv,
- tcg_default = Nothing,
- tcg_type_env = hsc_global_type_env hsc_env,
+ tcg_mod = mod,
+ tcg_src = hsc_src,
+ tcg_rdr_env = hsc_global_rdr_env hsc_env,
+ tcg_fix_env = emptyNameEnv,
+ tcg_field_env = emptyNameEnv,
+ tcg_default = Nothing,
+ tcg_type_env = hsc_global_type_env hsc_env,
tcg_type_env_var = type_env_var,
tcg_inst_env = emptyInstEnv,
tcg_fam_inst_env = emptyFamInstEnv,
tcg_inst_uses = dfuns_var,
tcg_th_used = th_var,
tcg_exports = [],
- tcg_imports = init_imports,
+ tcg_imports = emptyImportAvails,
tcg_dus = emptyDUs,
- tcg_rn_imports = Nothing,
- tcg_rn_exports = Nothing,
- tcg_rn_decls = Nothing,
+
+ tcg_rn_imports = maybe_rn_syntax [],
+ tcg_rn_exports = maybe_rn_syntax [],
+ tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
+
tcg_binds = emptyLHsBinds,
tcg_deprecs = NoDeprecs,
tcg_insts = [],
tcg_dfun_n = dfun_n_var,
tcg_keep = keep_var,
tcg_doc = Nothing,
- tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing
+ tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing,
+ tcg_hpc = False
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
-- OK, here's the business end!
maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
- addBreakpointBindings $
do { r <- tryM do_this
; case r of
Right res -> return (Just res)
return (msgs, final_res)
}
- where
- init_imports = emptyImportAvails {imp_env = unitUFM (moduleName mod) []}
- -- Initialise tcg_imports with an empty set of bindings for
- -- this module, so that if we see 'module M' in the export
- -- list, and there are no bindings in M, we don't bleat
- -- "unknown module M".
initTcPrintErrors -- Used from the interactive loop only
:: HscEnv
-> TcM r
-> IO (Maybe r)
initTcPrintErrors env mod todo = do
- (msgs, res) <- initTc env HsSrcFile mod todo
+ (msgs, res) <- initTc env HsSrcFile False mod todo
printErrorsAndWarnings (hsc_dflags env) msgs
return res
\end{code}
-\begin{code}
-addBreakpointBindings :: TcM a -> TcM a
-addBreakpointBindings thing_inside
-#if defined(GHCI) && defined(BREAKPOINT)
- = do { unique <- newUnique
- ; let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
- tyvar = mkTyVar var liftedTypeKind;
- basicType extra = (FunTy intTy
- (FunTy (mkListTy unitTy)
- (FunTy stringTy
- (ForAllTy tyvar
- (extra
- (FunTy (TyVarTy tyvar)
- (TyVarTy tyvar)))))));
- breakpointJumpId
- = mkGlobalId VanillaGlobal breakpointJumpName
- (basicType id) vanillaIdInfo;
- breakpointCondJumpId
- = mkGlobalId VanillaGlobal breakpointCondJumpName
- (basicType (FunTy boolTy)) vanillaIdInfo
- }
- ; tcExtendIdEnv [breakpointJumpId, breakpointCondJumpId] thing_inside}
-#else
- = thing_inside
-#endif
-\end{code}
-
%************************************************************************
%* *
Initialisation
; let { env = Env { env_top = hsc_env,
env_us = us_var,
env_gbl = gbl_env,
- env_lcl = lcl_env } }
+ env_lcl = lcl_env} }
; runIOEnv env thing_inside
}
newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name -- Make a clone
= do { uniq <- newUnique
- ; return (mkInternalName uniq (nameOccName name) (getSrcLoc name)) }
+ ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) }
newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys
= updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
-getDefaultTys :: TcRn (Maybe [Type])
-getDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
+getRecFieldEnv :: TcRn RecFieldEnv
+getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
+
+extendRecFieldEnv :: RecFieldEnv -> RnM a -> RnM a
+extendRecFieldEnv new_bit
+ = updGblEnv (\env@(TcGblEnv { tcg_field_env = old_env }) ->
+ env {tcg_field_env = old_env `plusNameEnv` new_bit})
+
+getDeclaredDefaultTys :: TcRn (Maybe [Type])
+getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
\end{code}
%************************************************************************
\begin{code}
addWarnTc :: Message -> TcM ()
-addWarnTc msg
+addWarnTc msg = do { env0 <- tcInitTidyEnv
+ ; addWarnTcM (env0, msg) }
+
+addWarnTcM :: (TidyEnv, Message) -> TcM ()
+addWarnTcM (env0, msg)
= do { ctxt <- getErrCtxt ;
- env0 <- tcInitTidyEnv ;
ctxt_msgs <- do_ctxt env0 ctxt ;
- addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) }
+ addReport (vcat (ptext SLIT("Warning:") <+> msg : ctxt_to_use ctxt_msgs)) }
warnTc :: Bool -> Message -> TcM ()
warnTc warn_if_true warn_msg
-- pprPanic "forkM" doc
Just r -> r) }
\end{code}
-
-
projects / ghc-hetmet.git / blobdiff