+getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
+getErrsTc down env
+ = readIORef (getTcErrs down)
+
+failTc :: TcM a
+failTc down env = give_up
+
+give_up :: IO a
+give_up = ioError (userError "Typecheck failed")
+
+failWithTc :: Message -> TcM a -- Add an error message and fail
+failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
+
+addErrTc :: Message -> NF_TcM ()
+addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
+
+addErrsTc :: [Message] -> NF_TcM ()
+addErrsTc [] = returnNF_Tc ()
+addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
+
+-- The 'M' variants do the TidyEnv bit
+failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
+failWithTcM env_and_msg
+ = addErrTcM env_and_msg `thenNF_Tc_`
+ failTc
+
+checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
+checkTc True err = returnTc ()
+checkTc False err = failWithTc err
+
+checkTcM :: Bool -> TcM () -> TcM () -- Check that the boolean is true
+checkTcM True err = returnTc ()
+checkTcM False err = err
+
+checkMaybeTc :: Maybe val -> Message -> TcM val
+checkMaybeTc (Just val) err = returnTc val
+checkMaybeTc Nothing err = failWithTc err
+
+checkMaybeTcM :: Maybe val -> TcM val -> TcM val
+checkMaybeTcM (Just val) err = returnTc val
+checkMaybeTcM Nothing err = err
+
+addErrTcM :: (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
+addErrTcM (tidy_env, err_msg) down env
+ = add_err_tcm tidy_env err_msg ctxt loc down env
+ where
+ ctxt = getErrCtxt down
+ loc = getLoc down
+
+addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
+addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
+ = add_err_tcm tidy_env err_msg full_ctxt loc down env
+ where
+ full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
+
+add_err_tcm tidy_env err_msg ctxt loc down env
+ = do
+ (warns, errs) <- readIORef errs_var
+ ctxt_msgs <- do_ctxt tidy_env ctxt down env
+ let err = addShortErrLocLine loc $
+ vcat (err_msg : ctxt_to_use ctxt_msgs)
+ writeIORef errs_var (warns, errs `snocBag` err)
+ where
+ errs_var = getTcErrs down
+
+do_ctxt tidy_env [] down env
+ = return []
+do_ctxt tidy_env (c:cs) down env
+ = do
+ (tidy_env', m) <- c tidy_env down env
+ ms <- do_ctxt tidy_env' cs down env
+ return (m:ms)
+
+-- warnings don't have an 'M' variant
+warnTc :: Bool -> Message -> NF_TcM ()
+warnTc warn_if_true warn_msg down env
+ | warn_if_true
+ = do
+ (warns,errs) <- readIORef errs_var
+ ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
+ let warn = addShortWarnLocLine loc $
+ vcat (warn_msg : ctxt_to_use ctxt_msgs)
+ writeIORef errs_var (warns `snocBag` warn, errs)
+ | otherwise
+ = return ()