Fix header locations
[ghc.git] / compiler / typecheck / TcRnMonad.hs
index 5797b8e..e0989ae 100644 (file)
@@ -9,13 +9,137 @@ Functions for working with the typechecker environment (setters, getters...).
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module TcRnMonad(
-        module TcRnMonad,
-        module TcRnTypes,
-        module IOEnv
+  -- * Initalisation
+  initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
+
+  -- * Simple accessors
+  discardResult,
+  getTopEnv, updTopEnv, getGblEnv, updGblEnv,
+  setGblEnv, getLclEnv, updLclEnv, setLclEnv,
+  getEnvs, setEnvs,
+  xoptM, doptM, goptM, woptM,
+  setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
+  whenDOptM, whenGOptM, whenWOptM,
+  whenXOptM, unlessXOptM,
+  getGhcMode,
+  withDoDynamicToo,
+  getEpsVar,
+  getEps,
+  updateEps, updateEps_,
+  getHpt, getEpsAndHpt,
+
+  -- * Arrow scopes
+  newArrowScope, escapeArrowScope,
+
+  -- * Unique supply
+  newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
+  newSysName, newSysLocalId, newSysLocalIds,
+
+  -- * Accessing input/output
+  newTcRef, readTcRef, writeTcRef, updTcRef,
+
+  -- * Debugging
+  traceTc, traceRn, traceOptTcRn, traceTcRn,
+  getPrintUnqualified,
+  printForUserTcRn,
+  traceIf, traceHiDiffs, traceOptIf,
+  debugTc,
+
+  -- * Typechecker global environment
+  getIsGHCi, getGHCiMonad, getInteractivePrintName,
+  tcIsHsBootOrSig, tcSelfBootInfo, getGlobalRdrEnv,
+  getRdrEnvs, getImports,
+  getFixityEnv, extendFixityEnv, getRecFieldEnv,
+  getDeclaredDefaultTys,
+  addDependentFiles,
+
+  -- * Error management
+  getSrcSpanM, setSrcSpan, addLocM,
+  wrapLocM, wrapLocFstM, wrapLocSndM,
+  getErrsVar, setErrsVar,
+  addErr,
+  failWith, failAt,
+  addErrAt, addErrs,
+  checkErr,
+  addMessages,
+  discardWarnings,
+
+  -- * Shared error message stuff: renamer and typechecker
+  mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
+  reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
+  tryTc,
+  askNoErrs, discardErrs, tryTcDiscardingErrs,
+  checkNoErrs, whenNoErrs,
+  ifErrsM, failIfErrsM,
+  checkTH, failTH,
+
+  -- * Context management for the type checker
+  getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
+  addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM,
+
+  -- * Error message generation (type checker)
+  addErrTc, addErrsTc,
+  addErrTcM, mkErrTcM, mkErrTc,
+  failWithTc, failWithTcM,
+  checkTc, checkTcM,
+  failIfTc, failIfTcM,
+  warnIfFlag, warnIf, warnTc, warnTcM,
+  addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
+  mkErrInfo,
+
+  -- * Type constraints
+  newTcEvBinds, newNoTcEvBinds,
+  addTcEvBind, addTopEvBinds,
+  getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
+  chooseUniqueOccTc,
+  getConstraintVar, setConstraintVar,
+  emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
+  emitImplication, emitImplications, emitInsoluble,
+  discardConstraints, captureConstraints, tryCaptureConstraints,
+  pushLevelAndCaptureConstraints,
+  pushTcLevelM_, pushTcLevelM, pushTcLevelsM,
+  getTcLevel, setTcLevel, isTouchableTcM,
+  getLclTypeEnv, setLclTypeEnv,
+  traceTcConstraints, emitWildCardHoleConstraints,
+
+  -- * Template Haskell context
+  recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,
+  getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,
+  addModFinalizersWithLclEnv,
+
+  -- * Safe Haskell context
+  recordUnsafeInfer, finalSafeMode, fixSafeInstances,
+
+  -- * Stuff for the renamer's local env
+  getLocalRdrEnv, setLocalRdrEnv,
+
+  -- * Stuff for interface decls
+  mkIfLclEnv,
+  initIfaceTcRn,
+  initIfaceCheck,
+  initIfaceLcl,
+  initIfaceLclWithSubst,
+  initIfaceLoad,
+  getIfModule,
+  failIfM,
+  forkM_maybe,
+  forkM,
+  setImplicitEnvM,
+
+  withException,
+
+  -- * Stuff for cost centres.
+  ContainsCostCentreState(..), getCCIndexM,
+
+  -- * Types etc.
+  module TcRnTypes,
+  module IOEnv
   ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcRnTypes        -- Re-export all
 import IOEnv            -- Re-export all
 import TcEvidence
@@ -42,24 +166,26 @@ import NameSet
 import Bag
 import Outputable
 import UniqSupply
-import UniqFM
 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 )
 
-#ifdef GHCI
 import qualified Data.Map as Map
-#endif
 
 {-
 ************************************************************************
@@ -81,14 +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 ;
@@ -96,32 +220,42 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
 
         dependent_files_var <- newIORef [] ;
         static_wc_var       <- newIORef emptyWC ;
-#ifdef GHCI
+        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 ;
-#endif /* GHCI */
+        th_remote_state_var  <- newIORef Nothing ;
         let {
              dflags = hsc_dflags hsc_env ;
 
              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 {
-#ifdef GHCI
                 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,
-#endif /* GHCI */
+                tcg_th_remote_state  = th_remote_state_var,
 
                 tcg_mod            = mod,
+                tcg_semantic_mod   =
+                    canonicalizeModuleIfHome dflags mod,
                 tcg_src            = hsc_src,
-                tcg_sig_of         = getSigOf dflags (moduleName mod),
-                tcg_impl_rdr_env   = Nothing,
                 tcg_rdr_env        = emptyGlobalRdrEnv,
                 tcg_fix_env        = emptyNameEnv,
                 tcg_field_env      = emptyNameEnv,
@@ -135,13 +269,20 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_ann_env        = emptyAnnEnv,
                 tcg_th_used        = th_var,
                 tcg_th_splice_used = th_splice_var,
+                tcg_th_top_level_locs
+                                   = th_locs_var,
                 tcg_exports        = [],
                 tcg_imports        = emptyImportAvails,
                 tcg_used_gres     = used_gre_var,
                 tcg_dus            = emptyDUs,
 
                 tcg_rn_imports     = [],
-                tcg_rn_exports     = maybe_rn_syntax [],
+                tcg_rn_exports     =
+                    if hsc_src == HsigFile
+                        -- Always retain renamed syntax, so that we can give
+                        -- better errors.  (TODO: how?)
+                        then Just []
+                        else maybe_rn_syntax [],
                 tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,
                 tcg_tr_module      = Nothing,
                 tcg_binds          = emptyLHsBinds,
@@ -155,8 +296,8 @@ 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,
                 tcg_keep           = keep_var,
                 tcg_doc_hdr        = Nothing,
@@ -166,9 +307,28 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_safeInfer      = infer_var,
                 tcg_dependent_files = dependent_files_var,
                 tcg_tc_plugins     = [],
-                tcg_static_wc      = static_wc_var
+                tcg_top_loc        = loc,
+                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       = [],
@@ -178,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 ;
-
-        let { final_res | errorsFound dflags msgs = Nothing
-                        | otherwise               = maybe_res } ;
+      ; msgs <- readIORef (tcl_errs lcl_env)
 
-        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
@@ -218,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
@@ -276,6 +427,10 @@ discardResult a = a >> return ()
 getTopEnv :: TcRnIf gbl lcl HscEnv
 getTopEnv = do { env <- getEnv; return (env_top env) }
 
+updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
+                          env { env_top = upd top })
+
 getGblEnv :: TcRnIf gbl lcl gbl
 getGblEnv = do { env <- getEnv; return (env_gbl env) }
 
@@ -317,16 +472,20 @@ woptM :: WarningFlag -> TcRnIf gbl lcl Bool
 woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
 
 setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-setXOptM flag = updEnv (\ env@(Env { env_top = top }) ->
-                          env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
+setXOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})
+
+unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetXOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag})
 
 unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-unsetGOptM flag = updEnv (\ env@(Env { env_top = top }) ->
-                            env { env_top = top { hsc_dflags = gopt_unset (hsc_dflags top) flag}} )
+unsetGOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})
 
 unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) ->
-                            env { env_top = top { hsc_dflags = wopt_unset (hsc_dflags top) flag}} )
+unsetWOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})
 
 -- | Do it flag is true
 whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
@@ -345,15 +504,17 @@ 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)) }
 
 withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-withDoDynamicToo m = do env <- getEnv
-                        let dflags = extractDynFlags env
-                            dflags' = dynamicTooMkDynamicDynFlags dflags
-                            env' = replaceDynFlags env dflags'
-                        setEnv env' m
+withDoDynamicToo =
+  updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->
+              top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })
 
 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
@@ -391,6 +552,16 @@ getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
                   ; return (eps, hsc_HPT env) }
 
+-- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing
+-- an exception if it is an error.
+withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a
+withException do_this = do
+    r <- do_this
+    dflags <- getDynFlags
+    case r of
+        Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))
+        Succeeded result -> return result
+
 {-
 ************************************************************************
 *                                                                      *
@@ -445,14 +616,18 @@ newUniqueSupply
         writeMutVar u_var us1 ;
         return us2 }}}
 
-newLocalName :: Name -> TcM Name
-newLocalName name = newName (nameOccName name)
+cloneLocalName :: Name -> TcM Name
+-- Make a fresh Internal name with the same OccName and SrcSpan
+cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)
 
 newName :: OccName -> TcM Name
-newName occ
+newName occ = do { loc  <- getSrcSpanM
+                 ; newNameAt occ loc }
+
+newNameAt :: OccName -> SrcSpan -> TcM Name
+newNameAt occ span
   = do { uniq <- newUnique
-       ; loc  <- getSrcSpanM
-       ; return (mkInternalName uniq occ loc) }
+       ; return (mkInternalName uniq occ span) }
 
 newSysName :: OccName -> TcRnIf gbl lcl Name
 newSysName occ
@@ -495,12 +670,6 @@ updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
 updTcRef ref fn = liftIO $ do { old <- readIORef ref
                               ; writeIORef ref (fn old) }
 
-updTcRefX :: TcRef a -> (a -> a) -> TcRnIf gbl lcl a
--- Returns previous value
-updTcRefX ref fn = liftIO $ do { old <- readIORef ref
-                              ; writeIORef ref (fn old)
-                              ; return old }
-
 {-
 ************************************************************************
 *                                                                      *
@@ -509,18 +678,25 @@ updTcRefX ref fn = liftIO $ do { old <- readIORef ref
 ************************************************************************
 -}
 
+
+-- Typechecker trace
 traceTc :: String -> SDoc -> TcRn ()
-traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
+traceTc =
+  labelledTraceOptTcRn Opt_D_dump_tc_trace
+
+-- Renamer Trace
+traceRn :: String -> SDoc -> TcRn ()
+traceRn =
+  labelledTraceOptTcRn Opt_D_dump_rn_trace
 
--- | Typechecker trace
-traceTcN :: Int -> SDoc -> TcRn ()
-traceTcN level doc
-    = do dflags <- getDynFlags
-         when (level <= traceLevel dflags && not opt_NoDebugOutput) $
-             traceOptTcRn Opt_D_dump_tc_trace doc
+-- | Trace when a certain flag is enabled. This is like `traceOptTcRn`
+-- but accepts a string as a label and formats the trace message uniformly.
+labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
+labelledTraceOptTcRn flag herald doc = do
+   traceOptTcRn flag (formatTraceMsg herald doc)
 
-traceRn :: SDoc -> TcRn ()
-traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
+formatTraceMsg :: String -> SDoc -> SDoc
+formatTraceMsg herald doc = hang (text herald) 2 doc
 
 -- | Output a doc if the given 'DumpFlag' is set.
 --
@@ -532,8 +708,10 @@ traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
 traceOptTcRn flag doc
   = do { dflags <- getDynFlags
-       ; when (dopt flag dflags) (traceTcRn flag doc)
-    }
+       ; when (dopt flag dflags)
+              (traceTcRn flag doc)
+       }
+
 
 traceTcRn :: DumpFlag -> SDoc -> TcRn ()
 -- ^ Unconditionally dump some trace output
@@ -542,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
 
@@ -566,11 +744,6 @@ printForUserTcRn doc
        ; printer <- getPrintUnqualified dflags
        ; liftIO (printOutputForUser dflags printer doc) }
 
--- | Typechecker debug
-debugDumpTcRn :: SDoc -> TcRn ()
-debugDumpTcRn doc = unless opt_NoDebugOutput $
-                    traceOptTcRn Opt_D_dump_tc doc
-
 {-
 traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
 available.  Alas, they behave inconsistently with the other stuff;
@@ -596,9 +769,6 @@ traceOptIf flag doc
 ************************************************************************
 -}
 
-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 (isInteractiveModule mod) }
@@ -715,23 +885,18 @@ checkErr :: Bool -> MsgDoc -> TcRn ()
 -- Add the error if the bool is False
 checkErr ok msg = unless ok (addErr msg)
 
-warnIf :: Bool -> MsgDoc -> TcRn ()
-warnIf True  msg = addWarn msg
-warnIf False _   = return ()
-
 addMessages :: Messages -> TcRn ()
-addMessages (m_warns, m_errs)
+addMessages msgs1
   = do { errs_var <- getErrsVar ;
-         (warns, errs) <- readTcRef errs_var ;
-         writeTcRef errs_var (warns `unionBags` m_warns,
-                               errs  `unionBags` m_errs) }
+         msgs0 <- readTcRef errs_var ;
+         writeTcRef errs_var (unionMessages msgs0 msgs1) }
 
 discardWarnings :: TcRn a -> TcRn a
 -- Ignore warnings inside the thing inside;
 -- used to ignore-unused-variable warnings inside derived code
 discardWarnings thing_inside
   = do  { errs_var <- getErrsVar
-        ; (old_warns, _) <- readTcRef errs_var ;
+        ; (old_warns, _) <- readTcRef errs_var
 
         ; result <- thing_inside
 
@@ -774,9 +939,9 @@ reportError err
          (warns, errs) <- readTcRef errs_var ;
          writeTcRef errs_var (warns, errs `snocBag` err) }
 
-reportWarning :: ErrMsg -> TcRn ()
-reportWarning err
-  = do { let warn = makeIntoWarning err
+reportWarning :: WarnReason -> ErrMsg -> TcRn ()
+reportWarning reason err
+  = do { let warn = makeIntoWarning reason err
                     -- 'err' was built by mkLongErrMsg or something like that,
                     -- so it's of error severity.  For a warning we downgrade
                     -- its severity to SevWarning
@@ -789,16 +954,21 @@ reportWarning err
 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
 -- Does tryM, with a debug-trace on failure
 try_m thing
-  = do { mb_r <- tryM thing ;
-         case mb_r of
-             Left exn -> do { traceTc "tryTc/recoverM recovering from" $
-                                      text (showException exn)
-                            ; return mb_r }
-             Right _  -> return mb_r }
+  = do { (mb_r, lie) <- tryCaptureConstraints thing
+       ; emitConstraints lie
+
+       -- Debug trace
+       ; case mb_r of
+            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
@@ -809,15 +979,20 @@ recoverM recover thing
 
 
 -----------------------
-mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
--- Drop elements of the input that fail, so the result
+
+-- Drop elements of the input that fail, so the result
 -- list can be shorter than the argument list
-mapAndRecoverM _ []     = return []
-mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
-                             ; rs <- mapAndRecoverM f xs
-                             ; return (case mb_r of
-                                          Left _  -> rs
-                                          Right r -> r:rs) }
+mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
+mapAndRecoverM f = fmap reverse . foldAndRecoverM (\xs x -> (:xs) <$> f x ) []
+
+-- | The accumulator is not updated if the action fails
+foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
+foldAndRecoverM _ acc []     = return acc
+foldAndRecoverM f acc (x:xs) =
+                          do { mb_r <- try_m (f acc x)
+                             ; case mb_r of
+                                Left _  -> foldAndRecoverM f acc xs
+                                Right acc' -> foldAndRecoverM f acc' xs  }
 
 -- | Succeeds if applying the argument to all members of the lists succeeds,
 --   but nevertheless runs it on all arguments, to collect all errors.
@@ -831,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
@@ -864,48 +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 a -> TcM (Messages, Maybe a)
--- Just like tryTcErrs, except that it ensures that the LIE
--- for the thing is propagated only if there are no errors
--- Hence it's restricted to the type-check monad
-tryTcLIE thing_inside
-  = do  { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
         ; case mb_res of
-            Nothing  -> return (msgs, Nothing)
-            Just val -> do { emitConstraints lie; return (msgs, Just val) }
-        }
+            Just res | not (errorsFound dflags msgs)
+              -> -- 'main' succeeed with no error messages
+                 do { addMessages msgs  -- msgs might still have warnings
+                    ; return res }
 
------------------------
-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) <- tryTcLIE main
-        ; case mb_res of
-             Just val -> do { addMessages msgs  -- There might be warnings
-                             ; return val }
-             Nothing  -> recover                -- Discard all msgs
+            _ -> -- '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.
@@ -914,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) <- tryTcLIE 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
 
@@ -941,23 +1104,18 @@ failIfErrsM :: TcRn ()
 -- Useful to avoid error cascades
 failIfErrsM = ifErrsM failM (return ())
 
-#ifdef GHCI
 checkTH :: a -> String -> TcRn ()
 checkTH _ _ = return () -- OK
-#else
-checkTH :: Outputable a => a -> String -> TcRn ()
-checkTH e what = failTH e what  -- Raise an error in a stage-1 compiler
-#endif
 
 failTH :: Outputable a => a -> String -> TcRn x
 failTH e what  -- Raise an error in a stage-1 compiler
   = failWithTc (vcat [ hang (char 'A' <+> text what
-                             <+> ptext (sLit "requires GHC with interpreter support:"))
+                             <+> text "requires GHC with interpreter support:")
                           2 (ppr e)
-                     , ptext (sLit "Perhaps you are using a stage-1 compiler?") ])
+                     , text "Perhaps you are using a stage-1 compiler?" ])
 
-{-
-************************************************************************
+
+{- *********************************************************************
 *                                                                      *
         Context management for the type checker
 *                                                                      *
@@ -970,14 +1128,26 @@ getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
 
+-- | Add a fixed message to the error context. This message should not
+-- do any tidying.
 addErrCtxt :: MsgDoc -> TcM a -> TcM a
 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
 
+-- | Add a message to the error context. This message may do tidying.
 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
 
+-- | Add a fixed landmark message to the error context. A landmark
+-- message is always sure to be reported, even if there is a lot of
+-- context. It also doesn't count toward the maximum number of contexts
+-- reported.
 addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
-addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
+addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
+
+-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
+-- and tidying.
+addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
+addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
 
 -- Helper function for the above
 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
@@ -1036,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
@@ -1066,57 +1240,67 @@ failIfTcM True  err = failWithTcM err
 
 --         Warnings have no 'M' variant, nor failure
 
-warnTc :: Bool -> MsgDoc -> TcM ()
-warnTc warn_if_true warn_msg
-  | warn_if_true = addWarnTc warn_msg
+-- | Display a warning if a condition is met,
+--   and the warning is enabled
+warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()
+warnIfFlag warn_flag is_bad msg
+  = do { warn_on <- woptM warn_flag
+       ; when (warn_on && is_bad) $
+         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 ()
+warnTc reason warn_if_true warn_msg
+  | warn_if_true = addWarnTc reason warn_msg
   | otherwise    = return ()
 
-warnTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
-warnTcM warn_if_true warn_msg
-  | warn_if_true = addWarnTcM warn_msg
+-- | Display a warning if a condition is met.
+warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
+warnTcM reason warn_if_true warn_msg
+  | warn_if_true = addWarnTcM reason warn_msg
   | otherwise    = return ()
 
-addWarnTc :: MsgDoc -> TcM ()
-addWarnTc msg = do { env0 <- tcInitTidyEnv
-                   ; addWarnTcM (env0, msg) }
+-- | Display a warning in the current context.
+addWarnTc :: WarnReason -> MsgDoc -> TcM ()
+addWarnTc reason msg
+ = do { env0 <- tcInitTidyEnv ;
+      addWarnTcM reason (env0, msg) }
 
-addWarnTcM :: (TidyEnv, MsgDoc) -> TcM ()
-addWarnTcM (env0, msg)
+-- | Display a warning in a given context.
+addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
+addWarnTcM reason (env0, msg)
  = do { ctxt <- getErrCtxt ;
         err_info <- mkErrInfo env0 ctxt ;
-        add_warn msg err_info }
+        add_warn reason msg err_info }
 
-addWarn :: MsgDoc -> TcRn ()
-addWarn msg = add_warn msg Outputable.empty
+-- | Display a warning for the current source location.
+addWarn :: WarnReason -> MsgDoc -> TcRn ()
+addWarn reason msg = add_warn reason msg Outputable.empty
 
-addWarnAt :: SrcSpan -> MsgDoc -> TcRn ()
-addWarnAt loc msg = add_warn_at loc msg Outputable.empty
+-- | Display a warning for a given source location.
+addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
+addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty
 
-add_warn :: MsgDoc -> MsgDoc -> TcRn ()
-add_warn msg extra_info
+-- | Display a warning, with an optional flag, for the current source
+-- location.
+add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
+add_warn reason msg extra_info
   = do { loc <- getSrcSpanM
-       ; add_warn_at loc msg extra_info }
+       ; add_warn_at reason loc msg extra_info }
 
-add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
-add_warn_at loc msg extra_info
+-- | Display a warning, with an optional flag, for a given location.
+add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
+add_warn_at reason loc msg extra_info
   = do { dflags <- getDynFlags ;
          printer <- getPrintUnqualified dflags ;
          let { warn = mkLongWarnMsg dflags loc printer
                                     msg extra_info } ;
-         reportWarning 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 :: TyCoVarSet -> TcM TidyEnv
-tcInitOpenTidyEnv tvs
-  = do { env1 <- tcInitTidyEnv
-       ; let env2 = tidyFreeTyCoVars env1 tvs
-       ; return env2 }
+         reportWarning reason warn }
 
 
 {-
@@ -1134,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
@@ -1168,28 +1354,61 @@ 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 { ref <- newTcRef emptyEvBindMap
+newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
+                  ; tcvs_ref  <- newTcRef emptyVarSet
                   ; uniq <- newUnique
                   ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
-                  ; return (EvBindsVar ref uniq) }
+                  ; return (EvBindsVar { ebv_binds = binds_ref
+                                       , 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 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
-addTcEvBind (EvBindsVar ev_ref u) ev_bind
+addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
   = do { traceTc "addTcEvBind" $ ppr u $$
                                  ppr ev_bind
        ; bnds <- readTcRef ev_ref
        ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
-
-getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
-getTcEvBinds (EvBindsVar ev_ref _)
-  = do { bnds <- readTcRef ev_ref
-       ; return (evBindMapBinds bnds) }
-
-getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
-getTcEvBindsMap (EvBindsVar ev_ref _)
-  = readTcRef ev_ref
+addTcEvBind (NoEvBindsVar { ebv_uniq = u }) ev_bind
+  = pprPanic "addTcEvBind NoEvBindsVar" (ppr ev_bind $$ ppr u)
 
 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
 chooseUniqueOccTc fn =
@@ -1206,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) }
 
@@ -1234,39 +1461,67 @@ emitImplications ct
 
 emitInsoluble :: Ct -> TcM ()
 emitInsoluble ct
-  = do { lie_var <- getConstraintVar ;
-         updTcRef lie_var (`addInsols` unitBag ct) ;
-         v <- readTcRef lie_var ;
-         traceTc "emitInsoluble" (ppr v) }
+  = do { traceTc "emitInsoluble" (ppr ct)
+       ; lie_var <- getConstraintVar
+       ; updTcRef lie_var (`addInsols` unitBag ct) }
+
+emitInsolubles :: Cts -> TcM ()
+emitInsolubles cts
+  | isEmptyBag cts = return ()
+  | otherwise      = do { traceTc "emitInsolubles" (ppr cts)
+                        ; lie_var <- getConstraintVar
+                        ; updTcRef lie_var (`addInsols` cts) }
 
 -- | Throw out any constraints emitted by the thing_inside
 discardConstraints :: TcM a -> TcM a
 discardConstraints thing_inside = fst <$> 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]
+       ; 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 { lie_var <- newTcRef emptyWC ;
-         res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
-                          thing_inside ;
-         lie <- readTcRef lie_var ;
-         return (res, lie) }
+  = 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 { emitConstraints lie; failM }
+           Right res -> return (res, 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
-       ; lie_var <- newTcRef emptyWC ;
        ; let tclvl' = pushTcLevel (tcl_tclvl env)
-       ; res <- setLclEnv (env { tcl_tclvl = tclvl'
-                               , tcl_lie   = lie_var })
-                thing_inside
-       ; lie <- readTcRef lie_var
+       ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+                       captureConstraints thing_inside
        ; return (tclvl', lie, res) }
 
 pushTcLevelM_ :: TcM a -> TcM a
-pushTcLevelM_ = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) })
+pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
 
 pushTcLevelM :: TcM a -> TcM (a, TcLevel)
+-- See Note [TcLevel assignment] in TcType
 pushTcLevelM thing_inside
   = do { env <- getLclEnv
        ; let tclvl' = pushTcLevel (tcl_tclvl env)
@@ -1274,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) }
@@ -1284,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) }
@@ -1303,27 +1567,82 @@ traceTcConstraints :: String -> TcM ()
 traceTcConstraints msg
   = do { lie_var <- getConstraintVar
        ; lie     <- readTcRef lie_var
-       ; traceTc (msg ++ ": LIE:") (ppr lie)
+       ; traceOptTcRn Opt_D_dump_tc_trace $
+         hang (text (msg ++ ": LIE:")) 2 (ppr lie)
        }
 
 emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
 emitWildCardHoleConstraints wcs
-  = do { ctLoc <- getCtLocM HoleOrigin Nothing
-       ; forM_ wcs $ \(name, tv) -> do {
-       ; let real_span = case nameSrcSpan name of
+  = do { ct_loc <- getCtLocM HoleOrigin Nothing
+       ; emitInsolubles $ listToBag $
+         map (do_one ct_loc) wcs }
+  where
+    do_one :: CtLoc -> (Name, TcTyVar) -> Ct
+    do_one ct_loc (name, tv)
+       = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
+                                      , ctev_loc  = ct_loc' }
+                  , cc_hole = TypeHole (occName name) }
+       where
+         real_span = case nameSrcSpan name of
                            RealSrcSpan span  -> span
                            UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
                                                       (ppr name <+> quotes (ftext str))
                -- Wildcards are defined locally, and so have RealSrcSpans
-             ctLoc' = setCtLocSpan ctLoc real_span
-             ty     = mkTyVarTy tv
-             can    = CHoleCan { cc_ev   = CtDerived { ctev_pred = ty
-                                                     , ctev_loc  = ctLoc' }
-                               , cc_occ  = occName name
-                               , cc_hole = TypeHole }
-       ; emitInsoluble can } }
+         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
@@ -1337,10 +1656,26 @@ recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
 recordThSpliceUse :: TcM ()
 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
 
+-- | When generating an out-of-scope error message for a variable matching a
+-- binding in a later inter-splice group, the typechecker uses the splice
+-- locations to provide details in the message about the scope of that binding.
+recordTopLevelSpliceLoc :: SrcSpan -> TcM ()
+recordTopLevelSpliceLoc (RealSrcSpan real_loc)
+  = do { env <- getGblEnv
+       ; let locs_var = tcg_th_top_level_locs env
+       ; locs0 <- readTcRef locs_var
+       ; writeTcRef locs_var (Set.insert real_loc locs0) }
+recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()
+
+getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)
+getTopLevelSpliceLocs
+  = do { env <- getGblEnv
+       ; readTcRef (tcg_th_top_level_locs env) }
+
 keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set
 keepAlive name
   = do { env <- getGblEnv
-       ; traceRn (ptext (sLit "keep alive") <+> ppr name)
+       ; traceRn "keep alive" (ppr name)
        ; updTcRef (tcg_keep env) (`extendNameSet` name) }
 
 getStage :: TcM ThStage
@@ -1356,6 +1691,16 @@ getStageAndBindLevel name
 setStage :: ThStage -> TcM a -> TcRn a
 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
 
+-- | Adds the given modFinalizers to the global environment and set them to use
+-- the current local environment.
+addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
+addModFinalizersWithLclEnv mod_finalizers
+  = do lcl_env <- getLclEnv
+       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+       updTcRef th_modfinalizers_var $ \fins ->
+         setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers)
+         : fins
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1410,11 +1755,15 @@ setLocalRdrEnv rdr_env thing_inside
 ************************************************************************
 -}
 
-mkIfLclEnv :: Module -> SDoc -> IfLclEnv
-mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
+mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
+mkIfLclEnv mod loc boot
+                   = IfLclEnv { if_mod     = mod,
                                 if_loc     = loc,
-                                if_tv_env  = emptyUFM,
-                                if_id_env  = emptyUFM }
+                                if_boot    = boot,
+                                if_nsubst  = Nothing,
+                                if_implicits_env = Nothing,
+                                if_tv_env  = emptyFsEnv,
+                                if_id_env  = emptyFsEnv }
 
 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
@@ -1422,42 +1771,57 @@ mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
 initIfaceTcRn :: IfG a -> TcRn a
 initIfaceTcRn thing_inside
   = do  { tcg_env <- getGblEnv
+        ; dflags <- getDynFlags
+        ; let mod = tcg_semantic_mod tcg_env
+              -- When we are instantiating a signature, we DEFINITELY
+              -- do not want to knot tie.
+              is_instantiate = unitIdIsDefinite (thisPackage dflags) &&
+                               not (null (thisUnitIdInsts dflags))
         ; let { if_env = IfGblEnv {
-                            if_rec_types = Just (tcg_mod tcg_env, get_type_env)
+                            if_doc = text "initIfaceTcRn",
+                            if_rec_types =
+                                if is_instantiate
+                                    then Nothing
+                                    else Just (mod, get_type_env)
                          }
               ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
         ; setEnvs (if_env, ()) thing_inside }
 
-initIfaceCheck :: HscEnv -> IfG a -> IO a
+-- Used when sucking in a ModIface into a ModDetails to put in
+-- the HPT.  Notably, unlike initIfaceCheck, this does NOT use
+-- hsc_type_env_var (since we're not actually going to typecheck,
+-- so this variable will never get updated!)
+initIfaceLoad :: HscEnv -> IfG a -> IO a
+initIfaceLoad hsc_env do_this
+ = do let gbl_env = IfGblEnv {
+                        if_doc = text "initIfaceLoad",
+                        if_rec_types = Nothing
+                    }
+      initTcRnIf 'i' hsc_env gbl_env () do_this
+
+initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
 -- Used when checking the up-to-date-ness of the old Iface
 -- Initialise the environment with no useful info at all
-initIfaceCheck hsc_env do_this
+initIfaceCheck doc hsc_env do_this
  = do let rec_types = case hsc_type_env_var hsc_env of
                          Just (mod,var) -> Just (mod, readTcRef var)
                          Nothing        -> Nothing
-          gbl_env = IfGblEnv { if_rec_types = rec_types }
+          gbl_env = IfGblEnv {
+                        if_doc = text "initIfaceCheck" <+> doc,
+                        if_rec_types = rec_types
+                    }
       initTcRnIf 'i' hsc_env gbl_env () do_this
 
-initIfaceTc :: ModIface
-            -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
--- Used when type-checking checking an up-to-date interface file
--- No type envt from the current module, but we do know the module dependencies
-initIfaceTc iface do_this
- = do   { tc_env_var <- newTcRef emptyTypeEnv
-        ; let { gbl_env = IfGblEnv {
-                            if_rec_types = Just (mod, readTcRef tc_env_var)
-                          } ;
-              ; if_lenv = mkIfLclEnv mod doc
-           }
-        ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
-    }
-  where
-    mod = mi_module iface
-    doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
+initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
+initIfaceLcl mod loc_doc hi_boot_file thing_inside
+  = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
 
-initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
-initIfaceLcl mod loc_doc thing_inside
-  = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
+-- | Initialize interface typechecking, but with a 'NameShape'
+-- to apply when typechecking top-level 'OccName's (see
+-- 'lookupIfaceTop')
+initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a
+initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
+  = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
 
 getIfModule :: IfL Module
 getIfModule = do { env <- getLclEnv; return (if_mod env) }
@@ -1465,13 +1829,14 @@ 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 SevFatal noSrcSpan (defaultErrStyle dflags) full_msg)
+        ; liftIO (putLogMsg dflags NoReason SevFatal
+                   noSrcSpan (defaultErrStyle dflags) full_msg)
         ; failM }
 
 --------------------
@@ -1507,7 +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 SevFatal noSrcSpan (defaultErrStyle dflags) msg
+                          liftIO $ putLogMsg dflags
+                                             NoReason
+                                             SevFatal
+                                             noSrcSpan
+                                             (defaultErrStyle dflags)
+                                             msg
 
                     ; traceIf (text "} ending fork (badly)" <+> doc)
                     ; return Nothing }
@@ -1521,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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1538,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