Fix header locations
[ghc.git] / compiler / typecheck / TcRnMonad.hs
index 8c117f0..e0989ae 100644 (file)
@@ -10,7 +10,7 @@ Functions for working with the typechecker environment (setters, getters...).
 
 module TcRnMonad(
   -- * Initalisation
-  initTc, initTcInteractive, initTcForLookup, initTcRnIf,
+  initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
 
   -- * Simple accessors
   discardResult,
@@ -19,7 +19,8 @@ module TcRnMonad(
   getEnvs, setEnvs,
   xoptM, doptM, goptM, woptM,
   setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
-  whenDOptM, whenGOptM, whenWOptM, whenXOptM,
+  whenDOptM, whenGOptM, whenWOptM,
+  whenXOptM, unlessXOptM,
   getGhcMode,
   withDoDynamicToo,
   getEpsVar,
@@ -67,8 +68,7 @@ module TcRnMonad(
   mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
   reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
   tryTc,
-  askNoErrs, discardErrs,
-  tryTcErrs, tryTcLIE_,
+  askNoErrs, discardErrs, tryTcDiscardingErrs,
   checkNoErrs, whenNoErrs,
   ifErrsM, failIfErrsM,
   checkTH, failTH,
@@ -79,25 +79,25 @@ module TcRnMonad(
 
   -- * Error message generation (type checker)
   addErrTc, addErrsTc,
-  addErrTcM, mkErrTcM,
+  addErrTcM, mkErrTcM, mkErrTc,
   failWithTc, failWithTcM,
   checkTc, checkTcM,
   failIfTc, failIfTcM,
-  warnIf, warnTc, warnTcM,
+  warnIfFlag, warnIf, warnTc, warnTcM,
   addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
-  tcInitTidyEnv, tcInitOpenTidyEnv, mkErrInfo,
+  mkErrInfo,
 
   -- * Type constraints
-  newTcEvBinds,
-  addTcEvBind,
-  getTcEvTyCoVars, getTcEvBindsMap,
+  newTcEvBinds, newNoTcEvBinds,
+  addTcEvBind, addTopEvBinds,
+  getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
   chooseUniqueOccTc,
   getConstraintVar, setConstraintVar,
-  emitConstraints, emitSimple, emitSimples,
+  emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
   emitImplication, emitImplications, emitInsoluble,
-  discardConstraints, captureConstraints, captureTopConstraints,
+  discardConstraints, captureConstraints, tryCaptureConstraints,
   pushLevelAndCaptureConstraints,
-  pushTcLevelM_, pushTcLevelM,
+  pushTcLevelM_, pushTcLevelM, pushTcLevelsM,
   getTcLevel, setTcLevel, isTouchableTcM,
   getLclTypeEnv, setLclTypeEnv,
   traceTcConstraints, emitWildCardHoleConstraints,
@@ -124,9 +124,13 @@ module TcRnMonad(
   failIfM,
   forkM_maybe,
   forkM,
+  setImplicitEnvM,
 
   withException,
 
+  -- * Stuff for cost centres.
+  ContainsCostCentreState(..), getCCIndexM,
+
   -- * Types etc.
   module TcRnTypes,
   module IOEnv
@@ -134,6 +138,8 @@ module TcRnMonad(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcRnTypes        -- Re-export all
 import IOEnv            -- Re-export all
 import TcEvidence
@@ -161,23 +167,24 @@ import Bag
 import Outputable
 import UniqSupply
 import DynFlags
-import StaticFlags
 import FastString
 import Panic
 import Util
 import Annotations
 import BasicTypes( TopLevelFlag )
 import Maybes
+import CostCentreState
 
 import qualified GHC.LanguageExtensions as LangExt
 
-import Control.Exception
 import Data.IORef
 import Control.Monad
 import Data.Set ( Set )
 import qualified Data.Set as Set
 
 import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers )
+import {-# SOURCE #-} TcEnv    ( tcInitTidyEnv )
+
 import qualified Data.Map as Map
 
 {-
@@ -200,15 +207,12 @@ initTc :: HscEnv
                 -- (error messages should have been printed already)
 
 initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
- = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
-        tvs_var      <- newIORef emptyVarSet ;
-        keep_var     <- newIORef emptyNameSet ;
+ = do { keep_var     <- newIORef emptyNameSet ;
         used_gre_var <- newIORef [] ;
         th_var       <- newIORef False ;
         th_splice_var<- newIORef False ;
         th_locs_var  <- newIORef Set.empty ;
         infer_var    <- newIORef (True, 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 ;
@@ -216,9 +220,12 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
 
         dependent_files_var <- newIORef [] ;
         static_wc_var       <- newIORef emptyWC ;
+        cc_st_var           <- newIORef newCostCentreState ;
         th_topdecls_var      <- newIORef [] ;
+        th_foreign_files_var <- newIORef [] ;
         th_topnames_var      <- newIORef emptyNameSet ;
         th_modfinalizers_var <- newIORef [] ;
+        th_coreplugins_var <- newIORef [] ;
         th_state_var         <- newIORef Map.empty ;
         th_remote_state_var  <- newIORef Nothing ;
         let {
@@ -226,21 +233,28 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
 
              maybe_rn_syntax :: forall a. a -> Maybe a ;
              maybe_rn_syntax empty_val
-                | keep_rn_syntax = Just empty_val
-                | otherwise      = Nothing ;
+                | dopt Opt_D_dump_rn_ast dflags = Just empty_val
+
+                  -- We want to serialize the documentation in the .hi-files,
+                  -- and need to extract it from the renamed syntax first.
+                  -- See 'ExtractDocs.extractDocs'.
+                | gopt Opt_Haddock dflags       = Just empty_val
+
+                | keep_rn_syntax                = Just empty_val
+                | otherwise                     = Nothing ;
 
              gbl_env = TcGblEnv {
                 tcg_th_topdecls      = th_topdecls_var,
+                tcg_th_foreign_files = th_foreign_files_var,
                 tcg_th_topnames      = th_topnames_var,
                 tcg_th_modfinalizers = th_modfinalizers_var,
+                tcg_th_coreplugins = th_coreplugins_var,
                 tcg_th_state         = th_state_var,
                 tcg_th_remote_state  = th_remote_state_var,
 
                 tcg_mod            = mod,
                 tcg_semantic_mod   =
-                    if thisPackage dflags == moduleUnitId mod
-                        then canonicalizeHomeModule dflags (moduleName mod)
-                        else mod,
+                    canonicalizeModuleIfHome dflags mod,
                 tcg_src            = hsc_src,
                 tcg_rdr_env        = emptyGlobalRdrEnv,
                 tcg_fix_env        = emptyNameEnv,
@@ -252,7 +266,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_type_env_var   = type_env_var,
                 tcg_inst_env       = emptyInstEnv,
                 tcg_fam_inst_env   = emptyFamInstEnv,
-                tcg_pending_fam_checks = emptyNameEnv,
                 tcg_ann_env        = emptyAnnEnv,
                 tcg_th_used        = th_var,
                 tcg_th_splice_used = th_splice_var,
@@ -283,7 +296,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_fam_insts      = [],
                 tcg_rules          = [],
                 tcg_fords          = [],
-                tcg_vects          = [],
                 tcg_patsyns        = [],
                 tcg_merged         = [],
                 tcg_dfun_n         = dfun_n_var,
@@ -296,9 +308,27 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_dependent_files = dependent_files_var,
                 tcg_tc_plugins     = [],
                 tcg_top_loc        = loc,
-                tcg_static_wc      = static_wc_var
+                tcg_static_wc      = static_wc_var,
+                tcg_complete_matches = [],
+                tcg_cc_st          = cc_st_var
              } ;
-             lcl_env = TcLclEnv {
+        } ;
+
+        -- OK, here's the business end!
+        initTcWithGbl hsc_env gbl_env loc do_this
+    }
+
+-- | Run a 'TcM' action in the context of an existing 'GblEnv'.
+initTcWithGbl :: HscEnv
+              -> TcGblEnv
+              -> RealSrcSpan
+              -> TcM r
+              -> IO (Messages, Maybe r)
+initTcWithGbl hsc_env gbl_env loc do_this
+ = do { tvs_var      <- newIORef emptyVarSet
+      ; lie_var      <- newIORef emptyWC
+      ; errs_var     <- newIORef (emptyBag, emptyBag)
+      ; let lcl_env = TcLclEnv {
                 tcl_errs       = errs_var,
                 tcl_loc        = loc,     -- Should be over-ridden very soon!
                 tcl_ctxt       = [],
@@ -308,35 +338,35 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcl_arrow_ctxt = NoArrowCtxt,
                 tcl_env        = emptyNameEnv,
                 tcl_bndrs      = [],
-                tcl_tidy       = emptyTidyEnv,
                 tcl_tyvars     = tvs_var,
                 tcl_lie        = lie_var,
                 tcl_tclvl      = topTcLevel
-             } ;
-        } ;
+                }
 
-        -- OK, here's the business end!
-        maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
+      ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
                      do { r <- tryM do_this
                         ; case r of
                           Right res -> return (Just res)
-                          Left _    -> return Nothing } ;
+                          Left _    -> return Nothing }
 
-        -- Check for unsolved constraints
-        lie <- readIORef lie_var ;
-        if isEmptyWC lie
-           then return ()
-           else pprPanic "initTc: unsolved constraints" (ppr lie) ;
+      -- Check for unsolved constraints
+      -- If we succeed (maybe_res = Just r), there should be
+      -- no unsolved constraints.  But if we exit via an
+      -- exception (maybe_res = Nothing), we may have skipped
+      -- solving, so don't panic then (Trac #13466)
+      ; lie <- readIORef (tcl_lie lcl_env)
+      ; when (isJust maybe_res && not (isEmptyWC lie)) $
+        pprPanic "initTc: unsolved constraints" (ppr lie)
 
         -- Collect any error messages
-        msgs <- readIORef errs_var ;
+      ; msgs <- readIORef (tcl_errs lcl_env)
 
-        let { final_res | errorsFound dflags msgs = Nothing
-                        | otherwise               = maybe_res } ;
-
-        return (msgs, final_res)
-    }
+      ; let { final_res | errorsFound dflags msgs = Nothing
+                        | otherwise               = maybe_res }
 
+      ; return (msgs, final_res)
+      }
+  where dflags = hsc_dflags hsc_env
 
 initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
 -- Initialise the type checker monad for use in GHCi
@@ -348,15 +378,6 @@ initTcInteractive hsc_env thing_inside
   where
     interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
 
-initTcForLookup :: HscEnv -> TcM a -> IO a
--- The thing_inside is just going to look up something
--- in the environment, so we don't need much setup
-initTcForLookup hsc_env thing_inside
-  = do { (msgs, m) <- initTcInteractive hsc_env thing_inside
-       ; case m of
-             Nothing -> throwIO $ mkSrcErr $ snd msgs
-             Just x -> return x }
-
 {- Note [Default types]
 ~~~~~~~~~~~~~~~~~~~~~~~
 The Integer type is simply not available in package ghc-prim (it is
@@ -483,6 +504,10 @@ whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 whenXOptM flag thing_inside = do b <- xoptM flag
                                  when b thing_inside
 
+unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+unlessXOptM flag thing_inside = do b <- xoptM flag
+                                   unless b thing_inside
+
 getGhcMode :: TcRnIf gbl lcl GhcMode
 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
 
@@ -695,14 +720,14 @@ traceTcRn :: DumpFlag -> SDoc -> TcRn ()
 -- for --dump-to-file, not to decide whether or not to output
 -- That part is done by the caller
 traceTcRn flag doc
-  = do { real_doc <- prettyDoc doc
-       ; dflags   <- getDynFlags
+  = do { dflags   <- getDynFlags
+       ; real_doc <- prettyDoc dflags doc
        ; printer  <- getPrintUnqualified dflags
        ; liftIO $ dumpSDoc dflags printer flag "" real_doc  }
   where
-    -- Add current location if opt_PprStyle_Debug
-    prettyDoc :: SDoc -> TcRn SDoc
-    prettyDoc doc = if opt_PprStyle_Debug
+    -- Add current location if -dppr-debug
+    prettyDoc :: DynFlags -> SDoc -> TcRn SDoc
+    prettyDoc dflags doc = if hasPprDebug dflags
        then do { loc  <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
        else return doc -- The full location is usually way too much
 
@@ -929,20 +954,21 @@ reportWarning reason err
 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
 -- Does tryM, with a debug-trace on failure
 try_m thing
-  = do { mb_r <- tryM (captureConstraints thing)
+  = do { (mb_r, lie) <- tryCaptureConstraints thing
+       ; emitConstraints lie
 
-            -- See Note [Constraints and errors] for the
-            -- captureConstraints/emitContraints dance
+       -- Debug trace
        ; case mb_r of
-           Left exn -> do { traceTc "tryTc/recoverM recovering from" $
-                            text (showException exn)
-                          ; return (Left exn) }
-           Right (res, lie) -> do { emitConstraints lie
-                                  ; return (Right res) } }
+            Left exn -> traceTc "tryTc/recoverM recovering from" $
+                        text (showException exn)
+            Right {} -> return ()
+
+       ; return mb_r }
 
 -----------------------
 recoverM :: TcRn r      -- Recovery action; do this if the main one fails
-         -> TcRn r      -- Main action: do this first
+         -> TcRn r      -- Main action: do this first;
+                        --  if it generates errors, propagate them all
          -> TcRn r
 -- Errors in 'thing' are retained
 recoverM recover thing
@@ -980,30 +1006,25 @@ tryTc :: TcRn a -> TcRn (Messages, Maybe a)
 --      Nothing, if m fails
 -- It also returns all the errors and warnings accumulated by m
 -- It always succeeds (never raises an exception)
-tryTc m
+tryTc thing_inside
  = do { errs_var <- newTcRef emptyMessages ;
-        res  <- try_m (setErrsVar errs_var m) ;
+
+        res  <- try_m $  -- Be sure to catch exceptions, so that
+                         -- we guaranteed to read the messages out
+                         -- of that brand-new errs_var!
+                setErrsVar errs_var $
+                thing_inside ;
+
         msgs <- readTcRef errs_var ;
+
         return (msgs, case res of
-                            Left _  -> Nothing
-                            Right val -> Just val)
+                        Left _    -> Nothing
+                        Right val -> Just val)
         -- The exception is always the IOEnv built-in
         -- in exception; see IOEnv.failM
    }
 
--- (askNoErrs m) runs m
--- If m fails, (askNoErrs m) fails
--- If m succeeds with result r, (askNoErrs m) succeeds with result (r, b),
---  where b is True iff m generated no errors
--- Regardless of success or failure, any errors generated by m are propagated
-askNoErrs :: TcRn a -> TcRn (a, Bool)
-askNoErrs m
- = do { errs_var <- newTcRef emptyMessages
-      ; res  <- setErrsVar errs_var m
-      ; (warns, errs) <- readTcRef errs_var
-      ; addMessages (warns, errs)
-      ; return (res, isEmptyBag errs) }
-
+-----------------------
 discardErrs :: TcRn a -> TcRn a
 -- (discardErrs m) runs m,
 --   discarding all error messages and warnings generated by m
@@ -1013,36 +1034,43 @@ discardErrs m
       ; setErrsVar errs_var m }
 
 -----------------------
-tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
--- Run the thing, returning
---      Just r,  if m succceeds with no error messages
---      Nothing, if m fails, or if it succeeds but has error messages
--- Either way, the messages are returned;
--- even in the Just case there might be warnings
-tryTcErrs thing
-  = do  { (msgs, res) <- tryTc thing
+tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
+-- (tryTcDiscardingErrs recover main) tries 'main';
+--      if 'main' succeeds with no error messages, it's the answer
+--      otherwise discard everything from 'main', including errors,
+--          and try 'recover' instead.
+tryTcDiscardingErrs recover main
+  = do  { (msgs, mb_res) <- tryTc main
         ; dflags <- getDynFlags
-        ; let errs_found = errorsFound dflags msgs
-        ; return (msgs, case res of
-                          Nothing -> Nothing
-                          Just val | errs_found -> Nothing
-                                   | otherwise  -> Just val)
-        }
-
------------------------
-tryTcLIE_ :: TcM r -> TcM r -> TcM r
--- (tryTcLIE_ r m) tries m;
---      if m succeeds with no error messages, it's the answer
---      otherwise tryTcLIE_ drops everything from m and tries r instead.
-tryTcLIE_ recover main
-  = do  { (msgs, mb_res) <- tryTcErrs main
         ; case mb_res of
-             Just val -> do { addMessages msgs  -- There might be warnings
-                            ; return val }
-             Nothing  -> recover                -- Discard all msgs
+            Just res | not (errorsFound dflags msgs)
+              -> -- 'main' succeeed with no error messages
+                 do { addMessages msgs  -- msgs might still have warnings
+                    ; return res }
+
+            _ -> -- 'main' failed, or produced an error message
+                 recover     -- Discard all errors and warnings entirely
         }
 
 -----------------------
+-- (askNoErrs m) runs m
+-- If m fails,
+--    then (askNoErrs m) fails
+-- If m succeeds with result r,
+--    then (askNoErrs m) succeeds with result (r, b),
+--         where b is True iff m generated no errors
+-- Regardless of success or failure,
+--   propagate any errors/warnings generated by m
+askNoErrs :: TcRn a -> TcRn (a, Bool)
+askNoErrs m
+  = do { (msgs, mb_res) <- tryTc m
+       ; addMessages msgs  -- Always propagate errors
+       ; case mb_res of
+           Nothing  -> failM
+           Just res -> do { dflags <- getDynFlags
+                          ; let errs_found = errorsFound dflags msgs
+                          ; return (res, not errs_found) } }
+-----------------------
 checkNoErrs :: TcM r -> TcM r
 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
 -- If m fails then (checkNoErrsTc m) fails.
@@ -1051,13 +1079,11 @@ checkNoErrs :: TcM r -> TcM r
 --      If so, it fails too.
 -- Regardless, any errors generated by m are propagated to the enclosing context.
 checkNoErrs main
-  = do  { (msgs, mb_res) <- tryTcErrs main
-        ; addMessages msgs
-        ; case mb_res of
-            Nothing  -> failM
-            Just val -> return val
-        }
+  = do  { (res, no_errs) <- askNoErrs main
+        ; unless no_errs failM
+        ; return res }
 
+-----------------------
 whenNoErrs :: TcM () -> TcM ()
 whenNoErrs thing = ifErrsM (return ()) thing
 
@@ -1088,43 +1114,8 @@ failTH e what  -- Raise an error in a stage-1 compiler
                           2 (ppr e)
                      , text "Perhaps you are using a stage-1 compiler?" ])
 
-{- Note [Constraints and errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this (Trac #12124):
-
-  foo :: Maybe Int
-  foo = return (case Left 3 of
-                  Left -> 1  -- Error here!
-                  _    -> 0)
-
-The call to 'return' will generate a (Monad m) wanted constraint; but
-then there'll be "hard error" (i.e. an exception in the TcM monad).
-We'll recover in tcPolyBinds, using recoverM.  But then the final
-tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
-un-filled-in, and will emit a misleading error message.
-
-The underlying problem is that an exception interrupts the constraint
-gathering process. Bottom line: if we have an exception, it's best
-simply to discard any gathered constraints.  Hence in 'try_m' we
-capture the constraints in a fresh variable, and only emit them into
-the surrounding context if we exit normally.  If an exception is
-raised, simply discard the collected constraints... we have a hard
-error to report.  So this capture-the-emit dance isn't as stupid as it
-looks :-).
-
-However suppose we throw an exception inside an invocation of
-captureConstraints.  Then we'll discard all the constraints. But some
-of those contraints might be "variable out of scope" Hole constraints,
-and that might have been the actual original cause of the exception!
-For example (Trac #12529):
-   f = p @ Int
-Here 'p' is out of scope, so we get an insolube Hole constraint. But
-the visible type application fails in the monad (thows an exception).
-We must not discard the out-of-scope error.  Hence the use of tryM in
-captureConstraints to propagate insoluble constraints.
 
-
-************************************************************************
+{- *********************************************************************
 *                                                                      *
         Context management for the type checker
 *                                                                      *
@@ -1215,6 +1206,10 @@ mkErrTcM (tidy_env, err_msg)
          err_info <- mkErrInfo tidy_env ctxt ;
          mkLongErrAt loc err_msg err_info }
 
+mkErrTc :: MsgDoc -> TcM ErrMsg
+mkErrTc msg = do { env0 <- tcInitTidyEnv
+                 ; mkErrTcM (env0, msg) }
+
 -- The failWith functions add an error message and cause failure
 
 failWithTc :: MsgDoc -> TcM a               -- Add an error message and fail
@@ -1245,15 +1240,18 @@ failIfTcM True  err = failWithTcM err
 
 --         Warnings have no 'M' variant, nor failure
 
--- | Display a warning if a condition is met.
+-- | Display a warning if a condition is met,
 --   and the warning is enabled
-warnIf :: WarnReason -> Bool -> MsgDoc -> TcRn ()
-warnIf reason is_bad msg
-  = do { warn_on <- case reason of
-                       NoReason         -> return True
-                       Reason warn_flag -> woptM warn_flag
+warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()
+warnIfFlag warn_flag is_bad msg
+  = do { warn_on <- woptM warn_flag
        ; when (warn_on && is_bad) $
-         addWarn reason msg }
+         addWarn (Reason warn_flag) msg }
+
+-- | Display a warning if a condition is met.
+warnIf :: Bool -> MsgDoc -> TcRn ()
+warnIf is_bad msg
+  = when is_bad (addWarn NoReason msg)
 
 -- | Display a warning if a condition is met.
 warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
@@ -1304,19 +1302,6 @@ add_warn_at reason loc msg extra_info
                                     msg extra_info } ;
          reportWarning reason warn }
 
-tcInitTidyEnv :: TcM TidyEnv
-tcInitTidyEnv
-  = do  { lcl_env <- getLclEnv
-        ; return (tcl_tidy lcl_env) }
-
--- | Get a 'TidyEnv' that includes mappings for all vars free in the given
--- type. Useful when tidying open types.
-tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
-tcInitOpenTidyEnv tvs
-  = do { env1 <- tcInitTidyEnv
-       ; let env2 = tidyFreeTyCoVars env1 tvs
-       ; return env2 }
-
 
 {-
 -----------------------------------
@@ -1333,21 +1318,23 @@ 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
+--  = do
+--       dbg <- hasPprDebug <$> getDynFlags
+--       if dbg                -- In -dppr-debug style the output
+--          then return empty  -- just becomes too voluminous
+--          else go dbg 0 env ctxts
+ = go False 0 env ctxts
  where
-   go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
-   go _ _   [] = return empty
-   go n env ((is_landmark, ctxt) : ctxts)
-     | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
+   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
+   go _ _   [] = return empty
+   go dbg n env ((is_landmark, ctxt) : ctxts)
+     | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
      = do { (env', msg) <- ctxt env
           ; let n' = if is_landmark then n else n+1
-          ; rest <- go n' env' ctxts
+          ; rest <- go dbg n' env' ctxts
           ; return (msg $$ rest) }
      | otherwise
-     = go n env ctxts
+     = go dbg n env ctxts
 
 mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts
 mAX_CONTEXTS = 3
@@ -1367,6 +1354,13 @@ debugTc thing
 ************************************************************************
 -}
 
+addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
+addTopEvBinds new_ev_binds thing_inside
+  =updGblEnv upd_env thing_inside
+  where
+    upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env
+                                               `unionBags` new_ev_binds }
+
 newTcEvBinds :: TcM EvBindsVar
 newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
                   ; tcvs_ref  <- newTcRef emptyVarSet
@@ -1376,13 +1370,35 @@ newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
                                        , ebv_tcvs = tcvs_ref
                                        , ebv_uniq = uniq }) }
 
+-- | Creates an EvBindsVar incapable of holding any bindings. It still
+-- tracks covar usages (see comments on ebv_tcvs in TcEvidence), thus
+-- must be made monadically
+newNoTcEvBinds :: TcM EvBindsVar
+newNoTcEvBinds
+  = do { tcvs_ref  <- newTcRef emptyVarSet
+       ; uniq <- newUnique
+       ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
+       ; return (NoEvBindsVar { ebv_tcvs = tcvs_ref
+                              , ebv_uniq = uniq }) }
+
 getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
-getTcEvTyCoVars (EvBindsVar { ebv_tcvs = ev_ref })
-  = readTcRef ev_ref
+getTcEvTyCoVars ev_binds_var
+  = readTcRef (ebv_tcvs ev_binds_var)
 
 getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
 getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
   = readTcRef ev_ref
+getTcEvBindsMap (NoEvBindsVar {})
+  = return emptyEvBindMap
+
+setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
+setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds
+  = writeTcRef ev_ref binds
+setTcEvBindsMap v@(NoEvBindsVar {}) ev_binds
+  | isEmptyEvBindMap ev_binds
+  = return ()
+  | otherwise
+  = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)
 
 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
 -- Add a binding to the TcEvBinds by side effect
@@ -1391,6 +1407,8 @@ addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
                                  ppr ev_bind
        ; bnds <- readTcRef ev_ref
        ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
+addTcEvBind (NoEvBindsVar { ebv_uniq = u }) ev_bind
+  = pprPanic "addTcEvBind NoEvBindsVar" (ppr ev_bind $$ ppr u)
 
 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
 chooseUniqueOccTc fn =
@@ -1407,8 +1425,16 @@ getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
 
+emitStaticConstraints :: WantedConstraints -> TcM ()
+emitStaticConstraints static_lie
+  = do { gbl_env <- getGblEnv
+       ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
+
 emitConstraints :: WantedConstraints -> TcM ()
 emitConstraints ct
+  | isEmptyWC ct
+  = return ()
+  | otherwise
   = do { lie_var <- getConstraintVar ;
          updTcRef lie_var (`andWC` ct) }
 
@@ -1450,35 +1476,39 @@ emitInsolubles cts
 discardConstraints :: TcM a -> TcM a
 discardConstraints thing_inside = fst <$> captureConstraints thing_inside
 
-captureConstraints :: TcM a -> TcM (a, WantedConstraints)
--- (captureConstraints m) runs m, and returns the type constraints it generates
-captureConstraints thing_inside
+tryCaptureConstraints :: TcM a -> TcM (Either IOEnvFailure a, WantedConstraints)
+-- (captureConstraints_maybe m) runs m,
+-- and returns the type constraints it generates
+-- It never throws an exception; instead if thing_inside fails,
+--   it returns Left exn and the insoluble constraints
+tryCaptureConstraints thing_inside
   = do { lie_var <- newTcRef emptyWC
        ; mb_res <- tryM $
                    updLclEnv (\ env -> env { tcl_lie = lie_var }) $
                    thing_inside
-
        ; lie <- readTcRef lie_var
 
-            -- See Note [Constraints and errors] for the
-            -- tryM/failM dance here
+       -- See Note [Constraints and errors]
+       ; let lie_to_keep = case mb_res of
+                             Left {}  -> insolublesOnly lie
+                             Right {} -> lie
+
+       ; return (mb_res, lie_to_keep) }
+
+captureConstraints :: TcM a -> TcM (a, WantedConstraints)
+-- (captureConstraints m) runs m, and returns the type constraints it generates
+captureConstraints thing_inside
+  = do { (mb_res, lie) <- tryCaptureConstraints thing_inside
+
+            -- See Note [Constraints and errors]
+            -- If the thing_inside threw an exception, emit the insoluble
+            -- constraints only (returned by tryCaptureConstraints)
+            -- so that they are not lost
        ; case mb_res of
-           Left _    -> do { emitInsolubles (getInsolubles lie)
-                           ; failM }
+           Left _    -> do { emitConstraints lie; failM }
            Right res -> return (res, lie) }
 
-captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)
--- (captureTopConstraints m) runs m, and returns the type constraints it
--- generates plus the constraints produced by static forms inside.
-captureTopConstraints thing_inside
-  = do { (res, lie) <- captureConstraints thing_inside ;
-         -- wanted constraints from static forms
-       ; tcg_static_wc_ref <- tcg_static_wc <$> getGblEnv
-       ; stWC <- readTcRef tcg_static_wc_ref
-       ; writeTcRef tcg_static_wc_ref emptyWC
-       ; return (res, andWC stWC lie)
-       }
-
+-- | The name says it all. The returned TcLevel is the *inner* TcLevel.
 pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
 pushLevelAndCaptureConstraints thing_inside
   = do { env <- getLclEnv
@@ -1499,6 +1529,15 @@ pushTcLevelM thing_inside
                           thing_inside
        ; return (res, tclvl') }
 
+-- Returns pushed TcLevel
+pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
+pushTcLevelsM num_levels thing_inside
+  = do { env <- getLclEnv
+       ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env)
+       ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+                thing_inside
+       ; return (res, tclvl') }
+
 getTcLevel :: TcM TcLevel
 getTcLevel = do { env <- getLclEnv
                 ; return (tcl_tclvl env) }
@@ -1509,8 +1548,8 @@ setTcLevel tclvl thing_inside
 
 isTouchableTcM :: TcTyVar -> TcM Bool
 isTouchableTcM tv
-  = do { env <- getLclEnv
-       ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
+  = do { lvl <- getTcLevel
+       ; return (isTouchableMetaTyVar lvl tv) }
 
 getLclTypeEnv :: TcM TcTypeEnv
 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
@@ -1551,7 +1590,59 @@ emitWildCardHoleConstraints wcs
                -- Wildcards are defined locally, and so have RealSrcSpans
          ct_loc' = setCtLocSpan ct_loc real_span
 
-{-
+{- Note [Constraints and errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #12124):
+
+  foo :: Maybe Int
+  foo = return (case Left 3 of
+                  Left -> 1  -- Hard error here!
+                  _    -> 0)
+
+The call to 'return' will generate a (Monad m) wanted constraint; but
+then there'll be "hard error" (i.e. an exception in the TcM monad), from
+the unsaturated Left constructor pattern.
+
+We'll recover in tcPolyBinds, using recoverM.  But then the final
+tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
+un-filled-in, and will emit a misleading error message.
+
+The underlying problem is that an exception interrupts the constraint
+gathering process. Bottom line: if we have an exception, it's best
+simply to discard any gathered constraints.  Hence in 'try_m' we
+capture the constraints in a fresh variable, and only emit them into
+the surrounding context if we exit normally.  If an exception is
+raised, simply discard the collected constraints... we have a hard
+error to report.  So this capture-the-emit dance isn't as stupid as it
+looks :-).
+
+However suppose we throw an exception inside an invocation of
+captureConstraints, and discard all the constraints. Some of those
+constraints might be "variable out of scope" Hole constraints, and that
+might have been the actual original cause of the exception!  For
+example (Trac #12529):
+   f = p @ Int
+Here 'p' is out of scope, so we get an insolube Hole constraint. But
+the visible type application fails in the monad (thows an exception).
+We must not discard the out-of-scope error.
+
+So we /retain the insoluble constraints/ if there is an exception.
+Hence:
+  - insolublesOnly in tryCaptureConstraints
+  - emitConstraints in the Left case of captureConstraints
+
+Hover note that fresly-generated constraints like (Int ~ Bool), or
+((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as
+insoluble.  The constraint solver does that.  So they'll be discarded.
+That's probably ok; but see th/5358 as a not-so-good example:
+   t1 :: Int
+   t1 x = x   -- Manifestly wrong
+
+   foo = $(...raises exception...)
+We report the exception, but not the bug in t1.  Oh well.  Possible
+solution: make TcUnify.uType spot manifestly-insoluble constraints.
+
+
 ************************************************************************
 *                                                                      *
              Template Haskell context
@@ -1670,6 +1761,7 @@ mkIfLclEnv mod loc boot
                                 if_loc     = loc,
                                 if_boot    = boot,
                                 if_nsubst  = Nothing,
+                                if_implicits_env = Nothing,
                                 if_tv_env  = emptyFsEnv,
                                 if_id_env  = emptyFsEnv }
 
@@ -1737,13 +1829,13 @@ getIfModule = do { env <- getLclEnv; return (if_mod env) }
 --------------------
 failIfM :: MsgDoc -> IfL a
 -- The Iface monad doesn't have a place to accumulate errors, so we
--- just fall over fast if one happens; it "shouldnt happen".
+-- just fall over fast if one happens; it "shouldn't happen".
 -- We use IfL here so that we can get context info out of the local env
 failIfM msg
   = do  { env <- getLclEnv
         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
         ; dflags <- getDynFlags
-        ; liftIO (log_action dflags dflags NoReason SevFatal
+        ; liftIO (putLogMsg dflags NoReason SevFatal
                    noSrcSpan (defaultErrStyle dflags) full_msg)
         ; failM }
 
@@ -1780,13 +1872,12 @@ forkM_maybe doc thing_inside
                           dflags <- getDynFlags
                           let msg = hang (text "forkM failed:" <+> doc)
                                        2 (text (show exn))
-                          liftIO $ log_action dflags
-                                              dflags
-                                              NoReason
-                                              SevFatal
-                                              noSrcSpan
-                                              (defaultErrStyle dflags)
-                                              msg
+                          liftIO $ putLogMsg dflags
+                                             NoReason
+                                             SevFatal
+                                             noSrcSpan
+                                             (defaultErrStyle dflags)
+                                             msg
 
                     ; traceIf (text "} ending fork (badly)" <+> doc)
                     ; return Nothing }
@@ -1800,6 +1891,9 @@ forkM doc thing_inside
                                    -- pprPanic "forkM" doc
                         Just r  -> r) }
 
+setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
+setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl { if_implicits_env = Just tenv }) m
+
 {-
 Note [Masking exceptions in forkM_maybe]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1817,3 +1911,24 @@ up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
 discussion).  We don't currently know a general solution to this problem, but
 we can use uninterruptibleMask_ to avoid the situation.
 -}
+
+-- | Environments which track 'CostCentreState'
+class ContainsCostCentreState e where
+  extractCostCentreState :: e -> TcRef CostCentreState
+
+instance ContainsCostCentreState TcGblEnv where
+  extractCostCentreState = tcg_cc_st
+
+instance ContainsCostCentreState DsGblEnv where
+  extractCostCentreState = ds_cc_st
+
+-- | Get the next cost centre index associated with a given name.
+getCCIndexM :: (ContainsCostCentreState gbl)
+            => FastString -> TcRnIf gbl lcl CostCentreIndex
+getCCIndexM nm = do
+  env <- getGblEnv
+  let cc_st_ref = extractCostCentreState env
+  cc_st <- readTcRef cc_st_ref
+  let (idx, cc_st') = getCCIndex nm cc_st
+  writeTcRef cc_st_ref cc_st'
+  return idx