Commit 4a7a6c3a authored by Simon Peyton Jones's avatar Simon Peyton Jones

Rename getCtLoc, setCtLoc

getCtLoc -> getCtLocM
setCtLoc -> setCtLocM

These operations are monadic, and I want to introduce a
pure version of setCtLoc :: Ct -> CtLoc -> Ct
parent f4370c61
......@@ -70,7 +70,7 @@ import Data.Maybe( isJust )
newWanted :: CtOrigin -> PredType -> TcM CtEvidence
newWanted orig pty
= do loc <- getCtLoc orig
= do loc <- getCtLocM orig
v <- newEvVar pty
return $ CtWanted { ctev_evar = v
, ctev_pred = pty
......@@ -84,7 +84,7 @@ emitWanteds origin theta = mapM (emitWanted origin) theta
emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
emitWanted origin pred
= do { loc <- getCtLoc origin
= do { loc <- getCtLocM origin
; ev <- newEvVar pred
; emitSimple $ mkNonCanonical $
CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc }
......@@ -403,7 +403,7 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do
syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
-> TcRn (TidyEnv, SDoc)
syntaxNameCtxt name orig ty tidy_env
= do { inst_loc <- getCtLoc orig
= do { inst_loc <- getCtLocM orig
; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name)
<+> ptext (sLit "(needed by a syntactic construct)")
, nest 2 (ptext (sLit "has the required type:")
......
......@@ -1688,7 +1688,7 @@ warnDefaulting wanteds default_ty
warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type")
<+> quotes (ppr default_ty))
2 ppr_wanteds
; setCtLoc loc $ warnTc warn_default warn_msg }
; setCtLocM loc $ warnTc warn_default warn_msg }
{-
Note [Runtime skolems]
......@@ -1707,7 +1707,7 @@ are created by in RtClosureInspect.zonkRTTIType.
solverDepthErrorTcS :: CtLoc -> TcType -> TcM a
solverDepthErrorTcS loc ty
= setCtLoc loc $
= setCtLocM loc $
do { ty <- zonkTcType ty
; env0 <- tcInitTidyEnv
; let tidy_env = tidyFreeTyVars env0 (tyVarsOfType ty)
......
......@@ -131,7 +131,7 @@ tcHole occ res_ty
= do { ty <- newFlexiTyVarTy liftedTypeKind
; name <- newSysName occ
; let ev = mkLocalId name ty
; loc <- getCtLoc HoleOrigin
; loc <- getCtLocM HoleOrigin
; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ
, cc_hole = ExprHole }
; emitInsoluble can
......
......@@ -956,16 +956,16 @@ updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
popErrCtxt :: TcM a -> TcM a
popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
getCtLoc :: CtOrigin -> TcM CtLoc
getCtLoc origin
getCtLocM :: CtOrigin -> TcM CtLoc
getCtLocM origin
= do { env <- getLclEnv
; return (CtLoc { ctl_origin = origin
, ctl_env = env
, ctl_depth = initialSubGoalDepth }) }
setCtLoc :: CtLoc -> TcM a -> TcM a
setCtLocM :: CtLoc -> TcM a -> TcM a
-- Set the SrcSpan and error context from the CtLoc
setCtLoc (CtLoc { ctl_env = lcl }) thing_inside
setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
= updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
, tcl_bndrs = tcl_bndrs lcl
, tcl_ctxt = tcl_ctxt lcl })
......@@ -1241,7 +1241,7 @@ traceTcConstraints msg
emitWildcardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
emitWildcardHoleConstraints wcs
= do { ctLoc <- getCtLoc HoleOrigin
= do { ctLoc <- getCtLocM HoleOrigin
; forM_ wcs $ \(name, tv) -> do {
; let real_span = case nameSrcSpan name of
RealSrcSpan span -> span
......
......@@ -2468,7 +2468,7 @@ addUsedRdrNamesTcS names = wrapTcS $ addUsedRdrNames names
checkWellStagedDFun :: PredType -> DFunId -> CtLoc -> TcS ()
checkWellStagedDFun pred dfun_id loc
= wrapTcS $ TcM.setCtLoc loc $
= wrapTcS $ TcM.setCtLocM loc $
do { use_stage <- TcM.getStage
; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
where
......
......@@ -667,7 +667,7 @@ uType, uType_defer
-- See Note [Deferred unification]
uType_defer origin ty1 ty2
= do { eqv <- newEq ty1 ty2
; loc <- getCtLoc origin
; loc <- getCtLocM origin
; emitSimple $ mkNonCanonical $
CtWanted { ctev_evar = eqv
, ctev_pred = mkTcEqPred ty1 ty2
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment