X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=ce84178e10a9effbe677ab84dc46ce47d1511093;hp=65128baf4e7702aa6f3c966277a2ca8fd0ea9454;hb=0b4324456e472d15a3a124f56387486f71cb765d;hpb=94bf0d3604ff0d2ecab246924af712bdd1c29a40 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 65128ba..ce84178 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -22,6 +22,7 @@ import Name import TcType import InstEnv import FamInstEnv +import PrelNames ( iNTERACTIVE ) import Var import Id @@ -71,11 +72,10 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; meta_var <- newIORef initTyVarUnique ; tvs_var <- newIORef emptyVarSet ; - dfuns_var <- newIORef emptyNameSet ; - keep_var <- newIORef emptyNameSet ; + keep_var <- newIORef emptyNameSet ; used_rdr_var <- newIORef Set.empty ; th_var <- newIORef False ; - lie_var <- newIORef emptyBag ; + 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 ; @@ -97,8 +97,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_type_env_var = type_env_var, tcg_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, - tcg_inst_uses = dfuns_var, - tcg_th_used = th_var, + tcg_th_used = th_var, tcg_exports = [], tcg_imports = emptyImportAvails, tcg_used_rdrnames = used_rdr_var, @@ -115,11 +114,12 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_warns = NoWarnings, tcg_anns = [], tcg_insts = [], - tcg_fam_insts = [], - tcg_rules = [], - tcg_fords = [], - tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var, + tcg_fam_insts = [], + tcg_rules = [], + tcg_fords = [], + tcg_vects = [], + tcg_dfun_n = dfun_n_var, + tcg_keep = keep_var, tcg_doc_hdr = Nothing, tcg_hpc = False, tcg_main = Nothing @@ -148,7 +148,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this -- Check for unsolved constraints lie <- readIORef lie_var ; - if isEmptyBag lie + if isEmptyWC lie then return () else pprPanic "initTc: unsolved constraints" (pprWantedsWithLocs lie) ; @@ -406,7 +406,6 @@ traceRn, traceSplice :: SDoc -> TcRn () traceRn = traceOptTcRn Opt_D_dump_rn_trace traceSplice = traceOptTcRn Opt_D_dump_splices - traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () traceIf = traceOptIf Opt_D_dump_if_trace traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs @@ -453,6 +452,9 @@ getModule = do { env <- getGblEnv; return (tcg_mod env) } 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 (mod == iNTERACTIVE) } + tcIsHsBoot :: TcRn Bool tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } @@ -492,9 +494,10 @@ getSrcSpanM :: TcRn SrcSpan getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) } setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -setSrcSpan loc thing_inside - | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside - | otherwise = thing_inside -- Don't overwrite useful info with useless +setSrcSpan loc@(RealSrcSpan _) thing_inside + = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside +-- Don't overwrite useful info with useless: +setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside addLocM :: (a -> TcM b) -> Located a -> TcM b addLocM fn (L loc a) = setSrcSpan loc $ fn a @@ -610,6 +613,14 @@ addLongErrAt loc msg extra let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; (warns, errs) <- readTcRef errs_var ; writeTcRef errs_var (warns, errs `snocBag` err) } + +dumpDerivingInfo :: SDoc -> TcM () +dumpDerivingInfo doc + = do { dflags <- getDOpts + ; when (dopt Opt_D_dump_deriv dflags) $ do + { rdr_env <- getGlobalRdrEnv + ; let unqual = mkPrintUnqualified dflags rdr_env + ; liftIO (putMsgWith dflags unqual doc) } } \end{code} @@ -770,11 +781,6 @@ updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> env { tcl_ctxt = upd ctxt }) --- Conditionally add an error context -maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a -maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside -maybeAddErrCtxt Nothing thing_inside = thing_inside - popErrCtxt :: TcM a -> TcM a popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) @@ -886,6 +892,9 @@ add_err_tcm tidy_env err_msg loc ctxt mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts mkErrInfo env ctxts + | opt_PprStyle_Debug -- In -dppr-debug style the output + = return empty -- just becomes too voluminous + | otherwise = go 0 env ctxts where go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc @@ -955,21 +964,36 @@ setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) emitConstraints :: WantedConstraints -> TcM () emitConstraints ct = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`andWanteds` ct) } + updTcRef lie_var (`andWC` ct) } + +emitFlat :: WantedEvVar -> TcM () +emitFlat ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addFlats` unitBag ct) } -emitConstraint :: WantedConstraint -> TcM () -emitConstraint ct +emitFlats :: Bag WantedEvVar -> TcM () +emitFlats ct = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`extendWanteds` ct) } + updTcRef lie_var (`addFlats` ct) } + +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) } captureConstraints :: TcM a -> TcM (a, WantedConstraints) -- (captureConstraints m) runs m, and returns the type constraints it generates captureConstraints thing_inside - = do { lie_var <- newTcRef emptyWanteds ; - res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) - thing_inside ; - lie <- readTcRef lie_var ; - return (res, lie) } + = do { lie_var <- newTcRef emptyWC ; + res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) + thing_inside ; + lie <- readTcRef lie_var ; + return (res, lie) } captureUntouchables :: TcM a -> TcM (a, Untouchables) captureUntouchables thing_inside @@ -994,14 +1018,21 @@ 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 } + tcl_tyvars = tcl_tyvars lcl_env } + +traceTcConstraints :: String -> TcM () +traceTcConstraints msg + = do { lie_var <- getConstraintVar + ; lie <- readTcRef lie_var + ; traceTc (msg ++ "LIE:") (ppr lie) + } \end{code} %************************************************************************ -%* * - Template Haskell context -%* * +%* * + Template Haskell context +%* * %************************************************************************ \begin{code} @@ -1126,7 +1157,7 @@ failIfM :: Message -> IfL a failIfM msg = do { env <- getLclEnv ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; liftIO (printErrs (full_msg defaultErrStyle)) + ; liftIO (printErrs full_msg defaultErrStyle) ; failM } -------------------- @@ -1161,7 +1192,7 @@ forkM_maybe doc thing_inside ; return Nothing } }} where - print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle)) + print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle) forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside