module TcRnMonad(
module TcRnMonad,
module TcRnTypes,
module IOEnv
) where
#include "HsVersions.h"
import TcRnTypes
import IOEnv
import TcEvidence
import HsSyn hiding (LIE)
import HscTypes
import Module
import RdrName
import Name
import Type
import TcType
import InstEnv
import FamInstEnv
import PrelNames
import Var
import Id
import VarSet
import VarEnv
import ErrUtils
import SrcLoc
import NameEnv
import NameSet
import Bag
import Outputable
import UniqSupply
import UniqFM
import DynFlags
import StaticFlags
import FastString
import Panic
import Util
import Annotations
import BasicTypes( TopLevelFlag )
import Control.Exception
import Data.IORef
import qualified Data.Set as Set
import Control.Monad
#ifdef GHCI
import qualified Data.Map as Map
#endif
initTc :: HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages, Maybe r)
initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
= do { errs_var <- newIORef (emptyBag, emptyBag) ;
tvs_var <- newIORef emptyVarSet ;
keep_var <- newIORef emptyNameSet ;
used_rdr_var <- newIORef Set.empty ;
th_var <- newIORef False ;
th_splice_var<- newIORef False ;
infer_var <- newIORef True ;
lie_var <- newIORef emptyWC ;
dfun_n_var <- newIORef emptyOccSet ;
type_env_var <- case hsc_type_env_var hsc_env of {
Just (_mod, te_var) -> return te_var ;
Nothing -> newIORef emptyNameEnv } ;
dependent_files_var <- newIORef [] ;
static_wc_var <- newIORef emptyWC ;
#ifdef GHCI
th_topdecls_var <- newIORef [] ;
th_topnames_var <- newIORef emptyNameSet ;
th_modfinalizers_var <- newIORef [] ;
th_state_var <- newIORef Map.empty ;
#endif /* GHCI */
let {
dflags = hsc_dflags hsc_env ;
maybe_rn_syntax :: forall a. a -> Maybe a ;
maybe_rn_syntax empty_val
| keep_rn_syntax = Just empty_val
| otherwise = Nothing ;
gbl_env = TcGblEnv {
#ifdef GHCI
tcg_th_topdecls = th_topdecls_var,
tcg_th_topnames = th_topnames_var,
tcg_th_modfinalizers = th_modfinalizers_var,
tcg_th_state = th_state_var,
#endif /* GHCI */
tcg_mod = mod,
tcg_src = hsc_src,
tcg_sig_of = getSigOf dflags (moduleName mod),
tcg_impl_rdr_env = Nothing,
tcg_rdr_env = emptyGlobalRdrEnv,
tcg_fix_env = emptyNameEnv,
tcg_field_env = RecFields emptyNameEnv emptyNameSet,
tcg_default = Nothing,
tcg_type_env = emptyNameEnv,
tcg_type_env_var = type_env_var,
tcg_inst_env = emptyInstEnv,
tcg_fam_inst_env = emptyFamInstEnv,
tcg_ann_env = emptyAnnEnv,
tcg_visible_orphan_mods = mkModuleSet [mod],
tcg_th_used = th_var,
tcg_th_splice_used = th_splice_var,
tcg_exports = [],
tcg_imports = emptyImportAvails,
tcg_used_rdrnames = used_rdr_var,
tcg_dus = emptyDUs,
tcg_rn_imports = [],
tcg_rn_exports = maybe_rn_syntax [],
tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
tcg_binds = emptyLHsBinds,
tcg_imp_specs = [],
tcg_sigs = emptyNameSet,
tcg_ev_binds = emptyBag,
tcg_warns = NoWarnings,
tcg_anns = [],
tcg_tcs = [],
tcg_insts = [],
tcg_fam_insts = [],
tcg_rules = [],
tcg_fords = [],
tcg_vects = [],
tcg_patsyns = [],
tcg_dfun_n = dfun_n_var,
tcg_keep = keep_var,
tcg_doc_hdr = Nothing,
tcg_hpc = False,
tcg_main = Nothing,
tcg_safeInfer = infer_var,
tcg_dependent_files = dependent_files_var,
tcg_tc_plugins = [],
tcg_static_wc = static_wc_var
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
tcl_loc = loc,
tcl_ctxt = [],
tcl_rdr = emptyLocalRdrEnv,
tcl_th_ctxt = topStage,
tcl_th_bndrs = emptyNameEnv,
tcl_arrow_ctxt = NoArrowCtxt,
tcl_env = emptyNameEnv,
tcl_bndrs = [],
tcl_tidy = emptyTidyEnv,
tcl_tyvars = tvs_var,
tcl_lie = lie_var,
tcl_tclvl = topTcLevel
} ;
} ;
maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
do { r <- tryM do_this
; case r of
Right res -> return (Just res)
Left _ -> return Nothing } ;
lie <- readIORef lie_var ;
if isEmptyWC lie
then return ()
else pprPanic "initTc: unsolved constraints" (ppr lie) ;
msgs <- readIORef errs_var ;
let { final_res | errorsFound dflags msgs = Nothing
| otherwise = maybe_res } ;
return (msgs, final_res)
}
initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
initTcInteractive hsc_env thing_inside
= initTc hsc_env HsSrcFile False
(icInteractiveModule (hsc_IC hsc_env))
(realSrcLocSpan interactive_src_loc)
thing_inside
where
interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
initTcForLookup :: HscEnv -> TcM a -> IO a
initTcForLookup hsc_env thing_inside
= do { (msgs, m) <- initTcInteractive hsc_env thing_inside
; case m of
Nothing -> throwIO $ mkSrcErr $ snd msgs
Just x -> return x }
initTcRnIf :: Char
-> HscEnv
-> gbl -> lcl
-> TcRnIf gbl lcl a
-> IO a
initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
= do { us <- mkSplitUniqSupply uniq_tag ;
; us_var <- newIORef us ;
; let { env = Env { env_top = hsc_env,
env_us = us_var,
env_gbl = gbl_env,
env_lcl = lcl_env} }
; runIOEnv env thing_inside
}
discardResult :: TcM a -> TcM ()
discardResult a = a >> return ()
getTopEnv :: TcRnIf gbl lcl HscEnv
getTopEnv = do { env <- getEnv; return (env_top env) }
getGblEnv :: TcRnIf gbl lcl gbl
getGblEnv = do { env <- getEnv; return (env_gbl env) }
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
env { env_gbl = upd gbl })
setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
getLclEnv :: TcRnIf gbl lcl lcl
getLclEnv = do { env <- getEnv; return (env_lcl env) }
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
env { env_lcl = upd lcl })
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool
xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
doptM :: DumpFlag -> TcRnIf gbl lcl Bool
doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }
goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }
woptM :: WarningFlag -> TcRnIf gbl lcl Bool
woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
setXOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = gopt_unset (hsc_dflags top) flag}} )
unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = wopt_unset (hsc_dflags top) flag}} )
whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM flag thing_inside = do b <- doptM flag
when b thing_inside
whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenGOptM flag thing_inside = do b <- goptM flag
when b thing_inside
whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM flag thing_inside = do b <- woptM flag
when b thing_inside
whenXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenXOptM flag thing_inside = do b <- xoptM flag
when b thing_inside
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withDoDynamicToo m = do env <- getEnv
let dflags = extractDynFlags env
dflags' = dynamicTooMkDynamicDynFlags dflags
env' = replaceDynFlags env dflags'
setEnv env' m
getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
getEps :: TcRnIf gbl lcl ExternalPackageState
getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
-> TcRnIf gbl lcl a
updateEps upd_fn = do
traceIf (text "updating EPS")
eps_var <- getEpsVar
atomicUpdMutVar' eps_var upd_fn
updateEps_ :: (ExternalPackageState -> ExternalPackageState)
-> TcRnIf gbl lcl ()
updateEps_ upd_fn = do
traceIf (text "updating EPS_")
eps_var <- getEpsVar
atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
; return (eps, hsc_HPT env) }
newArrowScope :: TcM a -> TcM a
newArrowScope
= updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
escapeArrowScope :: TcM a -> TcM a
escapeArrowScope
= updLclEnv $ \ env ->
case tcl_arrow_ctxt env of
NoArrowCtxt -> env
ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
, tcl_lie = lie
, tcl_rdr = rdr_env }
newUnique :: TcRnIf gbl lcl Unique
newUnique
= do { env <- getEnv ;
let { u_var = env_us env } ;
us <- readMutVar u_var ;
case takeUniqFromSupply us of { (uniq, us') -> do {
writeMutVar u_var us' ;
return $! uniq }}}
newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
= do { env <- getEnv ;
let { u_var = env_us env } ;
us <- readMutVar u_var ;
case splitUniqSupply us of { (us1,us2) -> do {
writeMutVar u_var us1 ;
return us2 }}}
newLocalName :: Name -> TcM Name
newLocalName name = newName (nameOccName name)
newName :: OccName -> TcM Name
newName occ
= do { uniq <- newUnique
; loc <- getSrcSpanM
; return (mkInternalName uniq occ loc) }
newSysName :: OccName -> TcM Name
newSysName occ
= do { uniq <- newUnique
; return (mkSystemName uniq occ) }
newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
newSysLocalId fs ty
= do { u <- newUnique
; return (mkSysLocal fs u ty) }
newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys
= do { us <- newUniqueSupply
; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
instance MonadUnique (IOEnv (Env gbl lcl)) where
getUniqueM = newUnique
getUniqueSupplyM = newUniqueSupply
newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
newTcRef = newMutVar
readTcRef :: TcRef a -> TcRnIf gbl lcl a
readTcRef = readMutVar
writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef = writeMutVar
updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef ref fn = liftIO $ do { old <- readIORef ref
; writeIORef ref (fn old) }
updTcRefX :: TcRef a -> (a -> a) -> TcRnIf gbl lcl a
updTcRefX ref fn = liftIO $ do { old <- readIORef ref
; writeIORef ref (fn old)
; return old }
traceTc :: String -> SDoc -> TcRn ()
traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
traceTcN :: Int -> SDoc -> TcRn ()
traceTcN level doc
= do dflags <- getDynFlags
when (level <= traceLevel dflags && not opt_NoDebugOutput) $
traceOptTcRn Opt_D_dump_tc_trace doc
traceRn :: SDoc -> TcRn ()
traceRn = traceOptTcRn Opt_D_dump_rn_trace
traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc
= do { dflags <- getDynFlags
; when (dopt flag dflags) (traceTcRn flag doc)
}
traceTcRn :: DumpFlag -> SDoc -> TcRn ()
traceTcRn flag doc
= do { real_doc <- prettyDoc doc
; dflags <- getDynFlags
; printer <- getPrintUnqualified dflags
; liftIO $ dumpSDoc dflags printer flag "" real_doc }
where
prettyDoc :: SDoc -> TcRn SDoc
prettyDoc doc = if opt_PprStyle_Debug
then do { loc <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
else return doc
getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
getPrintUnqualified dflags
= do { rdr_env <- getGlobalRdrEnv
; return $ mkPrintUnqualified dflags rdr_env }
printForUserTcRn :: SDoc -> TcRn ()
printForUserTcRn doc
= do { dflags <- getDynFlags
; printer <- getPrintUnqualified dflags
; liftIO (printInfoForUser dflags printer doc) }
debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc = unless opt_NoDebugOutput $
traceOptTcRn Opt_D_dump_tc doc
traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
traceIf = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf flag doc
= whenDOptM flag $
do { dflags <- getDynFlags
; liftIO (putMsg dflags doc) }
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
getIsGHCi :: TcRn Bool
getIsGHCi = do { mod <- getModule
; return (isInteractiveModule mod) }
getGHCiMonad :: TcRn Name
getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
getInteractivePrintName :: TcRn Name
getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
getImports :: TcRn ImportAvails
getImports = do { env <- getGblEnv; return (tcg_imports env) }
getFixityEnv :: TcRn FixityEnv
getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
extendFixityEnv new_bit
= updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles fs = do
ref <- fmap tcg_dependent_files getGblEnv
dep_files <- readTcRef ref
writeTcRef ref (fs ++ dep_files)
getSrcSpanM :: TcRn SrcSpan
getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan (RealSrcSpan real_loc) thing_inside
= updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
addLocM :: (a -> TcM b) -> Located a -> TcM b
addLocM fn (L loc a) = setSrcSpan loc $ fn a
wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
setSrcSpan loc $ do
(b,c) <- fn a
return (L loc b, c)
wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
wrapLocSndM fn (L loc a) =
setSrcSpan loc $ do
(b,c) <- fn a
return (b, L loc c)
getErrsVar :: TcRn (TcRef Messages)
getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v })
addErr :: MsgDoc -> TcRn ()
addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
failWith :: MsgDoc -> TcRn a
failWith msg = addErr msg >> failM
addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
addErrAt loc msg = do { ctxt <- getErrCtxt
; tidy_env <- tcInitTidyEnv
; err_info <- mkErrInfo tidy_env ctxt
; addLongErrAt loc msg err_info }
addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
addErrs msgs = mapM_ add msgs
where
add (loc,msg) = addErrAt loc msg
checkErr :: Bool -> MsgDoc -> TcRn ()
checkErr ok msg = unless ok (addErr msg)
warnIf :: Bool -> MsgDoc -> TcRn ()
warnIf True msg = addWarn msg
warnIf False _ = return ()
addMessages :: Messages -> TcRn ()
addMessages (m_warns, m_errs)
= do { errs_var <- getErrsVar ;
(warns, errs) <- readTcRef errs_var ;
writeTcRef errs_var (warns `unionBags` m_warns,
errs `unionBags` m_errs) }
discardWarnings :: TcRn a -> TcRn a
discardWarnings thing_inside
= do { errs_var <- getErrsVar
; (old_warns, _) <- readTcRef errs_var ;
; result <- thing_inside
; (_new_warns, new_errs) <- readTcRef errs_var
; writeTcRef errs_var (old_warns, new_errs)
; return result }
mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
mkLongErrAt loc msg extra
= do { dflags <- getDynFlags ;
printer <- getPrintUnqualified dflags ;
return $ mkLongErrMsg dflags loc printer msg extra }
addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
reportErrors :: [ErrMsg] -> TcM ()
reportErrors = mapM_ reportError
reportError :: ErrMsg -> TcRn ()
reportError err
= do { traceTc "Adding error:" (pprLocErrMsg err) ;
errs_var <- getErrsVar ;
(warns, errs) <- readTcRef errs_var ;
writeTcRef errs_var (warns, errs `snocBag` err) }
reportWarning :: ErrMsg -> TcRn ()
reportWarning warn
= do { traceTc "Adding warning:" (pprLocErrMsg warn) ;
errs_var <- getErrsVar ;
(warns, errs) <- readTcRef errs_var ;
writeTcRef errs_var (warns `snocBag` warn, errs) }
try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
try_m thing
= do { mb_r <- tryM thing ;
case mb_r of
Left exn -> do { traceTc "tryTc/recoverM recovering from" $
text (showException exn)
; return mb_r }
Right _ -> return mb_r }
recoverM :: TcRn r
-> TcRn r
-> TcRn r
recoverM recover thing
= do { mb_res <- try_m thing ;
case mb_res of
Left _ -> recover
Right res -> return res }
mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM _ [] = return []
mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
; rs <- mapAndRecoverM f xs
; return (case mb_r of
Left _ -> rs
Right r -> r:rs) }
mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
tryTc m
= do { errs_var <- newTcRef emptyMessages ;
res <- try_m (setErrsVar errs_var m) ;
msgs <- readTcRef errs_var ;
return (msgs, case res of
Left _ -> Nothing
Right val -> Just val)
}
tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
tryTcErrs thing
= do { (msgs, res) <- tryTc thing
; dflags <- getDynFlags
; let errs_found = errorsFound dflags msgs
; return (msgs, case res of
Nothing -> Nothing
Just val | errs_found -> Nothing
| otherwise -> Just val)
}
tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
tryTcLIE thing_inside
= do { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
; case mb_res of
Nothing -> return (msgs, Nothing)
Just val -> do { emitConstraints lie; return (msgs, Just val) }
}
tryTcLIE_ :: TcM r -> TcM r -> TcM r
tryTcLIE_ recover main
= do { (msgs, mb_res) <- tryTcLIE main
; case mb_res of
Just val -> do { addMessages msgs
; return val }
Nothing -> recover
}
checkNoErrs :: TcM r -> TcM r
checkNoErrs main
= do { (msgs, mb_res) <- tryTcLIE main
; addMessages msgs
; case mb_res of
Nothing -> failM
Just val -> return val
}
whenNoErrs :: TcM () -> TcM ()
whenNoErrs thing = ifErrsM (return ()) thing
ifErrsM :: TcRn r -> TcRn r -> TcRn r
ifErrsM bale_out normal
= do { errs_var <- getErrsVar ;
msgs <- readTcRef errs_var ;
dflags <- getDynFlags ;
if errorsFound dflags msgs then
bale_out
else
normal }
failIfErrsM :: TcRn ()
failIfErrsM = ifErrsM failM (return ())
checkTH :: Outputable a => a -> String -> TcRn ()
#ifdef GHCI
checkTH _ _ = return ()
#else
checkTH e what = failTH e what
#endif
failTH :: Outputable a => a -> String -> TcRn x
failTH e what
= failWithTc (vcat [ hang (char 'A' <+> text what
<+> ptext (sLit "requires GHC with interpreter support:"))
2 (ppr e)
, ptext (sLit "Perhaps you are using a stage-1 compiler?") ])
getErrCtxt :: TcM [ErrCtxt]
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
addErrCtxt :: MsgDoc -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
env { tcl_ctxt = upd ctxt })
popErrCtxt :: TcM a -> TcM a
popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
getCtLoc :: CtOrigin -> TcM CtLoc
getCtLoc origin
= do { env <- getLclEnv
; return (CtLoc { ctl_origin = origin
, ctl_env = env
, ctl_depth = initialSubGoalDepth }) }
setCtLoc :: CtLoc -> TcM a -> TcM a
setCtLoc (CtLoc { ctl_env = lcl }) thing_inside
= updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
, tcl_bndrs = tcl_bndrs lcl
, tcl_ctxt = tcl_ctxt lcl })
thing_inside
addErrTc :: MsgDoc -> TcM ()
addErrTc err_msg = do { env0 <- tcInitTidyEnv
; addErrTcM (env0, err_msg) }
addErrsTc :: [MsgDoc] -> TcM ()
addErrsTc err_msgs = mapM_ addErrTc err_msgs
addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
addErrTcM (tidy_env, err_msg)
= do { ctxt <- getErrCtxt ;
loc <- getSrcSpanM ;
add_err_tcm tidy_env err_msg loc ctxt }
mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
mkErrTcM (tidy_env, err_msg)
= do { ctxt <- getErrCtxt ;
loc <- getSrcSpanM ;
err_info <- mkErrInfo tidy_env ctxt ;
mkLongErrAt loc err_msg err_info }
failWithTc :: MsgDoc -> TcM a
failWithTc err_msg
= addErrTc err_msg >> failM
failWithTcM :: (TidyEnv, MsgDoc) -> TcM a
failWithTcM local_and_msg
= addErrTcM local_and_msg >> failM
checkTc :: Bool -> MsgDoc -> TcM ()
checkTc True _ = return ()
checkTc False err = failWithTc err
warnTc :: Bool -> MsgDoc -> TcM ()
warnTc warn_if_true warn_msg
| warn_if_true = addWarnTc warn_msg
| otherwise = return ()
addWarnTc :: MsgDoc -> TcM ()
addWarnTc msg = do { env0 <- tcInitTidyEnv
; addWarnTcM (env0, msg) }
addWarnTcM :: (TidyEnv, MsgDoc) -> TcM ()
addWarnTcM (env0, msg)
= do { ctxt <- getErrCtxt ;
err_info <- mkErrInfo env0 ctxt ;
add_warn msg err_info }
addWarn :: MsgDoc -> TcRn ()
addWarn msg = add_warn msg Outputable.empty
addWarnAt :: SrcSpan -> MsgDoc -> TcRn ()
addWarnAt loc msg = add_warn_at loc msg Outputable.empty
add_warn :: MsgDoc -> MsgDoc -> TcRn ()
add_warn msg extra_info
= do { loc <- getSrcSpanM
; add_warn_at loc msg extra_info }
add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
add_warn_at loc msg extra_info
= do { dflags <- getDynFlags ;
printer <- getPrintUnqualified dflags ;
let { warn = mkLongWarnMsg dflags loc printer
msg extra_info } ;
reportWarning warn }
tcInitTidyEnv :: TcM TidyEnv
tcInitTidyEnv
= do { lcl_env <- getLclEnv
; return (tcl_tidy lcl_env) }
add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
-> [ErrCtxt]
-> TcM ()
add_err_tcm tidy_env err_msg loc ctxt
= do { err_info <- mkErrInfo tidy_env ctxt ;
addLongErrAt loc err_msg err_info }
mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
mkErrInfo env ctxts
| otherwise
= go 0 env ctxts
where
go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
go _ _ [] = return Outputable.empty
go n env ((is_landmark, ctxt) : ctxts)
| is_landmark || n < mAX_CONTEXTS
= do { (env', msg) <- ctxt env
; let n' = if is_landmark then n else n+1
; rest <- go n' env' ctxts
; return (msg $$ rest) }
| otherwise
= go n env ctxts
mAX_CONTEXTS :: Int
mAX_CONTEXTS = 3
debugTc :: TcM () -> TcM ()
debugTc thing
| debugIsOn = thing
| otherwise = return ()
newTcEvBinds :: TcM EvBindsVar
newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
; uniq <- newUnique
; return (EvBindsVar ref uniq) }
addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM ()
addTcEvBind (EvBindsVar ev_ref _) ev_id ev_tm
= do { traceTc "addTcEvBind" $ vcat [ text "ev_id =" <+> ppr ev_id
, text "ev_tm =" <+> ppr ev_tm ]
; bnds <- readTcRef ev_ref
; writeTcRef ev_ref (extendEvBinds bnds ev_id ev_tm) }
getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
getTcEvBinds (EvBindsVar ev_ref _)
= do { bnds <- readTcRef ev_ref
; return (evBindMapBinds bnds) }
chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc fn =
do { env <- getGblEnv
; let dfun_n_var = tcg_dfun_n env
; set <- readTcRef dfun_n_var
; let occ = fn set
; writeTcRef dfun_n_var (extendOccSet set occ)
; return occ }
getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
emitConstraints :: WantedConstraints -> TcM ()
emitConstraints ct
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`andWC` ct) }
emitSimple :: Ct -> TcM ()
emitSimple ct
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`addSimples` unitBag ct) }
emitSimples :: Cts -> TcM ()
emitSimples cts
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`addSimples` cts) }
emitImplication :: Implication -> TcM ()
emitImplication ct
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`addImplics` unitBag ct) }
emitImplications :: Bag Implication -> TcM ()
emitImplications ct
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`addImplics` ct) }
emitInsoluble :: Ct -> TcM ()
emitInsoluble ct
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`addInsols` unitBag ct) ;
v <- readTcRef lie_var ;
traceTc "emitInsoluble" (ppr v) }
captureConstraints :: TcM a -> TcM (a, WantedConstraints)
captureConstraints thing_inside
= do { lie_var <- newTcRef emptyWC ;
res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
thing_inside ;
lie <- readTcRef lie_var ;
return (res, lie) }
captureTcLevel :: TcM a -> TcM (a, TcLevel)
captureTcLevel thing_inside
= do { env <- getLclEnv
; let tclvl' = pushTcLevel (tcl_tclvl env)
; res <- setLclEnv (env { tcl_tclvl = tclvl' })
thing_inside
; return (res, tclvl') }
pushTcLevelM :: TcM a -> TcM a
pushTcLevelM thing_inside
= do { env <- getLclEnv
; let tclvl' = pushTcLevel (tcl_tclvl env)
; setLclEnv (env { tcl_tclvl = tclvl' })
thing_inside }
getTcLevel :: TcM TcLevel
getTcLevel = do { env <- getLclEnv
; return (tcl_tclvl env) }
setTcLevel :: TcLevel -> TcM a -> TcM a
setTcLevel tclvl thing_inside
= updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
isTouchableTcM :: TcTyVar -> TcM Bool
isTouchableTcM tv
= do { env <- getLclEnv
; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
setLclTypeEnv lcl_env thing_inside
= updLclEnv upd thing_inside
where
upd env = env { tcl_env = tcl_env lcl_env,
tcl_tyvars = tcl_tyvars lcl_env }
traceTcConstraints :: String -> TcM ()
traceTcConstraints msg
= do { lie_var <- getConstraintVar
; lie <- readTcRef lie_var
; traceTc (msg ++ ": LIE:") (ppr lie)
}
emitWildcardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
emitWildcardHoleConstraints wcs
= do { ctLoc <- getCtLoc HoleOrigin
; forM_ wcs $ \(name, tv) -> do {
; let real_span = case nameSrcSpan name of
RealSrcSpan span -> span
UnhelpfulSpan str -> pprPanic "emitWildcardHoleConstraints"
(ppr name <+> quotes (ftext str))
ctLoc' = setCtLocSpan ctLoc real_span
ty = mkTyVarTy tv
ev = mkLocalId name ty
can = CHoleCan { cc_ev = CtWanted ty ev ctLoc'
, cc_occ = occName name
, cc_hole = TypeHole }
; emitInsoluble can } }
recordThUse :: TcM ()
recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
recordThSpliceUse :: TcM ()
recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
keepAlive :: Name -> TcRn ()
keepAlive name
= do { env <- getGblEnv
; traceRn (ptext (sLit "keep alive") <+> ppr name)
; updTcRef (tcg_keep env) (`extendNameSet` name) }
getStage :: TcM ThStage
getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel name
= do { env <- getLclEnv;
; case lookupNameEnv (tcl_th_bndrs env) name of
Nothing -> return Nothing
Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
setStage :: ThStage -> TcM a -> TcRn a
setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
recordUnsafeInfer :: TcM ()
recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False
finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode dflags tcg_env = do
safeInf <- readIORef (tcg_safeInfer tcg_env)
return $ case safeHaskell dflags of
Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
| otherwise -> Sf_None
s -> s
getLocalRdrEnv :: RnM LocalRdrEnv
getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv rdr_env thing_inside
= updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
mkIfLclEnv :: Module -> SDoc -> IfLclEnv
mkIfLclEnv mod loc = IfLclEnv { if_mod = mod,
if_loc = loc,
if_tv_env = emptyUFM,
if_id_env = emptyUFM }
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside
= do { tcg_env <- getGblEnv
; let { if_env = IfGblEnv {
if_rec_types = Just (tcg_mod tcg_env, get_type_env)
}
; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
; setEnvs (if_env, ()) thing_inside }
initIfaceCheck :: HscEnv -> IfG a -> IO a
initIfaceCheck hsc_env do_this
= do let rec_types = case hsc_type_env_var hsc_env of
Just (mod,var) -> Just (mod, readTcRef var)
Nothing -> Nothing
gbl_env = IfGblEnv { if_rec_types = rec_types }
initTcRnIf 'i' hsc_env gbl_env () do_this
initIfaceTc :: ModIface
-> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
initIfaceTc iface do_this
= do { tc_env_var <- newTcRef emptyTypeEnv
; let { gbl_env = IfGblEnv {
if_rec_types = Just (mod, readTcRef tc_env_var)
} ;
; if_lenv = mkIfLclEnv mod doc
}
; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
}
where
mod = mi_module iface
doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
initIfaceLcl mod loc_doc thing_inside
= setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
getIfModule :: IfL Module
getIfModule = do { env <- getLclEnv; return (if_mod env) }
failIfM :: MsgDoc -> IfL a
failIfM msg
= do { env <- getLclEnv
; let full_msg = (if_loc env <> colon) $$ nest 2 msg
; dflags <- getDynFlags
; liftIO (log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) full_msg)
; failM }
forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
forkM_maybe doc thing_inside
= do { child_us <- newUniqueSupply
; child_env_us <- newMutVar child_us
; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
do { traceIf (text "Starting fork {" <+> doc)
; mb_res <- tryM $
updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
thing_inside
; case mb_res of
Right r -> do { traceIf (text "} ending fork" <+> doc)
; return (Just r) }
Left exn -> do {
whenDOptM Opt_D_dump_if_trace $ do
dflags <- getDynFlags
let msg = hang (text "forkM failed:" <+> doc)
2 (text (show exn))
liftIO $ log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
; traceIf (text "} ending fork (badly)" <+> doc)
; return Nothing }
}}
forkM :: SDoc -> IfL a -> IfL a
forkM doc thing_inside
= do { mb_res <- forkM_maybe doc thing_inside
; return (case mb_res of
Nothing -> pgmError "Cannot continue after interface file error"
Just r -> r) }