X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=2ad5b2fefb016b4b755256a06d119395ad107eb9;hb=ee2571bd2a80683d33cf65a01942bc8be50a5e33;hp=8632895b10893c194b036a2ab034c8f7490d6d0c;hpb=2f223e8f4a4e2fb22a8bb0638cd48256e9f2f0e2;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 8632895..2ad5b2f 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -17,8 +17,6 @@ module TcSimplify ( tcSimplifyDeriv, tcSimplifyDefault, bindInstsOfLocalFuns, - tcSimplifyStagedExpr, - misMatchMsg ) where @@ -3057,25 +3055,6 @@ tcSimplifyDefault theta = do doc = ptext (sLit "default declaration") \end{code} -@tcSimplifyStagedExpr@ performs a simplification but does so at a new -stage. This is used when typechecking annotations and splices. - -\begin{code} - -tcSimplifyStagedExpr :: ThStage -> TcM a -> TcM (a, TcDictBinds) --- Type check an expression that runs at a top level stage as if --- it were going to be spliced and then simplify it -tcSimplifyStagedExpr stage tc_action - = setStage stage $ do { - -- Typecheck the expression - (thing', lie) <- getLIE tc_action - - -- Solve the constraints - ; const_binds <- tcSimplifyTop lie - - ; return (thing', const_binds) } - -\end{code} %************************************************************************ @@ -3107,7 +3086,7 @@ groupErrs report_err (inst:insts) (friends, others) = partition is_friend insts loc_msg = showSDoc (pprInstLoc (instLoc inst)) is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg - do_one insts = addInstCtxt (instLoc (head insts)) (report_err insts) + do_one insts = setInstCtxt (instLoc (head insts)) (report_err insts) -- Add location and context information derived from the Insts -- Add the "arising from..." part to a message about bunch of dicts @@ -3316,7 +3295,7 @@ monomorphism_fix dflags warnDefault :: [(Inst, Class, Var)] -> Type -> TcM () warnDefault ups default_ty = do warn_flag <- doptM Opt_WarnTypeDefaults - addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg) + setInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg) where dicts = [d | (d,_,_) <- ups]