\begin{code}
module TcMonad(
- TcType,
- TcTauType, TcPredType, TcThetaType, TcRhoType,
- TcTyVar, TcTyVarSet,
- TcKind,
+ TcType, TcTauType, TcPredType, TcThetaType, TcRhoType,
+ TcTyVar, TcTyVarSet, TcKind,
TcM, NF_TcM, TcDown, TcEnv,
tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
tcAddErrCtxtM, tcSetErrCtxtM,
- tcAddErrCtxt, tcSetErrCtxt,
+ tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
import {-# SOURCE #-} TcEnv ( TcEnv )
-import HsSyn ( HsOverLit )
+import HsLit ( HsOverLit )
import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
-import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
- )
+import TcType ( Type, Kind, PredType, ThetaType, TauType, RhoType )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
import Bag ( Bag, emptyBag, isEmptyBag,
failTc down env = give_up
give_up :: IO a
-give_up = IOERROR (userError "Typecheck failed")
+give_up = ioError (userError "Typecheck failed")
failWithTc :: Message -> TcM a -- Add an error message and fail
failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
m_errs_var <- newIORef (emptyBag,emptyBag)
catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
where
+ errs_var = getTcErrs down
+
my_recover m_errs_var
= do warns_and_errs <- readIORef m_errs_var
recover warns_and_errs down env
-- errors along the way.
(m_warns, m_errs) <- readIORef m_errs_var
if isEmptyBag m_errs then
- return result
+ -- No errors, so return normally, but don't lose the warnings
+ if isEmptyBag m_warns then
+ return result
+ else
+ do (warns, errs) <- readIORef errs_var
+ writeIORef errs_var (warns `unionBags` m_warns, errs)
+ return result
else
give_up -- This triggers the catch
-- Usual thing
tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
+
+tcPopErrCtxt :: Either_TcM r -> Either_TcM r
+tcPopErrCtxt m down env = m (popErrCtxt down) env
\end{code}
setErrCtxt down msg = down{tc_ctxt=[msg]}
addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
+popErrCtxt down = case tc_ctxt down of
+ [] -> down
+ m : ms -> down{tc_ctxt = ms}
+
doptsTc :: DynFlag -> TcM Bool
doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
= return (dopt dflag dflags)