{-
(c) The University of Glasgow 2006


Functions for working with the typechecker environment (setters, getters...).
-}

{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ViewPatterns #-}


module TcRnMonad(
  -- * 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, traceTcRnForUser,
  traceTcRnWithStyle,
  getPrintUnqualified,
  printForUserTcRn,
  traceIf, traceHiDiffs, traceOptIf,
  debugTc,

  -- * Typechecker global environment
  getIsGHCi, getGHCiMonad, getInteractivePrintName,
  tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv,
  getRdrEnvs, getImports,
  getFixityEnv, extendFixityEnv, getRecFieldEnv,
  getDeclaredDefaultTys,
  addDependentFiles,

  -- * Error management
  getSrcSpanM, setSrcSpan, addLocM,
  wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_,
  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,
  attemptM, 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, cloneEvBindsVar,
  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

import HsSyn hiding (LIE)
import HscTypes
import Module
import RdrName
import Name
import Type

import TcType
import InstEnv
import FamInstEnv
import PrelNames

import Id
import VarSet
import VarEnv
import ErrUtils
import SrcLoc
import NameEnv
import NameSet
import Bag
import Outputable
import UniqSupply
import DynFlags
import FastString
import Panic
import Util
import Annotations
import BasicTypes( TopLevelFlag )
import Maybes
import CostCentreState

import qualified GHC.LanguageExtensions as LangExt

import Data.IORef
import Control.Monad
import Data.Set ( Set )
import qualified Data.Set as Set

import {-# SOURCE #-} TcEnv    ( tcInitTidyEnv )

import qualified Data.Map as Map

{-
************************************************************************
*                                                                      *
                        initTc
*                                                                      *
************************************************************************
-}

-- | Setup the initial typechecking environment
initTc :: HscEnv
       -> HscSource
       -> Bool          -- True <=> retain renamed syntax trees
       -> Module
       -> RealSrcSpan
       -> TcM r
       -> IO (Messages, Maybe r)
                -- Nothing => error thrown by the thing inside
                -- (error messages should have been printed already)

initTc :: HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages, Maybe r)
initTc hsc_env :: HscEnv
hsc_env hsc_src :: HscSource
hsc_src keep_rn_syntax :: Bool
keep_rn_syntax mod :: Module
mod loc :: RealSrcSpan
loc do_this :: TcM r
do_this
 = do { IORef NameSet
keep_var     <- NameSet -> IO (IORef NameSet)
forall a. a -> IO (IORef a)
newIORef NameSet
emptyNameSet ;
        IORef [GlobalRdrElt]
used_gre_var <- [GlobalRdrElt] -> IO (IORef [GlobalRdrElt])
forall a. a -> IO (IORef a)
newIORef [] ;
        IORef Bool
th_var       <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False ;
        IORef Bool
th_splice_var<- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False ;
        IORef (Set RealSrcSpan)
th_locs_var  <- Set RealSrcSpan -> IO (IORef (Set RealSrcSpan))
forall a. a -> IO (IORef a)
newIORef Set RealSrcSpan
forall a. Set a
Set.empty ;
        IORef (Bool, Bag WarnMsg)
infer_var    <- (Bool, Bag WarnMsg) -> IO (IORef (Bool, Bag WarnMsg))
forall a. a -> IO (IORef a)
newIORef (Bool
True, Bag WarnMsg
forall a. Bag a
emptyBag) ;
        IORef OccSet
dfun_n_var   <- OccSet -> IO (IORef OccSet)
forall a. a -> IO (IORef a)
newIORef OccSet
emptyOccSet ;
        IORef TypeEnv
type_env_var <- case HscEnv -> Maybe (Module, IORef TypeEnv)
hsc_type_env_var HscEnv
hsc_env of {
                           Just (_mod :: Module
_mod, te_var :: IORef TypeEnv
te_var) -> IORef TypeEnv -> IO (IORef TypeEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return IORef TypeEnv
te_var ;
                           Nothing             -> TypeEnv -> IO (IORef TypeEnv)
forall a. a -> IO (IORef a)
newIORef TypeEnv
forall a. NameEnv a
emptyNameEnv } ;

        IORef [FilePath]
dependent_files_var <- [FilePath] -> IO (IORef [FilePath])
forall a. a -> IO (IORef a)
newIORef [] ;
        IORef WantedConstraints
static_wc_var       <- WantedConstraints -> IO (IORef WantedConstraints)
forall a. a -> IO (IORef a)
newIORef WantedConstraints
emptyWC ;
        IORef CostCentreState
cc_st_var           <- CostCentreState -> IO (IORef CostCentreState)
forall a. a -> IO (IORef a)
newIORef CostCentreState
newCostCentreState ;
        IORef [LHsDecl GhcPs]
th_topdecls_var      <- [LHsDecl GhcPs] -> IO (IORef [LHsDecl GhcPs])
forall a. a -> IO (IORef a)
newIORef [] ;
        IORef [(ForeignSrcLang, FilePath)]
th_foreign_files_var <- [(ForeignSrcLang, FilePath)]
-> IO (IORef [(ForeignSrcLang, FilePath)])
forall a. a -> IO (IORef a)
newIORef [] ;
        IORef NameSet
th_topnames_var      <- NameSet -> IO (IORef NameSet)
forall a. a -> IO (IORef a)
newIORef NameSet
emptyNameSet ;
        IORef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var <- [(TcLclEnv, ThModFinalizers)]
-> IO (IORef [(TcLclEnv, ThModFinalizers)])
forall a. a -> IO (IORef a)
newIORef [] ;
        IORef [FilePath]
th_coreplugins_var <- [FilePath] -> IO (IORef [FilePath])
forall a. a -> IO (IORef a)
newIORef [] ;
        IORef (Map TypeRep Dynamic)
th_state_var         <- Map TypeRep Dynamic -> IO (IORef (Map TypeRep Dynamic))
forall a. a -> IO (IORef a)
newIORef Map TypeRep Dynamic
forall k a. Map k a
Map.empty ;
        IORef (Maybe (ForeignRef (IORef QState)))
th_remote_state_var  <- Maybe (ForeignRef (IORef QState))
-> IO (IORef (Maybe (ForeignRef (IORef QState))))
forall a. a -> IO (IORef a)
newIORef Maybe (ForeignRef (IORef QState))
forall a. Maybe a
Nothing ;
        let {
             dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env ;

             maybe_rn_syntax :: forall a. a -> Maybe a ;
             maybe_rn_syntax :: a -> Maybe a
maybe_rn_syntax empty_val :: a
empty_val
                | DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_rn_ast DynFlags
dflags = a -> Maybe a
forall a. a -> Maybe a
Just a
empty_val

                | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags       = a -> Maybe a
forall a. a -> Maybe a
Just a
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'.
                | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Haddock DynFlags
dflags       = a -> Maybe a
forall a. a -> Maybe a
Just a
empty_val

                | Bool
keep_rn_syntax                = a -> Maybe a
forall a. a -> Maybe a
Just a
empty_val
                | Bool
otherwise                     = Maybe a
forall a. Maybe a
Nothing ;

             gbl_env :: TcGblEnv
gbl_env = $WTcGblEnv :: Module
-> Module
-> HscSource
-> GlobalRdrEnv
-> Maybe [Type]
-> FixityEnv
-> RecFieldEnv
-> TypeEnv
-> IORef TypeEnv
-> InstEnv
-> FamInstEnv
-> AnnEnv
-> [AvailInfo]
-> ImportAvails
-> DefUses
-> IORef [GlobalRdrElt]
-> IORef NameSet
-> IORef Bool
-> IORef Bool
-> IORef (Set RealSrcSpan)
-> IORef OccSet
-> [(Module, Fingerprint)]
-> Maybe [(Located (IE GhcRn), [AvailInfo])]
-> [LImportDecl GhcRn]
-> Maybe (HsGroup GhcRn)
-> IORef [FilePath]
-> IORef [LHsDecl GhcPs]
-> IORef [(ForeignSrcLang, FilePath)]
-> IORef NameSet
-> IORef [(TcLclEnv, ThModFinalizers)]
-> IORef [FilePath]
-> IORef (Map TypeRep Dynamic)
-> IORef (Maybe (ForeignRef (IORef QState)))
-> Bag EvBind
-> Maybe Id
-> LHsBinds GhcTc
-> NameSet
-> [LTcSpecPrag]
-> Warnings
-> [Annotation]
-> [TyCon]
-> [ClsInst]
-> [FamInst]
-> [LRuleDecl GhcTc]
-> [LForeignDecl GhcTc]
-> [PatSyn]
-> Maybe LHsDocString
-> Bool
-> SelfBootInfo
-> Maybe Name
-> IORef (Bool, Bag WarnMsg)
-> [TcPluginSolver]
-> RealSrcSpan
-> IORef WantedConstraints
-> [CompleteMatch]
-> IORef CostCentreState
-> TcGblEnv
TcGblEnv {
                tcg_th_topdecls :: IORef [LHsDecl GhcPs]
tcg_th_topdecls      = IORef [LHsDecl GhcPs]
th_topdecls_var,
                tcg_th_foreign_files :: IORef [(ForeignSrcLang, FilePath)]
tcg_th_foreign_files = IORef [(ForeignSrcLang, FilePath)]
th_foreign_files_var,
                tcg_th_topnames :: IORef NameSet
tcg_th_topnames      = IORef NameSet
th_topnames_var,
                tcg_th_modfinalizers :: IORef [(TcLclEnv, ThModFinalizers)]
tcg_th_modfinalizers = IORef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var,
                tcg_th_coreplugins :: IORef [FilePath]
tcg_th_coreplugins = IORef [FilePath]
th_coreplugins_var,
                tcg_th_state :: IORef (Map TypeRep Dynamic)
tcg_th_state         = IORef (Map TypeRep Dynamic)
th_state_var,
                tcg_th_remote_state :: IORef (Maybe (ForeignRef (IORef QState)))
tcg_th_remote_state  = IORef (Maybe (ForeignRef (IORef QState)))
th_remote_state_var,

                tcg_mod :: Module
tcg_mod            = Module
mod,
                tcg_semantic_mod :: Module
tcg_semantic_mod   =
                    DynFlags -> Module -> Module
canonicalizeModuleIfHome DynFlags
dflags Module
mod,
                tcg_src :: HscSource
tcg_src            = HscSource
hsc_src,
                tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env        = GlobalRdrEnv
emptyGlobalRdrEnv,
                tcg_fix_env :: FixityEnv
tcg_fix_env        = FixityEnv
forall a. NameEnv a
emptyNameEnv,
                tcg_field_env :: RecFieldEnv
tcg_field_env      = RecFieldEnv
forall a. NameEnv a
emptyNameEnv,
                tcg_default :: Maybe [Type]
tcg_default        = if Module -> UnitId
moduleUnitId Module
mod UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
primUnitId
                                     then [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just []  -- See Note [Default types]
                                     else Maybe [Type]
forall a. Maybe a
Nothing,
                tcg_type_env :: TypeEnv
tcg_type_env       = TypeEnv
forall a. NameEnv a
emptyNameEnv,
                tcg_type_env_var :: IORef TypeEnv
tcg_type_env_var   = IORef TypeEnv
type_env_var,
                tcg_inst_env :: InstEnv
tcg_inst_env       = InstEnv
emptyInstEnv,
                tcg_fam_inst_env :: FamInstEnv
tcg_fam_inst_env   = FamInstEnv
emptyFamInstEnv,
                tcg_ann_env :: AnnEnv
tcg_ann_env        = AnnEnv
emptyAnnEnv,
                tcg_th_used :: IORef Bool
tcg_th_used        = IORef Bool
th_var,
                tcg_th_splice_used :: IORef Bool
tcg_th_splice_used = IORef Bool
th_splice_var,
                tcg_th_top_level_locs :: IORef (Set RealSrcSpan)
tcg_th_top_level_locs
                                   = IORef (Set RealSrcSpan)
th_locs_var,
                tcg_exports :: [AvailInfo]
tcg_exports        = [],
                tcg_imports :: ImportAvails
tcg_imports        = ImportAvails
emptyImportAvails,
                tcg_used_gres :: IORef [GlobalRdrElt]
tcg_used_gres     = IORef [GlobalRdrElt]
used_gre_var,
                tcg_dus :: DefUses
tcg_dus            = DefUses
emptyDUs,

                tcg_rn_imports :: [LImportDecl GhcRn]
tcg_rn_imports     = [],
                tcg_rn_exports :: Maybe [(Located (IE GhcRn), [AvailInfo])]
tcg_rn_exports     =
                    if HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
                        -- Always retain renamed syntax, so that we can give
                        -- better errors.  (TODO: how?)
                        then [(Located (IE GhcRn), [AvailInfo])]
-> Maybe [(Located (IE GhcRn), [AvailInfo])]
forall a. a -> Maybe a
Just []
                        else [(Located (IE GhcRn), [AvailInfo])]
-> Maybe [(Located (IE GhcRn), [AvailInfo])]
forall a. a -> Maybe a
maybe_rn_syntax [],
                tcg_rn_decls :: Maybe (HsGroup GhcRn)
tcg_rn_decls       = HsGroup GhcRn -> Maybe (HsGroup GhcRn)
forall a. a -> Maybe a
maybe_rn_syntax HsGroup GhcRn
forall (p :: Pass). HsGroup (GhcPass p)
emptyRnGroup,
                tcg_tr_module :: Maybe Id
tcg_tr_module      = Maybe Id
forall a. Maybe a
Nothing,
                tcg_binds :: LHsBinds GhcTc
tcg_binds          = LHsBinds GhcTc
forall idL idR. LHsBindsLR idL idR
emptyLHsBinds,
                tcg_imp_specs :: [LTcSpecPrag]
tcg_imp_specs      = [],
                tcg_sigs :: NameSet
tcg_sigs           = NameSet
emptyNameSet,
                tcg_ev_binds :: Bag EvBind
tcg_ev_binds       = Bag EvBind
forall a. Bag a
emptyBag,
                tcg_warns :: Warnings
tcg_warns          = Warnings
NoWarnings,
                tcg_anns :: [Annotation]
tcg_anns           = [],
                tcg_tcs :: [TyCon]
tcg_tcs            = [],
                tcg_insts :: [ClsInst]
tcg_insts          = [],
                tcg_fam_insts :: [FamInst]
tcg_fam_insts      = [],
                tcg_rules :: [LRuleDecl GhcTc]
tcg_rules          = [],
                tcg_fords :: [LForeignDecl GhcTc]
tcg_fords          = [],
                tcg_patsyns :: [PatSyn]
tcg_patsyns        = [],
                tcg_merged :: [(Module, Fingerprint)]
tcg_merged         = [],
                tcg_dfun_n :: IORef OccSet
tcg_dfun_n         = IORef OccSet
dfun_n_var,
                tcg_keep :: IORef NameSet
tcg_keep           = IORef NameSet
keep_var,
                tcg_doc_hdr :: Maybe LHsDocString
tcg_doc_hdr        = Maybe LHsDocString
forall a. Maybe a
Nothing,
                tcg_hpc :: Bool
tcg_hpc            = Bool
False,
                tcg_main :: Maybe Name
tcg_main           = Maybe Name
forall a. Maybe a
Nothing,
                tcg_self_boot :: SelfBootInfo
tcg_self_boot      = SelfBootInfo
NoSelfBoot,
                tcg_safeInfer :: IORef (Bool, Bag WarnMsg)
tcg_safeInfer      = IORef (Bool, Bag WarnMsg)
infer_var,
                tcg_dependent_files :: IORef [FilePath]
tcg_dependent_files = IORef [FilePath]
dependent_files_var,
                tcg_tc_plugins :: [TcPluginSolver]
tcg_tc_plugins     = [],
                tcg_top_loc :: RealSrcSpan
tcg_top_loc        = RealSrcSpan
loc,
                tcg_static_wc :: IORef WantedConstraints
tcg_static_wc      = IORef WantedConstraints
static_wc_var,
                tcg_complete_matches :: [CompleteMatch]
tcg_complete_matches = [],
                tcg_cc_st :: IORef CostCentreState
tcg_cc_st          = IORef CostCentreState
cc_st_var
             } ;
        } ;

        -- OK, here's the business end!
        HscEnv
-> TcGblEnv -> RealSrcSpan -> TcM r -> IO (Messages, Maybe r)
forall r.
HscEnv
-> TcGblEnv -> RealSrcSpan -> TcM r -> IO (Messages, Maybe r)
initTcWithGbl HscEnv
hsc_env TcGblEnv
gbl_env RealSrcSpan
loc TcM r
do_this
    }

-- | Run a 'TcM' action in the context of an existing 'GblEnv'.
initTcWithGbl :: HscEnv
              -> TcGblEnv
              -> RealSrcSpan
              -> TcM r
              -> IO (Messages, Maybe r)
initTcWithGbl :: HscEnv
-> TcGblEnv -> RealSrcSpan -> TcM r -> IO (Messages, Maybe r)
initTcWithGbl hsc_env :: HscEnv
hsc_env gbl_env :: TcGblEnv
gbl_env loc :: RealSrcSpan
loc do_this :: TcM r
do_this
 = do { IORef VarSet
tvs_var      <- VarSet -> IO (IORef VarSet)
forall a. a -> IO (IORef a)
newIORef VarSet
emptyVarSet
      ; IORef WantedConstraints
lie_var      <- WantedConstraints -> IO (IORef WantedConstraints)
forall a. a -> IO (IORef a)
newIORef WantedConstraints
emptyWC
      ; IORef Messages
errs_var     <- Messages -> IO (IORef Messages)
forall a. a -> IO (IORef a)
newIORef (Bag WarnMsg
forall a. Bag a
emptyBag, Bag WarnMsg
forall a. Bag a
emptyBag)
      ; let lcl_env :: TcLclEnv
lcl_env = TcLclEnv :: RealSrcSpan
-> [ErrCtxt]
-> TcLevel
-> ThStage
-> ThBindEnv
-> ArrowCtxt
-> LocalRdrEnv
-> TcTypeEnv
-> TcBinderStack
-> IORef VarSet
-> IORef WantedConstraints
-> IORef Messages
-> TcLclEnv
TcLclEnv {
                tcl_errs :: IORef Messages
tcl_errs       = IORef Messages
errs_var,
                tcl_loc :: RealSrcSpan
tcl_loc        = RealSrcSpan
loc,     -- Should be over-ridden very soon!
                tcl_ctxt :: [ErrCtxt]
tcl_ctxt       = [],
                tcl_rdr :: LocalRdrEnv
tcl_rdr        = LocalRdrEnv
emptyLocalRdrEnv,
                tcl_th_ctxt :: ThStage
tcl_th_ctxt    = ThStage
topStage,
                tcl_th_bndrs :: ThBindEnv
tcl_th_bndrs   = ThBindEnv
forall a. NameEnv a
emptyNameEnv,
                tcl_arrow_ctxt :: ArrowCtxt
tcl_arrow_ctxt = ArrowCtxt
NoArrowCtxt,
                tcl_env :: TcTypeEnv
tcl_env        = TcTypeEnv
forall a. NameEnv a
emptyNameEnv,
                tcl_bndrs :: TcBinderStack
tcl_bndrs      = [],
                tcl_tyvars :: IORef VarSet
tcl_tyvars     = IORef VarSet
tvs_var,
                tcl_lie :: IORef WantedConstraints
tcl_lie        = IORef WantedConstraints
lie_var,
                tcl_tclvl :: TcLevel
tcl_tclvl      = TcLevel
topTcLevel
                }

      ; Maybe r
maybe_res <- Char
-> HscEnv
-> TcGblEnv
-> TcLclEnv
-> TcRnIf TcGblEnv TcLclEnv (Maybe r)
-> IO (Maybe r)
forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf 'a' HscEnv
hsc_env TcGblEnv
gbl_env TcLclEnv
lcl_env (TcRnIf TcGblEnv TcLclEnv (Maybe r) -> IO (Maybe r))
-> TcRnIf TcGblEnv TcLclEnv (Maybe r) -> IO (Maybe r)
forall a b. (a -> b) -> a -> b
$
                     do { Either IOEnvFailure r
r <- TcM r -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure r)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM TcM r
do_this
                        ; case Either IOEnvFailure r
r of
                          Right res :: r
res -> Maybe r -> TcRnIf TcGblEnv TcLclEnv (Maybe r)
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Maybe r
forall a. a -> Maybe a
Just r
res)
                          Left _    -> Maybe r -> TcRnIf TcGblEnv TcLclEnv (Maybe r)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe r
forall a. Maybe a
Nothing }

      -- 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)
      ; WantedConstraints
lie <- IORef WantedConstraints -> IO WantedConstraints
forall a. IORef a -> IO a
readIORef (TcLclEnv -> IORef WantedConstraints
tcl_lie TcLclEnv
lcl_env)
      ; Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe r -> Bool
forall a. Maybe a -> Bool
isJust Maybe r
maybe_res Bool -> Bool -> Bool
&& Bool -> Bool
not (WantedConstraints -> Bool
isEmptyWC WantedConstraints
lie)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> SDoc -> IO ()
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic "initTc: unsolved constraints" (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
lie)

        -- Collect any error messages
      ; Messages
msgs <- IORef Messages -> IO Messages
forall a. IORef a -> IO a
readIORef (TcLclEnv -> IORef Messages
tcl_errs TcLclEnv
lcl_env)

      ; let { final_res :: Maybe r
final_res | DynFlags -> Messages -> Bool
errorsFound DynFlags
dflags Messages
msgs = Maybe r
forall a. Maybe a
Nothing
                        | Bool
otherwise               = Maybe r
maybe_res }

      ; (Messages, Maybe r) -> IO (Messages, Maybe r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages
msgs, Maybe r
final_res)
      }
  where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
-- Initialise the type checker monad for use in GHCi
initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
initTcInteractive hsc_env :: HscEnv
hsc_env thing_inside :: TcM a
thing_inside
  = HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM a
-> IO (Messages, Maybe a)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages, Maybe r)
initTc HscEnv
hsc_env HscSource
HsSrcFile Bool
False
           (InteractiveContext -> Module
icInteractiveModule (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env))
           (RealSrcLoc -> RealSrcSpan
realSrcLocSpan RealSrcLoc
interactive_src_loc)
           TcM a
thing_inside
  where
    interactive_src_loc :: RealSrcLoc
interactive_src_loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
fsLit "<interactive>") 1 1

{- Note [Default types]
~~~~~~~~~~~~~~~~~~~~~~~
The Integer type is simply not available in package ghc-prim (it is
declared in integer-gmp).  So we set the defaulting types to (Just
[]), meaning there are no default types, rather then Nothing, which
means "use the default default types of Integer, Double".

If you don't do this, attempted defaulting in package ghc-prim causes
an actual crash (attempting to look up the Integer type).


************************************************************************
*                                                                      *
                Initialisation
*                                                                      *
************************************************************************
-}

initTcRnIf :: Char              -- Tag for unique supply
           -> HscEnv
           -> gbl -> lcl
           -> TcRnIf gbl lcl a
           -> IO a
initTcRnIf :: Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf uniq_tag :: Char
uniq_tag hsc_env :: HscEnv
hsc_env gbl_env :: gbl
gbl_env lcl_env :: lcl
lcl_env thing_inside :: TcRnIf gbl lcl a
thing_inside
   = do { UniqSupply
us     <- Char -> IO UniqSupply
mkSplitUniqSupply Char
uniq_tag ;
        ; IORef UniqSupply
us_var <- UniqSupply -> IO (IORef UniqSupply)
forall a. a -> IO (IORef a)
newIORef UniqSupply
us ;

        ; let { env :: Env gbl lcl
env = $WEnv :: forall gbl lcl.
HscEnv -> IORef UniqSupply -> gbl -> lcl -> Env gbl lcl
Env { env_top :: HscEnv
env_top = HscEnv
hsc_env,
                            env_us :: IORef UniqSupply
env_us  = IORef UniqSupply
us_var,
                            env_gbl :: gbl
env_gbl = gbl
gbl_env,
                            env_lcl :: lcl
env_lcl = lcl
lcl_env} }

        ; Env gbl lcl -> TcRnIf gbl lcl a -> IO a
forall env a. env -> IOEnv env a -> IO a
runIOEnv Env gbl lcl
env TcRnIf gbl lcl a
thing_inside
        }

{-
************************************************************************
*                                                                      *
                Simple accessors
*                                                                      *
************************************************************************
-}

discardResult :: TcM a -> TcM ()
discardResult :: TcM a -> TcM ()
discardResult a :: TcM a
a = TcM a
a TcM a -> TcM () -> TcM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

getTopEnv :: TcRnIf gbl lcl HscEnv
getTopEnv :: TcRnIf gbl lcl HscEnv
getTopEnv = do { Env gbl lcl
env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; HscEnv -> TcRnIf gbl lcl HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (Env gbl lcl -> HscEnv
forall gbl lcl. Env gbl lcl -> HscEnv
env_top Env gbl lcl
env) }

updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv upd :: HscEnv -> HscEnv
upd = (Env gbl lcl -> Env gbl lcl)
-> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\ env :: Env gbl lcl
env@(Env { env_top :: forall gbl lcl. Env gbl lcl -> HscEnv
env_top = HscEnv
top }) ->
                          Env gbl lcl
env { env_top :: HscEnv
env_top = HscEnv -> HscEnv
upd HscEnv
top })

getGblEnv :: TcRnIf gbl lcl gbl
getGblEnv :: TcRnIf gbl lcl gbl
getGblEnv = do { Env{..} <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; gbl -> TcRnIf gbl lcl gbl
forall (m :: * -> *) a. Monad m => a -> m a
return gbl
env_gbl }

updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv upd :: gbl -> gbl
upd = (Env gbl lcl -> Env gbl lcl)
-> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\ env :: Env gbl lcl
env@(Env { env_gbl :: forall gbl lcl. Env gbl lcl -> gbl
env_gbl = gbl
gbl }) ->
                          Env gbl lcl
env { env_gbl :: gbl
env_gbl = gbl -> gbl
upd gbl
gbl })

setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv gbl_env :: gbl
gbl_env = (Env gbl lcl -> Env gbl lcl)
-> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\ env :: Env gbl lcl
env -> Env gbl lcl
env { env_gbl :: gbl
env_gbl = gbl
gbl_env })

getLclEnv :: TcRnIf gbl lcl lcl
getLclEnv :: TcRnIf gbl lcl lcl
getLclEnv = do { Env{..} <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; lcl -> TcRnIf gbl lcl lcl
forall (m :: * -> *) a. Monad m => a -> m a
return lcl
env_lcl }

updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv upd :: lcl -> lcl
upd = (Env gbl lcl -> Env gbl lcl)
-> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\ env :: Env gbl lcl
env@(Env { env_lcl :: forall gbl lcl. Env gbl lcl -> lcl
env_lcl = lcl
lcl }) ->
                          Env gbl lcl
env { env_lcl :: lcl
env_lcl = lcl -> lcl
upd lcl
lcl })

setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv lcl_env :: lcl'
lcl_env = (Env gbl lcl -> Env gbl lcl')
-> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\ env :: Env gbl lcl
env -> Env gbl lcl
env { env_lcl :: lcl'
env_lcl = lcl'
lcl_env })

getEnvs :: TcRnIf gbl lcl (gbl, lcl)
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
getEnvs = do { Env gbl lcl
env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; (gbl, lcl) -> TcRnIf gbl lcl (gbl, lcl)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env gbl lcl -> gbl
forall gbl lcl. Env gbl lcl -> gbl
env_gbl Env gbl lcl
env, Env gbl lcl -> lcl
forall gbl lcl. Env gbl lcl -> lcl
env_lcl Env gbl lcl
env) }

setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (gbl_env :: gbl'
gbl_env, lcl_env :: lcl'
lcl_env) = (Env gbl lcl -> Env gbl' lcl')
-> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\ env :: Env gbl lcl
env -> Env gbl lcl
env { env_gbl :: gbl'
env_gbl = gbl'
gbl_env, env_lcl :: lcl'
env_lcl = lcl'
lcl_env })

-- Command-line flags

xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
xoptM :: Extension -> TcRnIf gbl lcl Bool
xoptM flag :: Extension
flag = do { DynFlags
dflags <- IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags; Bool -> TcRnIf gbl lcl Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Extension -> DynFlags -> Bool
xopt Extension
flag DynFlags
dflags) }

doptM :: DumpFlag -> TcRnIf gbl lcl Bool
doptM :: DumpFlag -> TcRnIf gbl lcl Bool
doptM flag :: DumpFlag
flag = do { DynFlags
dflags <- IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags; Bool -> TcRnIf gbl lcl Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
flag DynFlags
dflags) }

goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
goptM flag :: GeneralFlag
flag = do { DynFlags
dflags <- IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags; Bool -> TcRnIf gbl lcl Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
flag DynFlags
dflags) }

woptM :: WarningFlag -> TcRnIf gbl lcl Bool
woptM :: WarningFlag -> TcRnIf gbl lcl Bool
woptM flag :: WarningFlag
flag = do { DynFlags
dflags <- IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags; Bool -> TcRnIf gbl lcl Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
flag DynFlags
dflags) }

setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM :: Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM flag :: Extension
flag =
  (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv (\top :: HscEnv
top -> HscEnv
top { hsc_dflags :: DynFlags
hsc_dflags = DynFlags -> Extension -> DynFlags
xopt_set (HscEnv -> DynFlags
hsc_dflags HscEnv
top) Extension
flag})

unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetXOptM :: Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetXOptM flag :: Extension
flag =
  (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv (\top :: HscEnv
top -> HscEnv
top { hsc_dflags :: DynFlags
hsc_dflags = DynFlags -> Extension -> DynFlags
xopt_unset (HscEnv -> DynFlags
hsc_dflags HscEnv
top) Extension
flag})

unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM flag :: GeneralFlag
flag =
  (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv (\top :: HscEnv
top -> HscEnv
top { hsc_dflags :: DynFlags
hsc_dflags = DynFlags -> GeneralFlag -> DynFlags
gopt_unset (HscEnv -> DynFlags
hsc_dflags HscEnv
top) GeneralFlag
flag})

unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM flag :: WarningFlag
flag =
  (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv (\top :: HscEnv
top -> HscEnv
top { hsc_dflags :: DynFlags
hsc_dflags = DynFlags -> WarningFlag -> DynFlags
wopt_unset (HscEnv -> DynFlags
hsc_dflags HscEnv
top) WarningFlag
flag})

-- | Do it flag is true
whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM flag :: DumpFlag
flag thing_inside :: TcRnIf gbl lcl ()
thing_inside = do Bool
b <- DumpFlag -> TcRnIf gbl lcl Bool
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
flag
                                 Bool -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b TcRnIf gbl lcl ()
thing_inside

whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenGOptM flag :: GeneralFlag
flag thing_inside :: TcRnIf gbl lcl ()
thing_inside = do Bool
b <- GeneralFlag -> TcRnIf gbl lcl Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
flag
                                 Bool -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b TcRnIf gbl lcl ()
thing_inside

whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM flag :: WarningFlag
flag thing_inside :: TcRnIf gbl lcl ()
thing_inside = do Bool
b <- WarningFlag -> TcRnIf gbl lcl Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
flag
                                 Bool -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b TcRnIf gbl lcl ()
thing_inside

whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenXOptM :: Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenXOptM flag :: Extension
flag thing_inside :: TcRnIf gbl lcl ()
thing_inside = do Bool
b <- Extension -> TcRnIf gbl lcl Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
flag
                                 Bool -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b TcRnIf gbl lcl ()
thing_inside

unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM :: Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM flag :: Extension
flag thing_inside :: TcRnIf gbl lcl ()
thing_inside = do Bool
b <- Extension -> TcRnIf gbl lcl Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
flag
                                   Bool -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b TcRnIf gbl lcl ()
thing_inside

getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = do { HscEnv
env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; GhcMode -> TcRnIf gbl lcl GhcMode
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
env)) }

withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withDoDynamicToo =
  (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv (\top :: HscEnv
top@(HscEnv { hsc_dflags :: HscEnv -> DynFlags
hsc_dflags = DynFlags
dflags }) ->
              HscEnv
top { hsc_dflags :: DynFlags
hsc_dflags = DynFlags -> DynFlags
dynamicTooMkDynamicDynFlags DynFlags
dflags })

getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar = do { HscEnv
env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; TcRef ExternalPackageState
-> TcRnIf gbl lcl (TcRef ExternalPackageState)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv -> TcRef ExternalPackageState
hsc_EPS HscEnv
env) }

getEps :: TcRnIf gbl lcl ExternalPackageState
getEps :: TcRnIf gbl lcl ExternalPackageState
getEps = do { HscEnv
env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; TcRef ExternalPackageState -> TcRnIf gbl lcl ExternalPackageState
forall a env. IORef a -> IOEnv env a
readMutVar (HscEnv -> TcRef ExternalPackageState
hsc_EPS HscEnv
env) }

-- | Update the external package state.  Returns the second result of the
-- modifier function.
--
-- This is an atomic operation and forces evaluation of the modified EPS in
-- order to avoid space leaks.
updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
          -> TcRnIf gbl lcl a
updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
-> TcRnIf gbl lcl a
updateEps upd_fn :: ExternalPackageState -> (ExternalPackageState, a)
upd_fn = do
  SDoc -> TcRnIf gbl lcl ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
text "updating EPS")
  TcRef ExternalPackageState
eps_var <- TcRnIf gbl lcl (TcRef ExternalPackageState)
forall gbl lcl. TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar
  TcRef ExternalPackageState
-> (ExternalPackageState -> (ExternalPackageState, a))
-> TcRnIf gbl lcl a
forall a b env. IORef a -> (a -> (a, b)) -> IOEnv env b
atomicUpdMutVar' TcRef ExternalPackageState
eps_var ExternalPackageState -> (ExternalPackageState, a)
upd_fn

-- | Update the external package state.
--
-- This is an atomic operation and forces evaluation of the modified EPS in
-- order to avoid space leaks.
updateEps_ :: (ExternalPackageState -> ExternalPackageState)
           -> TcRnIf gbl lcl ()
updateEps_ :: (ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl ()
updateEps_ upd_fn :: ExternalPackageState -> ExternalPackageState
upd_fn = do
  SDoc -> TcRnIf gbl lcl ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
text "updating EPS_")
  TcRef ExternalPackageState
eps_var <- TcRnIf gbl lcl (TcRef ExternalPackageState)
forall gbl lcl. TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar
  TcRef ExternalPackageState
-> (ExternalPackageState -> (ExternalPackageState, ()))
-> TcRnIf gbl lcl ()
forall a b env. IORef a -> (a -> (a, b)) -> IOEnv env b
atomicUpdMutVar' TcRef ExternalPackageState
eps_var (\eps :: ExternalPackageState
eps -> (ExternalPackageState -> ExternalPackageState
upd_fn ExternalPackageState
eps, ()))

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { HscEnv
env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; HomePackageTable -> TcRnIf gbl lcl HomePackageTable
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv -> HomePackageTable
hsc_HPT HscEnv
env) }

getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
getEpsAndHpt = do { HscEnv
env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; ExternalPackageState
eps <- TcRef ExternalPackageState
-> IOEnv (Env gbl lcl) ExternalPackageState
forall a env. IORef a -> IOEnv env a
readMutVar (HscEnv -> TcRef ExternalPackageState
hsc_EPS HscEnv
env)
                  ; (ExternalPackageState, HomePackageTable)
-> TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExternalPackageState
eps, HscEnv -> HomePackageTable
hsc_HPT HscEnv
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 :: TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a
withException do_this :: TcRnIf gbl lcl (MaybeErr SDoc a)
do_this = do
    MaybeErr SDoc a
r <- TcRnIf gbl lcl (MaybeErr SDoc a)
do_this
    DynFlags
dflags <- IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    case MaybeErr SDoc a
r of
        Failed err :: SDoc
err -> IO a -> TcRnIf gbl lcl a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> TcRnIf gbl lcl a) -> IO a -> TcRnIf gbl lcl a
forall a b. (a -> b) -> a -> b
$ GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
ProgramError (DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags SDoc
err))
        Succeeded result :: a
result -> a -> TcRnIf gbl lcl a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

{-
************************************************************************
*                                                                      *
                Arrow scopes
*                                                                      *
************************************************************************
-}

newArrowScope :: TcM a -> TcM a
newArrowScope :: TcM a -> TcM a
newArrowScope
  = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv ((TcLclEnv -> TcLclEnv) -> TcM a -> TcM a)
-> (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$ \env :: TcLclEnv
env -> TcLclEnv
env { tcl_arrow_ctxt :: ArrowCtxt
tcl_arrow_ctxt = LocalRdrEnv -> IORef WantedConstraints -> ArrowCtxt
ArrowCtxt (TcLclEnv -> LocalRdrEnv
tcl_rdr TcLclEnv
env) (TcLclEnv -> IORef WantedConstraints
tcl_lie TcLclEnv
env) }

-- Return to the stored environment (from the enclosing proc)
escapeArrowScope :: TcM a -> TcM a
escapeArrowScope :: TcM a -> TcM a
escapeArrowScope
  = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv ((TcLclEnv -> TcLclEnv) -> TcM a -> TcM a)
-> (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$ \ env :: TcLclEnv
env ->
    case TcLclEnv -> ArrowCtxt
tcl_arrow_ctxt TcLclEnv
env of
      NoArrowCtxt       -> TcLclEnv
env
      ArrowCtxt rdr_env :: LocalRdrEnv
rdr_env lie :: IORef WantedConstraints
lie -> TcLclEnv
env { tcl_arrow_ctxt :: ArrowCtxt
tcl_arrow_ctxt = ArrowCtxt
NoArrowCtxt
                                   , tcl_lie :: IORef WantedConstraints
tcl_lie = IORef WantedConstraints
lie
                                   , tcl_rdr :: LocalRdrEnv
tcl_rdr = LocalRdrEnv
rdr_env }

{-
************************************************************************
*                                                                      *
                Unique supply
*                                                                      *
************************************************************************
-}

newUnique :: TcRnIf gbl lcl Unique
newUnique :: TcRnIf gbl lcl Unique
newUnique
 = do { Env gbl lcl
env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv ;
        let { u_var :: IORef UniqSupply
u_var = Env gbl lcl -> IORef UniqSupply
forall gbl lcl. Env gbl lcl -> IORef UniqSupply
env_us Env gbl lcl
env } ;
        UniqSupply
us <- IORef UniqSupply -> IOEnv (Env gbl lcl) UniqSupply
forall a env. IORef a -> IOEnv env a
readMutVar IORef UniqSupply
u_var ;
        case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us of { (uniq :: Unique
uniq, us' :: UniqSupply
us') -> do {
        IORef UniqSupply -> UniqSupply -> IOEnv (Env gbl lcl) ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef UniqSupply
u_var UniqSupply
us' ;
        Unique -> TcRnIf gbl lcl Unique
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> TcRnIf gbl lcl Unique)
-> Unique -> TcRnIf gbl lcl Unique
forall a b. (a -> b) -> a -> b
$! Unique
uniq }}}
   -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
   -- a chain of unevaluated supplies behind.
   -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
   -- throw away one half of the new split supply.  This is safe because this
   -- is the only place we use that unique.  Using the other half of the split
   -- supply is safer, but slower.

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { Env gbl lcl
env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv ;
        let { u_var :: IORef UniqSupply
u_var = Env gbl lcl -> IORef UniqSupply
forall gbl lcl. Env gbl lcl -> IORef UniqSupply
env_us Env gbl lcl
env } ;
        UniqSupply
us <- IORef UniqSupply -> TcRnIf gbl lcl UniqSupply
forall a env. IORef a -> IOEnv env a
readMutVar IORef UniqSupply
u_var ;
        case UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us of { (us1 :: UniqSupply
us1,us2 :: UniqSupply
us2) -> do {
        IORef UniqSupply -> UniqSupply -> IOEnv (Env gbl lcl) ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef UniqSupply
u_var UniqSupply
us1 ;
        UniqSupply -> TcRnIf gbl lcl UniqSupply
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSupply
us2 }}}

cloneLocalName :: Name -> TcM Name
-- Make a fresh Internal name with the same OccName and SrcSpan
cloneLocalName :: Name -> TcM Name
cloneLocalName name :: Name
name = OccName -> SrcSpan -> TcM Name
newNameAt (Name -> OccName
nameOccName Name
name) (Name -> SrcSpan
nameSrcSpan Name
name)

newName :: OccName -> TcM Name
newName :: OccName -> TcM Name
newName occ :: OccName
occ = do { SrcSpan
loc  <- TcRn SrcSpan
getSrcSpanM
                 ; OccName -> SrcSpan -> TcM Name
newNameAt OccName
occ SrcSpan
loc }

newNameAt :: OccName -> SrcSpan -> TcM Name
newNameAt :: OccName -> SrcSpan -> TcM Name
newNameAt occ :: OccName
occ span :: SrcSpan
span
  = do { Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
       ; Name -> TcM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
span) }

newSysName :: OccName -> TcRnIf gbl lcl Name
newSysName :: OccName -> TcRnIf gbl lcl Name
newSysName occ :: OccName
occ
  = do { Unique
uniq <- TcRnIf gbl lcl Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
       ; Name -> TcRnIf gbl lcl Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> OccName -> Name
mkSystemName Unique
uniq OccName
occ) }

newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
newSysLocalId :: FastString -> Type -> TcRnIf gbl lcl Id
newSysLocalId fs :: FastString
fs ty :: Type
ty
  = do  { Unique
u <- TcRnIf gbl lcl Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
        ; Id -> TcRnIf gbl lcl Id
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> Unique -> Type -> Id
mkSysLocalOrCoVar FastString
fs Unique
u Type
ty) }

newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds :: FastString -> [Type] -> TcRnIf gbl lcl [Id]
newSysLocalIds fs :: FastString
fs tys :: [Type]
tys
  = do  { UniqSupply
us <- TcRnIf gbl lcl UniqSupply
forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
        ; [Id] -> TcRnIf gbl lcl [Id]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Unique -> Type -> Id) -> [Unique] -> [Type] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (FastString -> Unique -> Type -> Id
mkSysLocalOrCoVar FastString
fs) (UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us) [Type]
tys) }

instance MonadUnique (IOEnv (Env gbl lcl)) where
        getUniqueM :: IOEnv (Env gbl lcl) Unique
getUniqueM = IOEnv (Env gbl lcl) Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
        getUniqueSupplyM :: IOEnv (Env gbl lcl) UniqSupply
getUniqueSupplyM = IOEnv (Env gbl lcl) UniqSupply
forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply

{-
************************************************************************
*                                                                      *
                Accessing input/output
*                                                                      *
************************************************************************
-}

newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
newTcRef = a -> TcRnIf gbl lcl (TcRef a)
forall a env. a -> IOEnv env (IORef a)
newMutVar

readTcRef :: TcRef a -> TcRnIf gbl lcl a
readTcRef :: TcRef a -> TcRnIf gbl lcl a
readTcRef = TcRef a -> TcRnIf gbl lcl a
forall a env. IORef a -> IOEnv env a
readMutVar

writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef = TcRef a -> a -> TcRnIf gbl lcl ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar

updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
-- Returns ()
updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef ref :: TcRef a
ref fn :: a -> a
fn = IO () -> TcRnIf gbl lcl ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TcRnIf gbl lcl ()) -> IO () -> TcRnIf gbl lcl ()
forall a b. (a -> b) -> a -> b
$ do { a
old <- TcRef a -> IO a
forall a. IORef a -> IO a
readIORef TcRef a
ref
                              ; TcRef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef TcRef a
ref (a -> a
fn a
old) }

{-
************************************************************************
*                                                                      *
                Debugging
*                                                                      *
************************************************************************
-}


-- Typechecker trace
traceTc :: String -> SDoc -> TcRn ()
traceTc :: FilePath -> SDoc -> TcM ()
traceTc =
  DumpFlag -> FilePath -> SDoc -> TcM ()
labelledTraceOptTcRn DumpFlag
Opt_D_dump_tc_trace

-- Renamer Trace
traceRn :: String -> SDoc -> TcRn ()
traceRn :: FilePath -> SDoc -> TcM ()
traceRn =
  DumpFlag -> FilePath -> SDoc -> TcM ()
labelledTraceOptTcRn DumpFlag
Opt_D_dump_rn_trace

-- | 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 :: DumpFlag -> FilePath -> SDoc -> TcM ()
labelledTraceOptTcRn flag :: DumpFlag
flag herald :: FilePath
herald doc :: SDoc
doc = do
   DumpFlag -> SDoc -> TcM ()
traceOptTcRn DumpFlag
flag (FilePath -> SDoc -> SDoc
formatTraceMsg FilePath
herald SDoc
doc)

formatTraceMsg :: String -> SDoc -> SDoc
formatTraceMsg :: FilePath -> SDoc -> SDoc
formatTraceMsg herald :: FilePath
herald doc :: SDoc
doc = SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
text FilePath
herald) 2 SDoc
doc

-- | Output a doc if the given 'DumpFlag' is set.
--
-- By default this logs to stdout
-- However, if the `-ddump-to-file` flag is set,
-- then this will dump output to a file
--
-- Just a wrapper for 'dumpSDoc'
traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
traceOptTcRn :: DumpFlag -> SDoc -> TcM ()
traceOptTcRn flag :: DumpFlag
flag doc :: SDoc
doc
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
flag DynFlags
dflags)
              (DumpFlag -> SDoc -> TcM ()
traceTcRn DumpFlag
flag SDoc
doc)
       }

-- Certain tests (T3017, Roles3, T12763 etc.) expect part of the
-- output generated by `-ddump-types` to be in 'PprUser' style. However,
-- generally we want all other debugging output to use 'PprDump'
-- style. 'traceTcRn' and 'traceTcRnForUser' help us accomplish this.

-- | A wrapper around 'traceTcRnWithStyle' which uses 'PprDump' style.
traceTcRn :: DumpFlag -> SDoc -> TcRn ()
traceTcRn :: DumpFlag -> SDoc -> TcM ()
traceTcRn flag :: DumpFlag
flag doc :: SDoc
doc
  = do { DynFlags
dflags  <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; PrintUnqualified
printer <- DynFlags -> TcRn PrintUnqualified
getPrintUnqualified DynFlags
dflags
       ; let dump_style :: PprStyle
dump_style = DynFlags -> PrintUnqualified -> PprStyle
mkDumpStyle DynFlags
dflags PrintUnqualified
printer
       ; PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcM ()
traceTcRnWithStyle PprStyle
dump_style DynFlags
dflags DumpFlag
flag SDoc
doc }

-- | A wrapper around 'traceTcRnWithStyle' which uses 'PprUser' style.
traceTcRnForUser :: DumpFlag -> SDoc -> TcRn ()
-- Used by 'TcRnDriver.tcDump'.
traceTcRnForUser :: DumpFlag -> SDoc -> TcM ()
traceTcRnForUser flag :: DumpFlag
flag doc :: SDoc
doc
  = do { DynFlags
dflags  <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; PrintUnqualified
printer <- DynFlags -> TcRn PrintUnqualified
getPrintUnqualified DynFlags
dflags
       ; let user_style :: PprStyle
user_style = DynFlags -> PrintUnqualified -> Depth -> PprStyle
mkUserStyle DynFlags
dflags PrintUnqualified
printer Depth
AllTheWay
       ; PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcM ()
traceTcRnWithStyle PprStyle
user_style DynFlags
dflags DumpFlag
flag SDoc
doc }

traceTcRnWithStyle :: PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcRn ()
-- ^ Unconditionally dump some trace output
--
-- The DumpFlag is used only to set the output filename
-- for --dump-to-file, not to decide whether or not to output
-- That part is done by the caller
traceTcRnWithStyle :: PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcM ()
traceTcRnWithStyle sty :: PprStyle
sty dflags :: DynFlags
dflags flag :: DumpFlag
flag doc :: SDoc
doc
  = do { SDoc
real_doc <- DynFlags -> SDoc -> TcRn SDoc
prettyDoc DynFlags
dflags SDoc
doc
       ; IO () -> TcM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TcM ()) -> IO () -> TcM ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> DynFlags -> DumpFlag -> FilePath -> SDoc -> IO ()
dumpSDocWithStyle PprStyle
sty DynFlags
dflags DumpFlag
flag "" SDoc
real_doc }
  where
    -- Add current location if -dppr-debug
    prettyDoc :: DynFlags -> SDoc -> TcRn SDoc
    prettyDoc :: DynFlags -> SDoc -> TcRn SDoc
prettyDoc dflags :: DynFlags
dflags doc :: SDoc
doc = if DynFlags -> Bool
hasPprDebug DynFlags
dflags
       then do { SrcSpan
loc  <- TcRn SrcSpan
getSrcSpanM; SDoc -> TcRn SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> TcRn SDoc) -> SDoc -> TcRn SDoc
forall a b. (a -> b) -> a -> b
$ Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage Severity
SevOutput SrcSpan
loc SDoc
doc }
       else SDoc -> TcRn SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
doc -- The full location is usually way too much


getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
getPrintUnqualified dflags :: DynFlags
dflags
  = do { GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; PrintUnqualified -> TcRn PrintUnqualified
forall (m :: * -> *) a. Monad m => a -> m a
return (PrintUnqualified -> TcRn PrintUnqualified)
-> PrintUnqualified -> TcRn PrintUnqualified
forall a b. (a -> b) -> a -> b
$ DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified DynFlags
dflags GlobalRdrEnv
rdr_env }

-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
printForUserTcRn :: SDoc -> TcM ()
printForUserTcRn doc :: SDoc
doc
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; PrintUnqualified
printer <- DynFlags -> TcRn PrintUnqualified
getPrintUnqualified DynFlags
dflags
       ; IO () -> TcM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (DynFlags -> PrintUnqualified -> SDoc -> IO ()
printOutputForUser DynFlags
dflags PrintUnqualified
printer SDoc
doc) }

{-
traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
available.  Alas, they behave inconsistently with the other stuff;
e.g. are unaffected by -dump-to-file.
-}

traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
traceIf :: SDoc -> TcRnIf m n ()
traceIf      = DumpFlag -> SDoc -> TcRnIf m n ()
forall m n. DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf DumpFlag
Opt_D_dump_if_trace
traceHiDiffs :: SDoc -> TcRnIf m n ()
traceHiDiffs = DumpFlag -> SDoc -> TcRnIf m n ()
forall m n. DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf DumpFlag
Opt_D_dump_hi_diffs


traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf flag :: DumpFlag
flag doc :: SDoc
doc
  = DumpFlag -> TcRnIf m n () -> TcRnIf m n ()
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
flag (TcRnIf m n () -> TcRnIf m n ()) -> TcRnIf m n () -> TcRnIf m n ()
forall a b. (a -> b) -> a -> b
$    -- No RdrEnv available, so qualify everything
    do { DynFlags
dflags <- IOEnv (Env m n) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; IO () -> TcRnIf m n ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags SDoc
doc) }

{-
************************************************************************
*                                                                      *
                Typechecker global environment
*                                                                      *
************************************************************************
-}

getIsGHCi :: TcRn Bool
getIsGHCi :: TcRn Bool
getIsGHCi = do { Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
               ; Bool -> TcRn Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> Bool
isInteractiveModule Module
mod) }

getGHCiMonad :: TcRn Name
getGHCiMonad :: TcM Name
getGHCiMonad = do { HscEnv
hsc <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; Name -> TcM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (InteractiveContext -> Name
ic_monad (InteractiveContext -> Name) -> InteractiveContext -> Name
forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc) }

getInteractivePrintName :: TcRn Name
getInteractivePrintName :: TcM Name
getInteractivePrintName = do { HscEnv
hsc <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; Name -> TcM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (InteractiveContext -> Name
ic_int_print (InteractiveContext -> Name) -> InteractiveContext -> Name
forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc) }

tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; Bool -> TcRn Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (HscSource -> Bool
isHsBootOrSig (TcGblEnv -> HscSource
tcg_src TcGblEnv
env)) }

tcIsHsig :: TcRn Bool
tcIsHsig :: TcRn Bool
tcIsHsig = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; Bool -> TcRn Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (HscSource -> Bool
isHsigFile (TcGblEnv -> HscSource
tcg_src TcGblEnv
env)) }

tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; SelfBootInfo -> TcRn SelfBootInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> SelfBootInfo
tcg_self_boot TcGblEnv
env) }

getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; GlobalRdrEnv -> TcRn GlobalRdrEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
env) }

getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl :: TcGblEnv
gbl,lcl :: TcLclEnv
lcl) <- TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs; (GlobalRdrEnv, LocalRdrEnv) -> TcRn (GlobalRdrEnv, LocalRdrEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
gbl, TcLclEnv -> LocalRdrEnv
tcl_rdr TcLclEnv
lcl) }

getImports :: TcRn ImportAvails
getImports :: TcRn ImportAvails
getImports = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; ImportAvails -> TcRn ImportAvails
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
env) }

getFixityEnv :: TcRn FixityEnv
getFixityEnv :: TcRn FixityEnv
getFixityEnv = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; FixityEnv -> TcRn FixityEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> FixityEnv
tcg_fix_env TcGblEnv
env) }

extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
extendFixityEnv :: [(Name, FixItem)] -> RnM a -> RnM a
extendFixityEnv new_bit :: [(Name, FixItem)]
new_bit
  = (TcGblEnv -> TcGblEnv) -> RnM a -> RnM a
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\env :: TcGblEnv
env@(TcGblEnv { tcg_fix_env :: TcGblEnv -> FixityEnv
tcg_fix_env = FixityEnv
old_fix_env }) ->
                TcGblEnv
env {tcg_fix_env :: FixityEnv
tcg_fix_env = FixityEnv -> [(Name, FixItem)] -> FixityEnv
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList FixityEnv
old_fix_env [(Name, FixItem)]
new_bit})

getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; RecFieldEnv -> TcRn RecFieldEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> RecFieldEnv
tcg_field_env TcGblEnv
env) }

getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; Maybe [Type] -> TcRn (Maybe [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> Maybe [Type]
tcg_default TcGblEnv
env) }

addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles :: [FilePath] -> TcM ()
addDependentFiles fs :: [FilePath]
fs = do
  IORef [FilePath]
ref <- (TcGblEnv -> IORef [FilePath])
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (IORef [FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> IORef [FilePath]
tcg_dependent_files TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
  [FilePath]
dep_files <- IORef [FilePath] -> TcRnIf TcGblEnv TcLclEnv [FilePath]
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef [FilePath]
ref
  IORef [FilePath] -> [FilePath] -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef [FilePath]
ref ([FilePath]
fs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
dep_files)

{-
************************************************************************
*                                                                      *
                Error management
*                                                                      *
************************************************************************
-}

getSrcSpanM :: TcRn SrcSpan
        -- Avoid clash with Name.getSrcLoc
getSrcSpanM :: TcRn SrcSpan
getSrcSpanM = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; SrcSpan -> TcRn SrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> SrcSpan
RealSrcSpan (TcLclEnv -> RealSrcSpan
tcl_loc TcLclEnv
env)) }

setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan (RealSrcSpan real_loc :: RealSrcSpan
real_loc) thing_inside :: TcRn a
thing_inside
    = (TcLclEnv -> TcLclEnv) -> TcRn a -> TcRn a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\env :: TcLclEnv
env -> TcLclEnv
env { tcl_loc :: RealSrcSpan
tcl_loc = RealSrcSpan
real_loc }) TcRn a
thing_inside
-- Don't overwrite useful info with useless:
setSrcSpan (UnhelpfulSpan _) thing_inside :: TcRn a
thing_inside = TcRn a
thing_inside

addLocM :: HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM :: (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM fn :: SrcSpanLess a -> TcM b
fn (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc a :: SrcSpanLess a
a) = SrcSpan -> TcM b -> TcM b
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM b -> TcM b) -> TcM b -> TcM b
forall a b. (a -> b) -> a -> b
$ SrcSpanLess a -> TcM b
fn SrcSpanLess a
a

wrapLocM :: (HasSrcSpan a, HasSrcSpan b) =>
            (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
-- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM :: (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
wrapLocM fn :: SrcSpanLess a -> TcM (SrcSpanLess b)
fn (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc a :: SrcSpanLess a
a) = SrcSpan -> TcM b -> TcM b
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM b -> TcM b) -> TcM b -> TcM b
forall a b. (a -> b) -> a -> b
$ do { SrcSpanLess b
b <- SrcSpanLess a -> TcM (SrcSpanLess b)
fn SrcSpanLess a
a
                                                ; b -> TcM b
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess b -> b
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess b
b) }
wrapLocFstM :: (HasSrcSpan a, HasSrcSpan b) =>
               (SrcSpanLess a -> TcM (SrcSpanLess b,c)) -> a -> TcM (b, c)
wrapLocFstM :: (SrcSpanLess a -> TcM (SrcSpanLess b, c)) -> a -> TcM (b, c)
wrapLocFstM fn :: SrcSpanLess a -> TcM (SrcSpanLess b, c)
fn (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc a :: SrcSpanLess a
a) =
  SrcSpan -> TcM (b, c) -> TcM (b, c)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (b, c) -> TcM (b, c)) -> TcM (b, c) -> TcM (b, c)
forall a b. (a -> b) -> a -> b
$ do
    (b :: SrcSpanLess b
b,c :: c
c) <- SrcSpanLess a -> TcM (SrcSpanLess b, c)
fn SrcSpanLess a
a
    (b, c) -> TcM (b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess b -> b
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess b
b, c
c)

wrapLocSndM :: (HasSrcSpan a, HasSrcSpan c) =>
               (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c)
wrapLocSndM :: (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c)
wrapLocSndM fn :: SrcSpanLess a -> TcM (b, SrcSpanLess c)
fn (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc a :: SrcSpanLess a
a) =
  SrcSpan -> TcM (b, c) -> TcM (b, c)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (b, c) -> TcM (b, c)) -> TcM (b, c) -> TcM (b, c)
forall a b. (a -> b) -> a -> b
$ do
    (b :: b
b,c :: SrcSpanLess c
c) <- SrcSpanLess a -> TcM (b, SrcSpanLess c)
fn SrcSpanLess a
a
    (b, c) -> TcM (b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, SrcSpan -> SrcSpanLess c -> c
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess c
c)

wrapLocM_ :: HasSrcSpan a =>
             (SrcSpanLess a -> TcM ()) -> a -> TcM ()
wrapLocM_ :: (SrcSpanLess a -> TcM ()) -> a -> TcM ()
wrapLocM_ fn :: SrcSpanLess a -> TcM ()
fn (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc a :: SrcSpanLess a
a) = SrcSpan -> TcM () -> TcM ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (SrcSpanLess a -> TcM ()
fn SrcSpanLess a
a)

-- Reporting errors

getErrsVar :: TcRn (TcRef Messages)
getErrsVar :: TcRn (IORef Messages)
getErrsVar = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; IORef Messages -> TcRn (IORef Messages)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> IORef Messages
tcl_errs TcLclEnv
env) }

setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
setErrsVar :: IORef Messages -> TcRn a -> TcRn a
setErrsVar v :: IORef Messages
v = (TcLclEnv -> TcLclEnv) -> TcRn a -> TcRn a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ env :: TcLclEnv
env -> TcLclEnv
env { tcl_errs :: IORef Messages
tcl_errs =  IORef Messages
v })

addErr :: MsgDoc -> TcRn ()
addErr :: SDoc -> TcM ()
addErr msg :: SDoc
msg = do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM; SrcSpan -> SDoc -> TcM ()
addErrAt SrcSpan
loc SDoc
msg }

failWith :: MsgDoc -> TcRn a
failWith :: SDoc -> TcRn a
failWith msg :: SDoc
msg = SDoc -> TcM ()
addErr SDoc
msg TcM () -> TcRn a -> TcRn a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TcRn a
forall env a. IOEnv env a
failM

failAt :: SrcSpan -> MsgDoc -> TcRn a
failAt :: SrcSpan -> SDoc -> TcRn a
failAt loc :: SrcSpan
loc msg :: SDoc
msg = SrcSpan -> SDoc -> TcM ()
addErrAt SrcSpan
loc SDoc
msg TcM () -> TcRn a -> TcRn a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TcRn a
forall env a. IOEnv env a
failM

addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
-- addErrAt is mainly (exclusively?) used by the renamer, where
-- tidying is not an issue, but it's all lazy so the extra
-- work doesn't matter
addErrAt :: SrcSpan -> SDoc -> TcM ()
addErrAt loc :: SrcSpan
loc msg :: SDoc
msg = do { [ErrCtxt]
ctxt <- TcM [ErrCtxt]
getErrCtxt
                      ; TidyEnv
tidy_env <- TcM TidyEnv
tcInitTidyEnv
                      ; SDoc
err_info <- TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo TidyEnv
tidy_env [ErrCtxt]
ctxt
                      ; SrcSpan -> SDoc -> SDoc -> TcM ()
addLongErrAt SrcSpan
loc SDoc
msg SDoc
err_info }

addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
addErrs :: [(SrcSpan, SDoc)] -> TcM ()
addErrs msgs :: [(SrcSpan, SDoc)]
msgs = ((SrcSpan, SDoc) -> TcM ()) -> [(SrcSpan, SDoc)] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SrcSpan, SDoc) -> TcM ()
add [(SrcSpan, SDoc)]
msgs
             where
               add :: (SrcSpan, SDoc) -> TcM ()
add (loc :: SrcSpan
loc,msg :: SDoc
msg) = SrcSpan -> SDoc -> TcM ()
addErrAt SrcSpan
loc SDoc
msg

checkErr :: Bool -> MsgDoc -> TcRn ()
-- Add the error if the bool is False
checkErr :: Bool -> SDoc -> TcM ()
checkErr ok :: Bool
ok msg :: SDoc
msg = Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (SDoc -> TcM ()
addErr SDoc
msg)

addMessages :: Messages -> TcRn ()
addMessages :: Messages -> TcM ()
addMessages msgs1 :: Messages
msgs1
  = do { IORef Messages
errs_var <- TcRn (IORef Messages)
getErrsVar ;
         Messages
msgs0 <- IORef Messages -> TcRnIf TcGblEnv TcLclEnv Messages
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef Messages
errs_var ;
         IORef Messages -> Messages -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef Messages
errs_var (Messages -> Messages -> Messages
unionMessages Messages
msgs0 Messages
msgs1) }

discardWarnings :: TcRn a -> TcRn a
-- Ignore warnings inside the thing inside;
-- used to ignore-unused-variable warnings inside derived code
discardWarnings :: TcRn a -> TcRn a
discardWarnings thing_inside :: TcRn a
thing_inside
  = do  { IORef Messages
errs_var <- TcRn (IORef Messages)
getErrsVar
        ; (old_warns :: Bag WarnMsg
old_warns, _) <- IORef Messages -> TcRnIf TcGblEnv TcLclEnv Messages
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef Messages
errs_var

        ; a
result <- TcRn a
thing_inside

        -- Revert warnings to old_warns
        ; (_new_warns :: Bag WarnMsg
_new_warns, new_errs :: Bag WarnMsg
new_errs) <- IORef Messages -> TcRnIf TcGblEnv TcLclEnv Messages
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef Messages
errs_var
        ; IORef Messages -> Messages -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef Messages
errs_var (Bag WarnMsg
old_warns, Bag WarnMsg
new_errs)

        ; a -> TcRn a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result }

{-
************************************************************************
*                                                                      *
        Shared error message stuff: renamer and typechecker
*                                                                      *
************************************************************************
-}

mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn WarnMsg
mkLongErrAt loc :: SrcSpan
loc msg :: SDoc
msg extra :: SDoc
extra
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags ;
         PrintUnqualified
printer <- DynFlags -> TcRn PrintUnqualified
getPrintUnqualified DynFlags
dflags ;
         WarnMsg -> TcRn WarnMsg
forall (m :: * -> *) a. Monad m => a -> m a
return (WarnMsg -> TcRn WarnMsg) -> WarnMsg -> TcRn WarnMsg
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> WarnMsg
mkLongErrMsg DynFlags
dflags SrcSpan
loc PrintUnqualified
printer SDoc
msg SDoc
extra }

mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn WarnMsg
mkErrDocAt loc :: SrcSpan
loc errDoc :: ErrDoc
errDoc
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags ;
         PrintUnqualified
printer <- DynFlags -> TcRn PrintUnqualified
getPrintUnqualified DynFlags
dflags ;
         WarnMsg -> TcRn WarnMsg
forall (m :: * -> *) a. Monad m => a -> m a
return (WarnMsg -> TcRn WarnMsg) -> WarnMsg -> TcRn WarnMsg
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> WarnMsg
mkErrDoc DynFlags
dflags SrcSpan
loc PrintUnqualified
printer ErrDoc
errDoc }

addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcM ()
addLongErrAt loc :: SrcSpan
loc msg :: SDoc
msg extra :: SDoc
extra = SrcSpan -> SDoc -> SDoc -> TcRn WarnMsg
mkLongErrAt SrcSpan
loc SDoc
msg SDoc
extra TcRn WarnMsg -> (WarnMsg -> TcM ()) -> TcM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WarnMsg -> TcM ()
reportError

reportErrors :: [ErrMsg] -> TcM ()
reportErrors :: [WarnMsg] -> TcM ()
reportErrors = (WarnMsg -> TcM ()) -> [WarnMsg] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ WarnMsg -> TcM ()
reportError

reportError :: ErrMsg -> TcRn ()
reportError :: WarnMsg -> TcM ()
reportError err :: WarnMsg
err
  = do { FilePath -> SDoc -> TcM ()
traceTc "Adding error:" (WarnMsg -> SDoc
pprLocErrMsg WarnMsg
err) ;
         IORef Messages
errs_var <- TcRn (IORef Messages)
getErrsVar ;
         (warns :: Bag WarnMsg
warns, errs :: Bag WarnMsg
errs) <- IORef Messages -> TcRnIf TcGblEnv TcLclEnv Messages
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef Messages
errs_var ;
         IORef Messages -> Messages -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef Messages
errs_var (Bag WarnMsg
warns, Bag WarnMsg
errs Bag WarnMsg -> WarnMsg -> Bag WarnMsg
forall a. Bag a -> a -> Bag a
`snocBag` WarnMsg
err) }

reportWarning :: WarnReason -> ErrMsg -> TcRn ()
reportWarning :: WarnReason -> WarnMsg -> TcM ()
reportWarning reason :: WarnReason
reason err :: WarnMsg
err
  = do { let warn :: WarnMsg
warn = WarnReason -> WarnMsg -> WarnMsg
makeIntoWarning WarnReason
reason WarnMsg
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

       ; FilePath -> SDoc -> TcM ()
traceTc "Adding warning:" (WarnMsg -> SDoc
pprLocErrMsg WarnMsg
warn)
       ; IORef Messages
errs_var <- TcRn (IORef Messages)
getErrsVar
       ; (warns :: Bag WarnMsg
warns, errs :: Bag WarnMsg
errs) <- IORef Messages -> TcRnIf TcGblEnv TcLclEnv Messages
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef Messages
errs_var
       ; IORef Messages -> Messages -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef Messages
errs_var (Bag WarnMsg
warns Bag WarnMsg -> WarnMsg -> Bag WarnMsg
forall a. Bag a -> a -> Bag a
`snocBag` WarnMsg
warn, Bag WarnMsg
errs) }


-----------------------
checkNoErrs :: TcM r -> TcM r
-- (checkNoErrs m) succeeds iff m succeeds and generates no errors
-- If m fails then (checkNoErrsTc m) fails.
-- If m succeeds, it checks whether m generated any errors messages
--      (it might have recovered internally)
--      If so, it fails too.
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs :: TcM r -> TcM r
checkNoErrs main :: TcM r
main
  = do  { (res :: r
res, no_errs :: Bool
no_errs) <- TcM r -> TcRn (r, Bool)
forall a. TcRn a -> TcRn (a, Bool)
askNoErrs TcM r
main
        ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
no_errs TcM ()
forall env a. IOEnv env a
failM
        ; r -> TcM r
forall (m :: * -> *) a. Monad m => a -> m a
return r
res }

-----------------------
whenNoErrs :: TcM () -> TcM ()
whenNoErrs :: TcM () -> TcM ()
whenNoErrs thing :: TcM ()
thing = TcM () -> TcM () -> TcM ()
forall r. TcRn r -> TcRn r -> TcRn r
ifErrsM (() -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) TcM ()
thing

ifErrsM :: TcRn r -> TcRn r -> TcRn r
--      ifErrsM bale_out normal
-- does 'bale_out' if there are errors in errors collection
-- otherwise does 'normal'
ifErrsM :: TcRn r -> TcRn r -> TcRn r
ifErrsM bale_out :: TcRn r
bale_out normal :: TcRn r
normal
 = do { IORef Messages
errs_var <- TcRn (IORef Messages)
getErrsVar ;
        Messages
msgs <- IORef Messages -> TcRnIf TcGblEnv TcLclEnv Messages
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef Messages
errs_var ;
        DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags ;
        if DynFlags -> Messages -> Bool
errorsFound DynFlags
dflags Messages
msgs then
           TcRn r
bale_out
        else
           TcRn r
normal }

failIfErrsM :: TcRn ()
-- Useful to avoid error cascades
failIfErrsM :: TcM ()
failIfErrsM = TcM () -> TcM () -> TcM ()
forall r. TcRn r -> TcRn r -> TcRn r
ifErrsM TcM ()
forall env a. IOEnv env a
failM (() -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

checkTH :: a -> String -> TcRn ()
checkTH :: a -> FilePath -> TcM ()
checkTH _ _ = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- OK

failTH :: Outputable a => a -> String -> TcRn x
failTH :: a -> FilePath -> TcRn x
failTH e :: a
e what :: FilePath
what  -- Raise an error in a stage-1 compiler
  = SDoc -> TcRn x
forall a. SDoc -> TcM a
failWithTc ([SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (Char -> SDoc
char 'A' SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
what
                             SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text "requires GHC with interpreter support:")
                          2 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
e)
                     , FilePath -> SDoc
text "Perhaps you are using a stage-1 compiler?" ])


{- *********************************************************************
*                                                                      *
        Context management for the type checker
*                                                                      *
************************************************************************
-}

getErrCtxt :: TcM [ErrCtxt]
getErrCtxt :: TcM [ErrCtxt]
getErrCtxt = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; [ErrCtxt] -> TcM [ErrCtxt]
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> [ErrCtxt]
tcl_ctxt TcLclEnv
env) }

setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
setErrCtxt ctxt :: [ErrCtxt]
ctxt = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ env :: TcLclEnv
env -> TcLclEnv
env { tcl_ctxt :: [ErrCtxt]
tcl_ctxt = [ErrCtxt]
ctxt })

-- | Add a fixed message to the error context. This message should not
-- do any tidying.
addErrCtxt :: MsgDoc -> TcM a -> TcM a
addErrCtxt :: SDoc -> TcM a -> TcM a
addErrCtxt msg :: SDoc
msg = (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM (\env :: TidyEnv
env -> (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, SDoc
msg))

-- | Add a message to the error context. This message may do tidying.
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM ctxt :: TidyEnv -> TcM (TidyEnv, SDoc)
ctxt = ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
forall a. ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
updCtxt (\ ctxts :: [ErrCtxt]
ctxts -> (Bool
False, TidyEnv -> TcM (TidyEnv, SDoc)
ctxt) ErrCtxt -> [ErrCtxt] -> [ErrCtxt]
forall a. a -> [a] -> [a]
: [ErrCtxt]
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 :: SDoc -> TcM a -> TcM a
addLandmarkErrCtxt msg :: SDoc
msg = (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM (\env :: TidyEnv
env -> (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, SDoc
msg))

-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
-- and tidying.
addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM ctxt :: TidyEnv -> TcM (TidyEnv, SDoc)
ctxt = ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
forall a. ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
updCtxt (\ctxts :: [ErrCtxt]
ctxts -> (Bool
True, TidyEnv -> TcM (TidyEnv, SDoc)
ctxt) ErrCtxt -> [ErrCtxt] -> [ErrCtxt]
forall a. a -> [a] -> [a]
: [ErrCtxt]
ctxts)

-- Helper function for the above
updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
updCtxt upd :: [ErrCtxt] -> [ErrCtxt]
upd = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ env :: TcLclEnv
env@(TcLclEnv { tcl_ctxt :: TcLclEnv -> [ErrCtxt]
tcl_ctxt = [ErrCtxt]
ctxt }) ->
                           TcLclEnv
env { tcl_ctxt :: [ErrCtxt]
tcl_ctxt = [ErrCtxt] -> [ErrCtxt]
upd [ErrCtxt]
ctxt })

popErrCtxt :: TcM a -> TcM a
popErrCtxt :: TcM a -> TcM a
popErrCtxt = ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
forall a. ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
updCtxt (\ msgs :: [ErrCtxt]
msgs -> case [ErrCtxt]
msgs of { [] -> []; (_ : ms :: [ErrCtxt]
ms) -> [ErrCtxt]
ms })

getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM origin :: CtOrigin
origin t_or_k :: Maybe TypeOrKind
t_or_k
  = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; CtLoc -> TcM CtLoc
forall (m :: * -> *) a. Monad m => a -> m a
return ($WCtLoc :: CtOrigin -> TcLclEnv -> Maybe TypeOrKind -> SubGoalDepth -> CtLoc
CtLoc { ctl_origin :: CtOrigin
ctl_origin = CtOrigin
origin
                       , ctl_env :: TcLclEnv
ctl_env    = TcLclEnv
env
                       , ctl_t_or_k :: Maybe TypeOrKind
ctl_t_or_k = Maybe TypeOrKind
t_or_k
                       , ctl_depth :: SubGoalDepth
ctl_depth  = SubGoalDepth
initialSubGoalDepth }) }

setCtLocM :: CtLoc -> TcM a -> TcM a
-- Set the SrcSpan and error context from the CtLoc
setCtLocM :: CtLoc -> TcM a -> TcM a
setCtLocM (CtLoc { ctl_env :: CtLoc -> TcLclEnv
ctl_env = TcLclEnv
lcl }) thing_inside :: TcM a
thing_inside
  = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\env :: TcLclEnv
env -> TcLclEnv
env { tcl_loc :: RealSrcSpan
tcl_loc   = TcLclEnv -> RealSrcSpan
tcl_loc TcLclEnv
lcl
                           , tcl_bndrs :: TcBinderStack
tcl_bndrs = TcLclEnv -> TcBinderStack
tcl_bndrs TcLclEnv
lcl
                           , tcl_ctxt :: [ErrCtxt]
tcl_ctxt  = TcLclEnv -> [ErrCtxt]
tcl_ctxt TcLclEnv
lcl })
              TcM a
thing_inside


{- *********************************************************************
*                                                                      *
             Error recovery and exceptions
*                                                                      *
********************************************************************* -}

tcTryM :: TcRn r -> TcRn (Maybe r)
-- The most basic function: catch the exception
--   Nothing => an exception happened
--   Just r  => no exception, result R
-- Errors and constraints are propagated in both cases
-- Never throws an exception
tcTryM :: TcRn r -> TcRn (Maybe r)
tcTryM thing_inside :: TcRn r
thing_inside
  = do { Either IOEnvFailure r
either_res <- TcRn r -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure r)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM TcRn r
thing_inside
       ; Maybe r -> TcRn (Maybe r)
forall (m :: * -> *) a. Monad m => a -> m a
return (case Either IOEnvFailure r
either_res of
                    Left _  -> Maybe r
forall a. Maybe a
Nothing
                    Right r :: r
r -> r -> Maybe r
forall a. a -> Maybe a
Just r
r) }
         -- In the Left case the exception is always the IOEnv
         -- built-in in exception; see IOEnv.failM

-----------------------
capture_constraints :: TcM r -> TcM (r, WantedConstraints)
-- capture_constraints simply captures and returns the
--                     constraints generated by thing_inside
-- Precondition: thing_inside must not throw an exception!
-- Reason for precondition: an exception would blow past the place
-- where we read the lie_var, and we'd lose the constraints altogether
capture_constraints :: TcM r -> TcM (r, WantedConstraints)
capture_constraints thing_inside :: TcM r
thing_inside
  = do { IORef WantedConstraints
lie_var <- WantedConstraints
-> TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef WantedConstraints
emptyWC
       ; r
res <- (TcLclEnv -> TcLclEnv) -> TcM r -> TcM r
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ env :: TcLclEnv
env -> TcLclEnv
env { tcl_lie :: IORef WantedConstraints
tcl_lie = IORef WantedConstraints
lie_var }) (TcM r -> TcM r) -> TcM r -> TcM r
forall a b. (a -> b) -> a -> b
$
                TcM r
thing_inside
       ; WantedConstraints
lie <- IORef WantedConstraints
-> TcRnIf TcGblEnv TcLclEnv WantedConstraints
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef WantedConstraints
lie_var
       ; (r, WantedConstraints) -> TcM (r, WantedConstraints)
forall (m :: * -> *) a. Monad m => a -> m a
return (r
res, WantedConstraints
lie) }

capture_messages :: TcM r -> TcM (r, Messages)
-- capture_messages simply captures and returns the
--                  errors arnd warnings generated by thing_inside
-- Precondition: thing_inside must not throw an exception!
-- Reason for precondition: an exception would blow past the place
-- where we read the msg_var, and we'd lose the constraints altogether
capture_messages :: TcM r -> TcM (r, Messages)
capture_messages thing_inside :: TcM r
thing_inside
  = do { IORef Messages
msg_var <- Messages -> TcRn (IORef Messages)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef Messages
emptyMessages
       ; r
res     <- IORef Messages -> TcM r -> TcM r
forall a. IORef Messages -> TcRn a -> TcRn a
setErrsVar IORef Messages
msg_var TcM r
thing_inside
       ; Messages
msgs    <- IORef Messages -> TcRnIf TcGblEnv TcLclEnv Messages
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef Messages
msg_var
       ; (r, Messages) -> TcM (r, Messages)
forall (m :: * -> *) a. Monad m => a -> m a
return (r
res, Messages
msgs) }

-----------------------
-- (askNoErrs m) runs m
-- If m fails,
--    then (askNoErrs m) fails, propagating only
--         insoluble constraints
--
-- 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 :: TcRn a -> TcRn (a, Bool)
askNoErrs thing_inside :: TcRn a
thing_inside
  = do { ((mb_res :: Maybe a
mb_res, lie :: WantedConstraints
lie), msgs :: Messages
msgs) <- TcM (Maybe a, WantedConstraints)
-> TcM ((Maybe a, WantedConstraints), Messages)
forall r. TcM r -> TcM (r, Messages)
capture_messages    (TcM (Maybe a, WantedConstraints)
 -> TcM ((Maybe a, WantedConstraints), Messages))
-> TcM (Maybe a, WantedConstraints)
-> TcM ((Maybe a, WantedConstraints), Messages)
forall a b. (a -> b) -> a -> b
$
                                  TcM (Maybe a) -> TcM (Maybe a, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints (TcM (Maybe a) -> TcM (Maybe a, WantedConstraints))
-> TcM (Maybe a) -> TcM (Maybe a, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                                  TcRn a -> TcM (Maybe a)
forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcRn a
thing_inside
       ; Messages -> TcM ()
addMessages Messages
msgs

       ; case Maybe a
mb_res of
           Nothing  -> do { WantedConstraints -> TcM ()
emitConstraints (WantedConstraints -> WantedConstraints
insolublesOnly WantedConstraints
lie)
                          ; TcRn (a, Bool)
forall env a. IOEnv env a
failM }

           Just res :: a
res -> do { WantedConstraints -> TcM ()
emitConstraints WantedConstraints
lie
                          ; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                          ; let errs_found :: Bool
errs_found = DynFlags -> Messages -> Bool
errorsFound DynFlags
dflags Messages
msgs
                                          Bool -> Bool -> Bool
|| WantedConstraints -> Bool
insolubleWC WantedConstraints
lie
                          ; (a, Bool) -> TcRn (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, Bool -> Bool
not Bool
errs_found) } }

-----------------------
tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints)
-- (tryCaptureConstraints_maybe m) runs m,
--   and returns the type constraints it generates
-- It never throws an exception; instead if thing_inside fails,
--   it returns Nothing and the /insoluble/ constraints
-- Error messages are propagated
tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints thing_inside :: TcM a
thing_inside
  = do { (mb_res :: Maybe a
mb_res, lie :: WantedConstraints
lie) <- TcM (Maybe a) -> TcM (Maybe a, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints (TcM (Maybe a) -> TcM (Maybe a, WantedConstraints))
-> TcM (Maybe a) -> TcM (Maybe a, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                          TcM a -> TcM (Maybe a)
forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcM a
thing_inside

       -- See Note [Constraints and errors]
       ; let lie_to_keep :: WantedConstraints
lie_to_keep = case Maybe a
mb_res of
                             Nothing -> WantedConstraints -> WantedConstraints
insolublesOnly WantedConstraints
lie
                             Just {} -> WantedConstraints
lie

       ; (Maybe a, WantedConstraints) -> TcM (Maybe a, WantedConstraints)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
mb_res, WantedConstraints
lie_to_keep) }

captureConstraints :: TcM a -> TcM (a, WantedConstraints)
-- (captureConstraints m) runs m, and returns the type constraints it generates
-- If thing_inside fails (throwing an exception),
--   then (captureConstraints thing_inside) fails too
--   propagating the insoluble constraints only
-- Error messages are propagated in either case
captureConstraints :: TcM a -> TcM (a, WantedConstraints)
captureConstraints thing_inside :: TcM a
thing_inside
  = do { (mb_res :: Maybe a
mb_res, lie :: WantedConstraints
lie) <- TcM a -> TcM (Maybe a, WantedConstraints)
forall a. TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints TcM a
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 Maybe a
mb_res of
           Nothing  -> do { WantedConstraints -> TcM ()
emitConstraints WantedConstraints
lie; TcM (a, WantedConstraints)
forall env a. IOEnv env a
failM }
           Just res :: a
res -> (a, WantedConstraints) -> TcM (a, WantedConstraints)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, WantedConstraints
lie) }

-----------------------
attemptM :: TcRn r -> TcRn (Maybe r)
-- (attemptM thing_inside) runs thing_inside
-- If thing_inside succeeds, returning r,
--   we return (Just r), and propagate all constraints and errors
-- If thing_inside fail, throwing an exception,
--   we return Nothing, propagating insoluble constraints,
--                      and all errors
-- attemptM never throws an exception
attemptM :: TcRn r -> TcRn (Maybe r)
attemptM thing_inside :: TcRn r
thing_inside
  = do { (mb_r :: Maybe r
mb_r, lie :: WantedConstraints
lie) <- TcRn r -> TcM (Maybe r, WantedConstraints)
forall a. TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints TcRn r
thing_inside
       ; WantedConstraints -> TcM ()
emitConstraints WantedConstraints
lie

       -- Debug trace
       ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe r -> Bool
forall a. Maybe a -> Bool
isNothing Maybe r
mb_r) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
         FilePath -> SDoc -> TcM ()
traceTc "attemptM recovering with insoluble constraints" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
                 (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
lie)

       ; Maybe r -> TcRn (Maybe r)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe r
mb_r }

-----------------------
recoverM :: TcRn r      -- Recovery action; do this if the main one fails
         -> TcRn r      -- Main action: do this first;
                        --  if it generates errors, propagate them all
         -> TcRn r
-- (recoverM recover thing_inside) runs thing_inside
-- If thing_inside fails, propagate its errors and insoluble constraints
--                        and run 'recover'
-- If thing_inside succeeds, propagate all its errors and constraints
--
-- Can fail, if 'recover' fails
recoverM :: TcRn r -> TcRn r -> TcRn r
recoverM recover :: TcRn r
recover thing :: TcRn r
thing
  = do { Maybe r
mb_res <- TcRn r -> TcRn (Maybe r)
forall r. TcRn r -> TcRn (Maybe r)
attemptM TcRn r
thing ;
         case Maybe r
mb_res of
           Nothing  -> TcRn r
recover
           Just res :: r
res -> r -> TcRn r
forall (m :: * -> *) a. Monad m => a -> m a
return r
res }

-----------------------

-- | Drop elements of the input that fail, so the result
-- list can be shorter than the argument list
mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM f :: a -> TcRn b
f xs :: [a]
xs
  = do { [Maybe b]
mb_rs <- (a -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b))
-> [a] -> IOEnv (Env TcGblEnv TcLclEnv) [Maybe b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcRn b -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b)
forall r. TcRn r -> TcRn (Maybe r)
attemptM (TcRn b -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b))
-> (a -> TcRn b) -> a -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TcRn b
f) [a]
xs
       ; [b] -> TcRn [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [b
r | Just r :: b
r <- [Maybe b]
mb_rs] }

-- | Apply the function to all elements on the input list
-- If all succeed, return the list of results
-- Othewise fail, propagating all errors
mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM f :: a -> TcRn b
f xs :: [a]
xs
  = do { [Maybe b]
mb_rs <- (a -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b))
-> [a] -> IOEnv (Env TcGblEnv TcLclEnv) [Maybe b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcRn b -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b)
forall r. TcRn r -> TcRn (Maybe r)
attemptM (TcRn b -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b))
-> (a -> TcRn b) -> a -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TcRn b
f) [a]
xs
       ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Maybe b -> Bool) -> [Maybe b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe b -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe b]
mb_rs) TcM ()
forall env a. IOEnv env a
failM
       ; [b] -> TcRn [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [b
r | Just r :: b
r <- [Maybe b]
mb_rs] }

-- | The accumulator is not updated if the action fails
foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM _ acc :: b
acc []     = b -> TcRn b
forall (m :: * -> *) a. Monad m => a -> m a
return b
acc
foldAndRecoverM f :: b -> a -> TcRn b
f acc :: b
acc (x :: a
x:xs :: [a]
xs) =
                          do { Maybe b
mb_r <- TcRn b -> TcRn (Maybe b)
forall r. TcRn r -> TcRn (Maybe r)
attemptM (b -> a -> TcRn b
f b
acc a
x)
                             ; case Maybe b
mb_r of
                                Nothing   -> (b -> a -> TcRn b) -> b -> [a] -> TcRn b
forall b a. (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM b -> a -> TcRn b
f b
acc [a]
xs
                                Just acc' :: b
acc' -> (b -> a -> TcRn b) -> b -> [a] -> TcRn b
forall b a. (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM b -> a -> TcRn b
f b
acc' [a]
xs  }

-----------------------
tryTc :: TcRn a -> TcRn (Maybe a, Messages)
-- (tryTc m) executes m, and returns
--      Just r,  if m succeeds (returning r)
--      Nothing, if m fails
-- It also returns all the errors and warnings accumulated by m
-- It always succeeds (never raises an exception)
tryTc :: TcRn a -> TcRn (Maybe a, Messages)
tryTc thing_inside :: TcRn a
thing_inside
 = TcM (Maybe a) -> TcRn (Maybe a, Messages)
forall r. TcM r -> TcM (r, Messages)
capture_messages (TcRn a -> TcM (Maybe a)
forall r. TcRn r -> TcRn (Maybe r)
attemptM TcRn a
thing_inside)

-----------------------
discardErrs :: TcRn a -> TcRn a
-- (discardErrs m) runs m,
--   discarding all error messages and warnings generated by m
-- If m fails, discardErrs fails, and vice versa
discardErrs :: TcRn a -> TcRn a
discardErrs m :: TcRn a
m
 = do { IORef Messages
errs_var <- Messages -> TcRn (IORef Messages)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef Messages
emptyMessages
      ; IORef Messages -> TcRn a -> TcRn a
forall a. IORef Messages -> TcRn a -> TcRn a
setErrsVar IORef Messages
errs_var TcRn a
m }

-----------------------
tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
-- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside';
--      if 'main' succeeds with no error messages, it's the answer
--      otherwise discard everything from 'main', including errors,
--          and try 'recover' instead.
tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
tryTcDiscardingErrs recover :: TcM r
recover thing_inside :: TcM r
thing_inside
  = do { ((mb_res :: Maybe r
mb_res, lie :: WantedConstraints
lie), msgs :: Messages
msgs) <- TcM (Maybe r, WantedConstraints)
-> TcM ((Maybe r, WantedConstraints), Messages)
forall r. TcM r -> TcM (r, Messages)
capture_messages    (TcM (Maybe r, WantedConstraints)
 -> TcM ((Maybe r, WantedConstraints), Messages))
-> TcM (Maybe r, WantedConstraints)
-> TcM ((Maybe r, WantedConstraints), Messages)
forall a b. (a -> b) -> a -> b
$
                                  TcM (Maybe r) -> TcM (Maybe r, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints (TcM (Maybe r) -> TcM (Maybe r, WantedConstraints))
-> TcM (Maybe r) -> TcM (Maybe r, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                                  TcM r -> TcM (Maybe r)
forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcM r
thing_inside
        ; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; case Maybe r
mb_res of
            Just res :: r
res | Bool -> Bool
not (DynFlags -> Messages -> Bool
errorsFound DynFlags
dflags Messages
msgs)
                     , Bool -> Bool
not (WantedConstraints -> Bool
insolubleWC WantedConstraints
lie)
              -> -- 'main' succeeed with no errors
                 do { Messages -> TcM ()
addMessages Messages
msgs  -- msgs might still have warnings
                    ; WantedConstraints -> TcM ()
emitConstraints WantedConstraints
lie
                    ; r -> TcM r
forall (m :: * -> *) a. Monad m => a -> m a
return r
res }

            _ -> -- 'main' failed, or produced an error message
                 TcM r
recover     -- Discard all errors and warnings
                             -- and unsolved constraints entirely
        }

{-
************************************************************************
*                                                                      *
             Error message generation (type checker)
*                                                                      *
************************************************************************

    The addErrTc functions add an error message, but do not cause failure.
    The 'M' variants pass a TidyEnv that has already been used to
    tidy up the message; we then use it to tidy the context messages
-}

addErrTc :: MsgDoc -> TcM ()
addErrTc :: SDoc -> TcM ()
addErrTc err_msg :: SDoc
err_msg = do { TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
                      ; (TidyEnv, SDoc) -> TcM ()
addErrTcM (TidyEnv
env0, SDoc
err_msg) }

addErrsTc :: [MsgDoc] -> TcM ()
addErrsTc :: [SDoc] -> TcM ()
addErrsTc err_msgs :: [SDoc]
err_msgs = (SDoc -> TcM ()) -> [SDoc] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SDoc -> TcM ()
addErrTc [SDoc]
err_msgs

addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
addErrTcM :: (TidyEnv, SDoc) -> TcM ()
addErrTcM (tidy_env :: TidyEnv
tidy_env, err_msg :: SDoc
err_msg)
  = do { [ErrCtxt]
ctxt <- TcM [ErrCtxt]
getErrCtxt ;
         SrcSpan
loc  <- TcRn SrcSpan
getSrcSpanM ;
         TidyEnv -> SDoc -> SrcSpan -> [ErrCtxt] -> TcM ()
add_err_tcm TidyEnv
tidy_env SDoc
err_msg SrcSpan
loc [ErrCtxt]
ctxt }

-- Return the error message, instead of reporting it straight away
mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
mkErrTcM :: (TidyEnv, SDoc) -> TcRn WarnMsg
mkErrTcM (tidy_env :: TidyEnv
tidy_env, err_msg :: SDoc
err_msg)
  = do { [ErrCtxt]
ctxt <- TcM [ErrCtxt]
getErrCtxt ;
         SrcSpan
loc  <- TcRn SrcSpan
getSrcSpanM ;
         SDoc
err_info <- TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo TidyEnv
tidy_env [ErrCtxt]
ctxt ;
         SrcSpan -> SDoc -> SDoc -> TcRn WarnMsg
mkLongErrAt SrcSpan
loc SDoc
err_msg SDoc
err_info }

mkErrTc :: MsgDoc -> TcM ErrMsg
mkErrTc :: SDoc -> TcRn WarnMsg
mkErrTc msg :: SDoc
msg = do { TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
                 ; (TidyEnv, SDoc) -> TcRn WarnMsg
mkErrTcM (TidyEnv
env0, SDoc
msg) }

-- The failWith functions add an error message and cause failure

failWithTc :: MsgDoc -> TcM a               -- Add an error message and fail
failWithTc :: SDoc -> TcM a
failWithTc err_msg :: SDoc
err_msg
  = SDoc -> TcM ()
addErrTc SDoc
err_msg TcM () -> TcM a -> TcM a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TcM a
forall env a. IOEnv env a
failM

failWithTcM :: (TidyEnv, MsgDoc) -> TcM a   -- Add an error message and fail
failWithTcM :: (TidyEnv, SDoc) -> TcM a
failWithTcM local_and_msg :: (TidyEnv, SDoc)
local_and_msg
  = (TidyEnv, SDoc) -> TcM ()
addErrTcM (TidyEnv, SDoc)
local_and_msg TcM () -> TcM a -> TcM a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TcM a
forall env a. IOEnv env a
failM

checkTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is true
checkTc :: Bool -> SDoc -> TcM ()
checkTc True  _   = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkTc False err :: SDoc
err = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc SDoc
err

checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
checkTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()
checkTcM True  _   = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkTcM False err :: (TidyEnv, SDoc)
err = (TidyEnv, SDoc) -> TcM ()
forall a. (TidyEnv, SDoc) -> TcM a
failWithTcM (TidyEnv, SDoc)
err

failIfTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is false
failIfTc :: Bool -> SDoc -> TcM ()
failIfTc False _   = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
failIfTc True  err :: SDoc
err = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc SDoc
err

failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
   -- Check that the boolean is false
failIfTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()
failIfTcM False _   = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
failIfTcM True  err :: (TidyEnv, SDoc)
err = (TidyEnv, SDoc) -> TcM ()
forall a. (TidyEnv, SDoc) -> TcM a
failWithTcM (TidyEnv, SDoc)
err


--         Warnings have no 'M' variant, nor failure

-- | Display a warning if a condition is met,
--   and the warning is enabled
warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()
warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcM ()
warnIfFlag warn_flag :: WarningFlag
warn_flag is_bad :: Bool
is_bad msg :: SDoc
msg
  = do { Bool
warn_on <- WarningFlag -> TcRn Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
warn_flag
       ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn_on Bool -> Bool -> Bool
&& Bool
is_bad) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
         WarnReason -> SDoc -> TcM ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
warn_flag) SDoc
msg }

-- | Display a warning if a condition is met.
warnIf :: Bool -> MsgDoc -> TcRn ()
warnIf :: Bool -> SDoc -> TcM ()
warnIf is_bad :: Bool
is_bad msg :: SDoc
msg
  = Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_bad (WarnReason -> SDoc -> TcM ()
addWarn WarnReason
NoReason SDoc
msg)

-- | Display a warning if a condition is met.
warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
warnTc :: WarnReason -> Bool -> SDoc -> TcM ()
warnTc reason :: WarnReason
reason warn_if_true :: Bool
warn_if_true warn_msg :: SDoc
warn_msg
  | Bool
warn_if_true = WarnReason -> SDoc -> TcM ()
addWarnTc WarnReason
reason SDoc
warn_msg
  | Bool
otherwise    = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Display a warning if a condition is met.
warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
warnTcM :: WarnReason -> Bool -> (TidyEnv, SDoc) -> TcM ()
warnTcM reason :: WarnReason
reason warn_if_true :: Bool
warn_if_true warn_msg :: (TidyEnv, SDoc)
warn_msg
  | Bool
warn_if_true = WarnReason -> (TidyEnv, SDoc) -> TcM ()
addWarnTcM WarnReason
reason (TidyEnv, SDoc)
warn_msg
  | Bool
otherwise    = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Display a warning in the current context.
addWarnTc :: WarnReason -> MsgDoc -> TcM ()
addWarnTc :: WarnReason -> SDoc -> TcM ()
addWarnTc reason :: WarnReason
reason msg :: SDoc
msg
 = do { TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv ;
      WarnReason -> (TidyEnv, SDoc) -> TcM ()
addWarnTcM WarnReason
reason (TidyEnv
env0, SDoc
msg) }

-- | Display a warning in a given context.
addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
addWarnTcM :: WarnReason -> (TidyEnv, SDoc) -> TcM ()
addWarnTcM reason :: WarnReason
reason (env0 :: TidyEnv
env0, msg :: SDoc
msg)
 = do { [ErrCtxt]
ctxt <- TcM [ErrCtxt]
getErrCtxt ;
        SDoc
err_info <- TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo TidyEnv
env0 [ErrCtxt]
ctxt ;
        WarnReason -> SDoc -> SDoc -> TcM ()
add_warn WarnReason
reason SDoc
msg SDoc
err_info }

-- | Display a warning for the current source location.
addWarn :: WarnReason -> MsgDoc -> TcRn ()
addWarn :: WarnReason -> SDoc -> TcM ()
addWarn reason :: WarnReason
reason msg :: SDoc
msg = WarnReason -> SDoc -> SDoc -> TcM ()
add_warn WarnReason
reason SDoc
msg SDoc
Outputable.empty

-- | Display a warning for a given source location.
addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
addWarnAt :: WarnReason -> SrcSpan -> SDoc -> TcM ()
addWarnAt reason :: WarnReason
reason loc :: SrcSpan
loc msg :: SDoc
msg = WarnReason -> SrcSpan -> SDoc -> SDoc -> TcM ()
add_warn_at WarnReason
reason SrcSpan
loc SDoc
msg SDoc
Outputable.empty

-- | Display a warning, with an optional flag, for the current source
-- location.
add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
add_warn :: WarnReason -> SDoc -> SDoc -> TcM ()
add_warn reason :: WarnReason
reason msg :: SDoc
msg extra_info :: SDoc
extra_info
  = do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
       ; WarnReason -> SrcSpan -> SDoc -> SDoc -> TcM ()
add_warn_at WarnReason
reason SrcSpan
loc SDoc
msg SDoc
extra_info }

-- | Display a warning, with an optional flag, for a given location.
add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
add_warn_at :: WarnReason -> SrcSpan -> SDoc -> SDoc -> TcM ()
add_warn_at reason :: WarnReason
reason loc :: SrcSpan
loc msg :: SDoc
msg extra_info :: SDoc
extra_info
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags ;
         PrintUnqualified
printer <- DynFlags -> TcRn PrintUnqualified
getPrintUnqualified DynFlags
dflags ;
         let { warn :: WarnMsg
warn = DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> WarnMsg
mkLongWarnMsg DynFlags
dflags SrcSpan
loc PrintUnqualified
printer
                                    SDoc
msg SDoc
extra_info } ;
         WarnReason -> WarnMsg -> TcM ()
reportWarning WarnReason
reason WarnMsg
warn }


{-
-----------------------------------
        Other helper functions
-}

add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
            -> [ErrCtxt]
            -> TcM ()
add_err_tcm :: TidyEnv -> SDoc -> SrcSpan -> [ErrCtxt] -> TcM ()
add_err_tcm tidy_env :: TidyEnv
tidy_env err_msg :: SDoc
err_msg loc :: SrcSpan
loc ctxt :: [ErrCtxt]
ctxt
 = do { SDoc
err_info <- TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo TidyEnv
tidy_env [ErrCtxt]
ctxt ;
        SrcSpan -> SDoc -> SDoc -> TcM ()
addLongErrAt SrcSpan
loc SDoc
err_msg SDoc
err_info }

mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
-- Tidy the error info, trimming excessive contexts
mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo env :: TidyEnv
env ctxts :: [ErrCtxt]
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
 = Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcRn SDoc
go Bool
False 0 TidyEnv
env [ErrCtxt]
ctxts
 where
   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcRn SDoc
go _ _ _   [] = SDoc -> TcRn SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
empty
   go dbg :: Bool
dbg n :: Int
n env :: TidyEnv
env ((is_landmark :: Bool
is_landmark, ctxt :: TidyEnv -> TcM (TidyEnv, SDoc)
ctxt) : ctxts :: [ErrCtxt]
ctxts)
     | Bool
is_landmark Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
mAX_CONTEXTS -- Too verbose || dbg
     = do { (env' :: TidyEnv
env', msg :: SDoc
msg) <- TidyEnv -> TcM (TidyEnv, SDoc)
ctxt TidyEnv
env
          ; let n' :: Int
n' = if Bool
is_landmark then Int
n else Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1
          ; SDoc
rest <- Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcRn SDoc
go Bool
dbg Int
n' TidyEnv
env' [ErrCtxt]
ctxts
          ; SDoc -> TcRn SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
rest) }
     | Bool
otherwise
     = Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcRn SDoc
go Bool
dbg Int
n TidyEnv
env [ErrCtxt]
ctxts

mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts
mAX_CONTEXTS :: Int
mAX_CONTEXTS = 3

-- debugTc is useful for monadic debugging code

debugTc :: TcM () -> TcM ()
debugTc :: TcM () -> TcM ()
debugTc thing :: TcM ()
thing
 | Bool
debugIsOn = TcM ()
thing
 | Bool
otherwise = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{-
************************************************************************
*                                                                      *
             Type constraints
*                                                                      *
************************************************************************
-}

addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
addTopEvBinds new_ev_binds :: Bag EvBind
new_ev_binds thing_inside :: TcM a
thing_inside
  =(TcGblEnv -> TcGblEnv) -> TcM a -> TcM a
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv TcGblEnv -> TcGblEnv
upd_env TcM a
thing_inside
  where
    upd_env :: TcGblEnv -> TcGblEnv
upd_env tcg_env :: TcGblEnv
tcg_env = TcGblEnv
tcg_env { tcg_ev_binds :: Bag EvBind
tcg_ev_binds = TcGblEnv -> Bag EvBind
tcg_ev_binds TcGblEnv
tcg_env
                                               Bag EvBind -> Bag EvBind -> Bag EvBind
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag EvBind
new_ev_binds }

newTcEvBinds :: TcM EvBindsVar
newTcEvBinds :: TcM EvBindsVar
newTcEvBinds = do { TcRef EvBindMap
binds_ref <- EvBindMap -> TcRnIf TcGblEnv TcLclEnv (TcRef EvBindMap)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef EvBindMap
emptyEvBindMap
                  ; IORef VarSet
tcvs_ref  <- VarSet -> TcRnIf TcGblEnv TcLclEnv (IORef VarSet)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef VarSet
emptyVarSet
                  ; Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
                  ; FilePath -> SDoc -> TcM ()
traceTc "newTcEvBinds" (FilePath -> SDoc
text "unique =" SDoc -> SDoc -> SDoc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
uniq)
                  ; EvBindsVar -> TcM EvBindsVar
forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindsVar :: Unique -> TcRef EvBindMap -> IORef VarSet -> EvBindsVar
EvBindsVar { ebv_binds :: TcRef EvBindMap
ebv_binds = TcRef EvBindMap
binds_ref
                                       , ebv_tcvs :: IORef VarSet
ebv_tcvs = IORef VarSet
tcvs_ref
                                       , ebv_uniq :: Unique
ebv_uniq = Unique
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 :: TcM EvBindsVar
newNoTcEvBinds
  = do { IORef VarSet
tcvs_ref  <- VarSet -> TcRnIf TcGblEnv TcLclEnv (IORef VarSet)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef VarSet
emptyVarSet
       ; Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
       ; FilePath -> SDoc -> TcM ()
traceTc "newNoTcEvBinds" (FilePath -> SDoc
text "unique =" SDoc -> SDoc -> SDoc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
uniq)
       ; EvBindsVar -> TcM EvBindsVar
forall (m :: * -> *) a. Monad m => a -> m a
return (CoEvBindsVar :: Unique -> IORef VarSet -> EvBindsVar
CoEvBindsVar { ebv_tcvs :: IORef VarSet
ebv_tcvs = IORef VarSet
tcvs_ref
                              , ebv_uniq :: Unique
ebv_uniq = Unique
uniq }) }

cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
-- Clone the refs, so that any binding created when
-- solving don't pollute the original
cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
cloneEvBindsVar ebv :: EvBindsVar
ebv@(EvBindsVar {})
  = do { TcRef EvBindMap
binds_ref <- EvBindMap -> TcRnIf TcGblEnv TcLclEnv (TcRef EvBindMap)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef EvBindMap
emptyEvBindMap
       ; IORef VarSet
tcvs_ref  <- VarSet -> TcRnIf TcGblEnv TcLclEnv (IORef VarSet)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef VarSet
emptyVarSet
       ; EvBindsVar -> TcM EvBindsVar
forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindsVar
ebv { ebv_binds :: TcRef EvBindMap
ebv_binds = TcRef EvBindMap
binds_ref
                     , ebv_tcvs :: IORef VarSet
ebv_tcvs = IORef VarSet
tcvs_ref }) }
cloneEvBindsVar ebv :: EvBindsVar
ebv@(CoEvBindsVar {})
  = do { IORef VarSet
tcvs_ref  <- VarSet -> TcRnIf TcGblEnv TcLclEnv (IORef VarSet)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef VarSet
emptyVarSet
       ; EvBindsVar -> TcM EvBindsVar
forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindsVar
ebv { ebv_tcvs :: IORef VarSet
ebv_tcvs = IORef VarSet
tcvs_ref }) }

getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
getTcEvTyCoVars :: EvBindsVar -> TcM VarSet
getTcEvTyCoVars ev_binds_var :: EvBindsVar
ev_binds_var
  = IORef VarSet -> TcM VarSet
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef (EvBindsVar -> IORef VarSet
ebv_tcvs EvBindsVar
ev_binds_var)

getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
getTcEvBindsMap (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindMap
ebv_binds = TcRef EvBindMap
ev_ref })
  = TcRef EvBindMap -> TcM EvBindMap
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef EvBindMap
ev_ref
getTcEvBindsMap (CoEvBindsVar {})
  = EvBindMap -> TcM EvBindMap
forall (m :: * -> *) a. Monad m => a -> m a
return EvBindMap
emptyEvBindMap

setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
setTcEvBindsMap (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindMap
ebv_binds = TcRef EvBindMap
ev_ref }) binds :: EvBindMap
binds
  = TcRef EvBindMap -> EvBindMap -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef EvBindMap
ev_ref EvBindMap
binds
setTcEvBindsMap v :: EvBindsVar
v@(CoEvBindsVar {}) ev_binds :: EvBindMap
ev_binds
  | EvBindMap -> Bool
isEmptyEvBindMap EvBindMap
ev_binds
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = FilePath -> SDoc -> TcM ()
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic "setTcEvBindsMap" (EvBindsVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBindsVar
v SDoc -> SDoc -> SDoc
$$ EvBindMap -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBindMap
ev_binds)

addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
-- Add a binding to the TcEvBinds by side effect
addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
addTcEvBind (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindMap
ebv_binds = TcRef EvBindMap
ev_ref, ebv_uniq :: EvBindsVar -> Unique
ebv_uniq = Unique
u }) ev_bind :: EvBind
ev_bind
  = do { FilePath -> SDoc -> TcM ()
traceTc "addTcEvBind" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
$$
                                 EvBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBind
ev_bind
       ; EvBindMap
bnds <- TcRef EvBindMap -> TcM EvBindMap
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef EvBindMap
ev_ref
       ; TcRef EvBindMap -> EvBindMap -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef EvBindMap
ev_ref (EvBindMap -> EvBind -> EvBindMap
extendEvBinds EvBindMap
bnds EvBind
ev_bind) }
addTcEvBind (CoEvBindsVar { ebv_uniq :: EvBindsVar -> Unique
ebv_uniq = Unique
u }) ev_bind :: EvBind
ev_bind
  = FilePath -> SDoc -> TcM ()
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic "addTcEvBind CoEvBindsVar" (EvBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBind
ev_bind SDoc -> SDoc -> SDoc
$$ Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
u)

chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc fn :: OccSet -> OccName
fn =
  do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
     ; let dfun_n_var :: IORef OccSet
dfun_n_var = TcGblEnv -> IORef OccSet
tcg_dfun_n TcGblEnv
env
     ; OccSet
set <- IORef OccSet -> TcRnIf TcGblEnv TcLclEnv OccSet
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef OccSet
dfun_n_var
     ; let occ :: OccName
occ = OccSet -> OccName
fn OccSet
set
     ; IORef OccSet -> OccSet -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef OccSet
dfun_n_var (OccSet -> OccName -> OccSet
extendOccSet OccSet
set OccName
occ)
     ; OccName -> TcM OccName
forall (m :: * -> *) a. Monad m => a -> m a
return OccName
occ }

getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar :: TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; IORef WantedConstraints
-> TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> IORef WantedConstraints
tcl_lie TcLclEnv
env) }

setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar :: IORef WantedConstraints -> TcM a -> TcM a
setConstraintVar lie_var :: IORef WantedConstraints
lie_var = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ env :: TcLclEnv
env -> TcLclEnv
env { tcl_lie :: IORef WantedConstraints
tcl_lie = IORef WantedConstraints
lie_var })

emitStaticConstraints :: WantedConstraints -> TcM ()
emitStaticConstraints :: WantedConstraints -> TcM ()
emitStaticConstraints static_lie :: WantedConstraints
static_lie
  = do { TcGblEnv
gbl_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef (TcGblEnv -> IORef WantedConstraints
tcg_static_wc TcGblEnv
gbl_env) (WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
static_lie) }

emitConstraints :: WantedConstraints -> TcM ()
emitConstraints :: WantedConstraints -> TcM ()
emitConstraints ct :: WantedConstraints
ct
  | WantedConstraints -> Bool
isEmptyWC WantedConstraints
ct
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = do { IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar ;
         IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
ct) }

emitSimple :: Ct -> TcM ()
emitSimple :: Ct -> TcM ()
emitSimple ct :: Ct
ct
  = do { IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar ;
         IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Ct -> WantedConstraints
`addSimples` Ct -> Bag Ct
forall a. a -> Bag a
unitBag Ct
ct) }

emitSimples :: Cts -> TcM ()
emitSimples :: Bag Ct -> TcM ()
emitSimples cts :: Bag Ct
cts
  = do { IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar ;
         IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Ct -> WantedConstraints
`addSimples` Bag Ct
cts) }

emitImplication :: Implication -> TcM ()
emitImplication :: Implication -> TcM ()
emitImplication ct :: Implication
ct
  = do { IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar ;
         IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Implication -> WantedConstraints
`addImplics` Implication -> Bag Implication
forall a. a -> Bag a
unitBag Implication
ct) }

emitImplications :: Bag Implication -> TcM ()
emitImplications :: Bag Implication -> TcM ()
emitImplications ct :: Bag Implication
ct
  = Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bag Implication -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag Implication
ct) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
    do { IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar ;
         IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Implication -> WantedConstraints
`addImplics` Bag Implication
ct) }

emitInsoluble :: Ct -> TcM ()
emitInsoluble :: Ct -> TcM ()
emitInsoluble ct :: Ct
ct
  = do { FilePath -> SDoc -> TcM ()
traceTc "emitInsoluble" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
       ; IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar
       ; IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Ct -> WantedConstraints
`addInsols` Ct -> Bag Ct
forall a. a -> Bag a
unitBag Ct
ct) }

emitInsolubles :: Cts -> TcM ()
emitInsolubles :: Bag Ct -> TcM ()
emitInsolubles cts :: Bag Ct
cts
  | Bag Ct -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag Ct
cts = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise      = do { FilePath -> SDoc -> TcM ()
traceTc "emitInsolubles" (Bag Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag Ct
cts)
                        ; IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar
                        ; IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Ct -> WantedConstraints
`addInsols` Bag Ct
cts) }

-- | Throw out any constraints emitted by the thing_inside
discardConstraints :: TcM a -> TcM a
discardConstraints :: TcM a -> TcM a
discardConstraints thing_inside :: TcM a
thing_inside = (a, WantedConstraints) -> a
forall a b. (a, b) -> a
fst ((a, WantedConstraints) -> a)
-> IOEnv (Env TcGblEnv TcLclEnv) (a, WantedConstraints) -> TcM a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (a, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
captureConstraints TcM a
thing_inside

-- | The name says it all. The returned TcLevel is the *inner* TcLevel.
pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints thing_inside :: TcM a
thing_inside
  = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; let tclvl' :: TcLevel
tclvl' = TcLevel -> TcLevel
pushTcLevel (TcLclEnv -> TcLevel
tcl_tclvl TcLclEnv
env)
       ; FilePath -> SDoc -> TcM ()
traceTc "pushLevelAndCaptureConstraints {" (TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl')
       ; (res :: a
res, lie :: WantedConstraints
lie) <- TcLclEnv
-> TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints)
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv (TcLclEnv
env { tcl_tclvl :: TcLevel
tcl_tclvl = TcLevel
tclvl' }) (TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints)
 -> TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints))
-> TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                       TcM a -> TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
captureConstraints TcM a
thing_inside
       ; FilePath -> SDoc -> TcM ()
traceTc "pushLevelAndCaptureConstraints }" (TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl')
       ; (TcLevel, WantedConstraints, a)
-> TcM (TcLevel, WantedConstraints, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLevel
tclvl', WantedConstraints
lie, a
res) }

pushTcLevelM_ :: TcM a -> TcM a
pushTcLevelM_ :: TcM a -> TcM a
pushTcLevelM_ x :: TcM a
x = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ env :: TcLclEnv
env -> TcLclEnv
env { tcl_tclvl :: TcLevel
tcl_tclvl = TcLevel -> TcLevel
pushTcLevel (TcLclEnv -> TcLevel
tcl_tclvl TcLclEnv
env) }) TcM a
x

pushTcLevelM :: TcM a -> TcM (TcLevel, a)
-- See Note [TcLevel assignment] in TcType
pushTcLevelM :: TcM a -> TcM (TcLevel, a)
pushTcLevelM thing_inside :: TcM a
thing_inside
  = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; let tclvl' :: TcLevel
tclvl' = TcLevel -> TcLevel
pushTcLevel (TcLclEnv -> TcLevel
tcl_tclvl TcLclEnv
env)
       ; a
res <- TcLclEnv -> TcM a -> TcM a
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv (TcLclEnv
env { tcl_tclvl :: TcLevel
tcl_tclvl = TcLevel
tclvl' })
                          TcM a
thing_inside
       ; (TcLevel, a) -> TcM (TcLevel, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLevel
tclvl', a
res) }

-- Returns pushed TcLevel
pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
pushTcLevelsM num_levels :: Int
num_levels thing_inside :: TcM a
thing_inside
  = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; let tclvl' :: TcLevel
tclvl' = Int -> (TcLevel -> TcLevel) -> TcLevel -> TcLevel
forall a. Int -> (a -> a) -> a -> a
nTimes Int
num_levels TcLevel -> TcLevel
pushTcLevel (TcLclEnv -> TcLevel
tcl_tclvl TcLclEnv
env)
       ; a
res <- TcLclEnv -> TcM a -> TcM a
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv (TcLclEnv
env { tcl_tclvl :: TcLevel
tcl_tclvl = TcLevel
tclvl' }) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
                TcM a
thing_inside
       ; (a, TcLevel) -> TcM (a, TcLevel)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, TcLevel
tclvl') }

getTcLevel :: TcM TcLevel
getTcLevel :: TcM TcLevel
getTcLevel = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
                ; TcLevel -> TcM TcLevel
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> TcLevel
tcl_tclvl TcLclEnv
env) }

setTcLevel :: TcLevel -> TcM a -> TcM a
setTcLevel :: TcLevel -> TcM a -> TcM a
setTcLevel tclvl :: TcLevel
tclvl thing_inside :: TcM a
thing_inside
  = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\env :: TcLclEnv
env -> TcLclEnv
env { tcl_tclvl :: TcLevel
tcl_tclvl = TcLevel
tclvl }) TcM a
thing_inside

isTouchableTcM :: TcTyVar -> TcM Bool
isTouchableTcM :: Id -> TcRn Bool
isTouchableTcM tv :: Id
tv
  = do { TcLevel
lvl <- TcM TcLevel
getTcLevel
       ; Bool -> TcRn Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLevel -> Id -> Bool
isTouchableMetaTyVar TcLevel
lvl Id
tv) }

getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; TcTypeEnv -> TcM TcTypeEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
env) }

setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
-- Set the local type envt, but do *not* disturb other fields,
-- notably the lie_var
setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
setLclTypeEnv lcl_env :: TcLclEnv
lcl_env thing_inside :: TcM a
thing_inside
  = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv TcLclEnv -> TcLclEnv
upd TcM a
thing_inside
  where
    upd :: TcLclEnv -> TcLclEnv
upd env :: TcLclEnv
env = TcLclEnv
env { tcl_env :: TcTypeEnv
tcl_env = TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
lcl_env,
                    tcl_tyvars :: IORef VarSet
tcl_tyvars = TcLclEnv -> IORef VarSet
tcl_tyvars TcLclEnv
lcl_env }

traceTcConstraints :: String -> TcM ()
traceTcConstraints :: FilePath -> TcM ()
traceTcConstraints msg :: FilePath
msg
  = do { IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar
       ; WantedConstraints
lie     <- IORef WantedConstraints
-> TcRnIf TcGblEnv TcLclEnv WantedConstraints
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef WantedConstraints
lie_var
       ; DumpFlag -> SDoc -> TcM ()
traceOptTcRn DumpFlag
Opt_D_dump_tc_trace (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
         SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
text (FilePath
msg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ": LIE:")) 2 (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
lie)
       }

emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
emitWildCardHoleConstraints :: [(Name, Id)] -> TcM ()
emitWildCardHoleConstraints wcs :: [(Name, Id)]
wcs
  = do { CtLoc
ct_loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
HoleOrigin Maybe TypeOrKind
forall a. Maybe a
Nothing
       ; Bag Ct -> TcM ()
emitInsolubles (Bag Ct -> TcM ()) -> Bag Ct -> TcM ()
forall a b. (a -> b) -> a -> b
$ [Ct] -> Bag Ct
forall a. [a] -> Bag a
listToBag ([Ct] -> Bag Ct) -> [Ct] -> Bag Ct
forall a b. (a -> b) -> a -> b
$
         ((Name, Id) -> Ct) -> [(Name, Id)] -> [Ct]
forall a b. (a -> b) -> [a] -> [b]
map (CtLoc -> (Name, Id) -> Ct
do_one CtLoc
ct_loc) [(Name, Id)]
wcs }
  where
    do_one :: CtLoc -> (Name, TcTyVar) -> Ct
    do_one :: CtLoc -> (Name, Id) -> Ct
do_one ct_loc :: CtLoc
ct_loc (name :: Name
name, tv :: Id
tv)
       = CHoleCan :: CtEvidence -> Hole -> Ct
CHoleCan { cc_ev :: CtEvidence
cc_ev = CtDerived :: Type -> CtLoc -> CtEvidence
CtDerived { ctev_pred :: Type
ctev_pred = Id -> Type
mkTyVarTy Id
tv
                                      , ctev_loc :: CtLoc
ctev_loc  = CtLoc
ct_loc' }
                  , cc_hole :: Hole
cc_hole = OccName -> Hole
TypeHole (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
name) }
       where
         real_span :: RealSrcSpan
real_span = case Name -> SrcSpan
nameSrcSpan Name
name of
                           RealSrcSpan span :: RealSrcSpan
span  -> RealSrcSpan
span
                           UnhelpfulSpan str :: FastString
str -> FilePath -> SDoc -> RealSrcSpan
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic "emitWildCardHoleConstraints"
                                                      (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FastString -> SDoc
ftext FastString
str))
               -- Wildcards are defined locally, and so have RealSrcSpans
         ct_loc' :: CtLoc
ct_loc' = CtLoc -> RealSrcSpan -> CtLoc
setCtLocSpan CtLoc
ct_loc RealSrcSpan
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 'attemptM' 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
*                                                                      *
************************************************************************
-}

recordThUse :: TcM ()
recordThUse :: TcM ()
recordThUse = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; IORef Bool -> Bool -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (TcGblEnv -> IORef Bool
tcg_th_used TcGblEnv
env) Bool
True }

recordThSpliceUse :: TcM ()
recordThSpliceUse :: TcM ()
recordThSpliceUse = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; IORef Bool -> Bool -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (TcGblEnv -> IORef Bool
tcg_th_splice_used TcGblEnv
env) Bool
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 :: SrcSpan -> TcM ()
recordTopLevelSpliceLoc (RealSrcSpan real_loc :: RealSrcSpan
real_loc)
  = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; let locs_var :: IORef (Set RealSrcSpan)
locs_var = TcGblEnv -> IORef (Set RealSrcSpan)
tcg_th_top_level_locs TcGblEnv
env
       ; Set RealSrcSpan
locs0 <- IORef (Set RealSrcSpan)
-> TcRnIf TcGblEnv TcLclEnv (Set RealSrcSpan)
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Set RealSrcSpan)
locs_var
       ; IORef (Set RealSrcSpan) -> Set RealSrcSpan -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef (Set RealSrcSpan)
locs_var (RealSrcSpan -> Set RealSrcSpan -> Set RealSrcSpan
forall a. Ord a => a -> Set a -> Set a
Set.insert RealSrcSpan
real_loc Set RealSrcSpan
locs0) }
recordTopLevelSpliceLoc (UnhelpfulSpan _) = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)
getTopLevelSpliceLocs :: TcRnIf TcGblEnv TcLclEnv (Set RealSrcSpan)
getTopLevelSpliceLocs
  = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; IORef (Set RealSrcSpan)
-> TcRnIf TcGblEnv TcLclEnv (Set RealSrcSpan)
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef (TcGblEnv -> IORef (Set RealSrcSpan)
tcg_th_top_level_locs TcGblEnv
env) }

keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set
keepAlive :: Name -> TcM ()
keepAlive name :: Name
name
  = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; FilePath -> SDoc -> TcM ()
traceRn "keep alive" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
       ; IORef NameSet -> (NameSet -> NameSet) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef (TcGblEnv -> IORef NameSet
tcg_keep TcGblEnv
env) (NameSet -> Name -> NameSet
`extendNameSet` Name
name) }

getStage :: TcM ThStage
getStage :: TcM ThStage
getStage = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; ThStage -> TcM ThStage
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> ThStage
tcl_th_ctxt TcLclEnv
env) }

getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Int, ThStage))
getStageAndBindLevel name :: Name
name
  = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv;
       ; case ThBindEnv -> Name -> Maybe (TopLevelFlag, Int)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (TcLclEnv -> ThBindEnv
tcl_th_bndrs TcLclEnv
env) Name
name of
           Nothing                  -> Maybe (TopLevelFlag, Int, ThStage)
-> TcRn (Maybe (TopLevelFlag, Int, ThStage))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TopLevelFlag, Int, ThStage)
forall a. Maybe a
Nothing
           Just (top_lvl :: TopLevelFlag
top_lvl, bind_lvl :: Int
bind_lvl) -> Maybe (TopLevelFlag, Int, ThStage)
-> TcRn (Maybe (TopLevelFlag, Int, ThStage))
forall (m :: * -> *) a. Monad m => a -> m a
return ((TopLevelFlag, Int, ThStage) -> Maybe (TopLevelFlag, Int, ThStage)
forall a. a -> Maybe a
Just (TopLevelFlag
top_lvl, Int
bind_lvl, TcLclEnv -> ThStage
tcl_th_ctxt TcLclEnv
env)) }

setStage :: ThStage -> TcM a -> TcRn a
setStage :: ThStage -> TcM a -> TcM a
setStage s :: ThStage
s = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ env :: TcLclEnv
env -> TcLclEnv
env { tcl_th_ctxt :: ThStage
tcl_th_ctxt = ThStage
s })

-- | Adds the given modFinalizers to the global environment and set them to use
-- the current local environment.
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv mod_finalizers :: ThModFinalizers
mod_finalizers
  = do TcLclEnv
lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       IORef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var <- (TcGblEnv -> IORef [(TcLclEnv, ThModFinalizers)])
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IOEnv
     (Env TcGblEnv TcLclEnv) (IORef [(TcLclEnv, ThModFinalizers)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> IORef [(TcLclEnv, ThModFinalizers)]
tcg_th_modfinalizers TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       IORef [(TcLclEnv, ThModFinalizers)]
-> ([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)])
-> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var (([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)])
 -> TcM ())
-> ([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)])
-> TcM ()
forall a b. (a -> b) -> a -> b
$ \fins :: [(TcLclEnv, ThModFinalizers)]
fins ->
         (TcLclEnv
lcl_env, ThModFinalizers
mod_finalizers) (TcLclEnv, ThModFinalizers)
-> [(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)]
forall a. a -> [a] -> [a]
: [(TcLclEnv, ThModFinalizers)]
fins

{-
************************************************************************
*                                                                      *
             Safe Haskell context
*                                                                      *
************************************************************************
-}

-- | Mark that safe inference has failed
-- See Note [Safe Haskell Overlapping Instances Implementation]
-- although this is used for more than just that failure case.
recordUnsafeInfer :: WarningMessages -> TcM ()
recordUnsafeInfer :: Bag WarnMsg -> TcM ()
recordUnsafeInfer warns :: Bag WarnMsg
warns =
    TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv TcRnIf TcGblEnv TcLclEnv TcGblEnv -> (TcGblEnv -> TcM ()) -> TcM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \env :: TcGblEnv
env -> IORef (Bool, Bag WarnMsg) -> (Bool, Bag WarnMsg) -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (TcGblEnv -> IORef (Bool, Bag WarnMsg)
tcg_safeInfer TcGblEnv
env) (Bool
False, Bag WarnMsg
warns)

-- | Figure out the final correct safe haskell mode
finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode dflags :: DynFlags
dflags tcg_env :: TcGblEnv
tcg_env = do
    Bool
safeInf <- (Bool, Bag WarnMsg) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Bag WarnMsg) -> Bool) -> IO (Bool, Bag WarnMsg) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Bool, Bag WarnMsg) -> IO (Bool, Bag WarnMsg)
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef (Bool, Bag WarnMsg)
tcg_safeInfer TcGblEnv
tcg_env)
    SafeHaskellMode -> IO SafeHaskellMode
forall (m :: * -> *) a. Monad m => a -> m a
return (SafeHaskellMode -> IO SafeHaskellMode)
-> SafeHaskellMode -> IO SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ case DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags of
        Sf_None | DynFlags -> Bool
safeInferOn DynFlags
dflags Bool -> Bool -> Bool
&& Bool
safeInf -> SafeHaskellMode
Sf_Safe
                | Bool
otherwise                     -> SafeHaskellMode
Sf_None
        s :: SafeHaskellMode
s -> SafeHaskellMode
s

-- | Switch instances to safe instances if we're in Safe mode.
fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
fixSafeInstances sfMode :: SafeHaskellMode
sfMode | SafeHaskellMode
sfMode SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
/= SafeHaskellMode
Sf_Safe = [ClsInst] -> [ClsInst]
forall a. a -> a
id
fixSafeInstances _ = (ClsInst -> ClsInst) -> [ClsInst] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> ClsInst
fixSafe
  where fixSafe :: ClsInst -> ClsInst
fixSafe inst :: ClsInst
inst = let new_flag :: OverlapFlag
new_flag = (ClsInst -> OverlapFlag
is_flag ClsInst
inst) { isSafeOverlap :: Bool
isSafeOverlap = Bool
True }
                       in ClsInst
inst { is_flag :: OverlapFlag
is_flag = OverlapFlag
new_flag }

{-
************************************************************************
*                                                                      *
             Stuff for the renamer's local env
*                                                                      *
************************************************************************
-}

getLocalRdrEnv :: RnM LocalRdrEnv
getLocalRdrEnv :: RnM LocalRdrEnv
getLocalRdrEnv = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; LocalRdrEnv -> RnM LocalRdrEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> LocalRdrEnv
tcl_rdr TcLclEnv
env) }

setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv rdr_env :: LocalRdrEnv
rdr_env thing_inside :: RnM a
thing_inside
  = (TcLclEnv -> TcLclEnv) -> RnM a -> RnM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\env :: TcLclEnv
env -> TcLclEnv
env {tcl_rdr :: LocalRdrEnv
tcl_rdr = LocalRdrEnv
rdr_env}) RnM a
thing_inside

{-
************************************************************************
*                                                                      *
             Stuff for interface decls
*                                                                      *
************************************************************************
-}

mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
mkIfLclEnv mod :: Module
mod loc :: SDoc
loc boot :: Bool
boot
                   = IfLclEnv :: Module
-> Bool
-> SDoc
-> Maybe NameShape
-> Maybe TypeEnv
-> FastStringEnv Id
-> FastStringEnv Id
-> IfLclEnv
IfLclEnv { if_mod :: Module
if_mod     = Module
mod,
                                if_loc :: SDoc
if_loc     = SDoc
loc,
                                if_boot :: Bool
if_boot    = Bool
boot,
                                if_nsubst :: Maybe NameShape
if_nsubst  = Maybe NameShape
forall a. Maybe a
Nothing,
                                if_implicits_env :: Maybe TypeEnv
if_implicits_env = Maybe TypeEnv
forall a. Maybe a
Nothing,
                                if_tv_env :: FastStringEnv Id
if_tv_env  = FastStringEnv Id
forall a. NameEnv a
emptyFsEnv,
                                if_id_env :: FastStringEnv Id
if_id_env  = FastStringEnv Id
forall a. NameEnv a
emptyFsEnv }

-- | Run an 'IfG' (top-level interface monad) computation inside an existing
-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
-- based on 'TcGblEnv'.
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside :: IfG a
thing_inside
  = do  { TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; let !mod :: Module
mod = TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env
              -- When we are instantiating a signature, we DEFINITELY
              -- do not want to knot tie.
              is_instantiate :: Bool
is_instantiate = UnitId -> Bool
unitIdIsDefinite (DynFlags -> UnitId
thisPackage DynFlags
dflags) Bool -> Bool -> Bool
&&
                               Bool -> Bool
not ([(ModuleName, Module)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DynFlags -> [(ModuleName, Module)]
thisUnitIdInsts DynFlags
dflags))
        ; let { if_env :: IfGblEnv
if_env = IfGblEnv :: SDoc -> Maybe (Module, IfG TypeEnv) -> IfGblEnv
IfGblEnv {
                            if_doc :: SDoc
if_doc = FilePath -> SDoc
text "initIfaceTcRn",
                            if_rec_types :: Maybe (Module, IfG TypeEnv)
if_rec_types =
                                if Bool
is_instantiate
                                    then Maybe (Module, IfG TypeEnv)
forall a. Maybe a
Nothing
                                    else (Module, IfG TypeEnv) -> Maybe (Module, IfG TypeEnv)
forall a. a -> Maybe a
Just (Module
mod, IfG TypeEnv
forall gbl lcl. TcRnIf gbl lcl TypeEnv
get_type_env)
                         }
              ; get_type_env :: TcRnIf gbl lcl TypeEnv
get_type_env = IORef TypeEnv -> TcRnIf gbl lcl TypeEnv
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef (TcGblEnv -> IORef TypeEnv
tcg_type_env_var TcGblEnv
tcg_env) }
        ; (IfGblEnv, ()) -> IfG a -> TcRn a
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (IfGblEnv
if_env, ()) IfG a
thing_inside }

-- 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 :: HscEnv -> IfG a -> IO a
initIfaceLoad hsc_env :: HscEnv
hsc_env do_this :: IfG a
do_this
 = do let gbl_env :: IfGblEnv
gbl_env = IfGblEnv :: SDoc -> Maybe (Module, IfG TypeEnv) -> IfGblEnv
IfGblEnv {
                        if_doc :: SDoc
if_doc = FilePath -> SDoc
text "initIfaceLoad",
                        if_rec_types :: Maybe (Module, IfG TypeEnv)
if_rec_types = Maybe (Module, IfG TypeEnv)
forall a. Maybe a
Nothing
                    }
      Char -> HscEnv -> IfGblEnv -> () -> IfG a -> IO a
forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf 'i' HscEnv
hsc_env IfGblEnv
gbl_env () IfG a
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 :: SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck doc :: SDoc
doc hsc_env :: HscEnv
hsc_env do_this :: IfG a
do_this
 = do let rec_types :: Maybe (Module, TcRnIf gbl lcl TypeEnv)
rec_types = case HscEnv -> Maybe (Module, IORef TypeEnv)
hsc_type_env_var HscEnv
hsc_env of
                         Just (mod :: Module
mod,var :: IORef TypeEnv
var) -> (Module, TcRnIf gbl lcl TypeEnv)
-> Maybe (Module, TcRnIf gbl lcl TypeEnv)
forall a. a -> Maybe a
Just (Module
mod, IORef TypeEnv -> TcRnIf gbl lcl TypeEnv
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef TypeEnv
var)
                         Nothing        -> Maybe (Module, TcRnIf gbl lcl TypeEnv)
forall a. Maybe a
Nothing
          gbl_env :: IfGblEnv
gbl_env = IfGblEnv :: SDoc -> Maybe (Module, IfG TypeEnv) -> IfGblEnv
IfGblEnv {
                        if_doc :: SDoc
if_doc = FilePath -> SDoc
text "initIfaceCheck" SDoc -> SDoc -> SDoc
<+> SDoc
doc,
                        if_rec_types :: Maybe (Module, IfG TypeEnv)
if_rec_types = Maybe (Module, IfG TypeEnv)
forall gbl lcl. Maybe (Module, TcRnIf gbl lcl TypeEnv)
rec_types
                    }
      Char -> HscEnv -> IfGblEnv -> () -> IfG a -> IO a
forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf 'i' HscEnv
hsc_env IfGblEnv
gbl_env () IfG a
do_this

initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
initIfaceLcl mod :: Module
mod loc_doc :: SDoc
loc_doc hi_boot_file :: Bool
hi_boot_file thing_inside :: IfL a
thing_inside
  = IfLclEnv -> IfL a -> IfM lcl a
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv (Module -> SDoc -> Bool -> IfLclEnv
mkIfLclEnv Module
mod SDoc
loc_doc Bool
hi_boot_file) IfL a
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 :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a
initIfaceLclWithSubst mod :: Module
mod loc_doc :: SDoc
loc_doc hi_boot_file :: Bool
hi_boot_file nsubst :: NameShape
nsubst thing_inside :: IfL a
thing_inside
  = IfLclEnv -> IfL a -> IfM lcl a
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv ((Module -> SDoc -> Bool -> IfLclEnv
mkIfLclEnv Module
mod SDoc
loc_doc Bool
hi_boot_file) { if_nsubst :: Maybe NameShape
if_nsubst = NameShape -> Maybe NameShape
forall a. a -> Maybe a
Just NameShape
nsubst }) IfL a
thing_inside

getIfModule :: IfL Module
getIfModule :: IfL Module
getIfModule = do { IfLclEnv
env <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; Module -> IfL Module
forall (m :: * -> *) a. Monad m => a -> m a
return (IfLclEnv -> Module
if_mod IfLclEnv
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 "shouldn't happen".
-- We use IfL here so that we can get context info out of the local env
failIfM :: SDoc -> IfL a
failIfM msg :: SDoc
msg
  = do  { IfLclEnv
env <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
        ; let full_msg :: SDoc
full_msg = (IfLclEnv -> SDoc
if_loc IfLclEnv
env SDoc -> SDoc -> SDoc
<> SDoc
colon) SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 2 SDoc
msg
        ; DynFlags
dflags <- IOEnv (Env IfGblEnv IfLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; IO () -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevFatal
                   SrcSpan
noSrcSpan (DynFlags -> PprStyle
defaultErrStyle DynFlags
dflags) SDoc
full_msg)
        ; IfL a
forall env a. IOEnv env a
failM }

--------------------
forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
-- Run thing_inside in an interleaved thread.
-- It shares everything with the parent thread, so this is DANGEROUS.
--
-- It returns Nothing if the computation fails
--
-- It's used for lazily type-checking interface
-- signatures, which is pretty benign

forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
forkM_maybe doc :: SDoc
doc thing_inside :: IfL a
thing_inside
 -- NB: Don't share the mutable env_us with the interleaved thread since env_us
 --     does not get updated atomically (e.g. in newUnique and newUniqueSupply).
 = do { UniqSupply
child_us <- TcRnIf IfGblEnv IfLclEnv UniqSupply
forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
      ; IORef UniqSupply
child_env_us <- UniqSupply -> IOEnv (Env IfGblEnv IfLclEnv) (IORef UniqSupply)
forall a env. a -> IOEnv env (IORef a)
newMutVar UniqSupply
child_us
        -- see Note [Masking exceptions in forkM_maybe]
      ; IfL (Maybe a) -> IfL (Maybe a)
forall env a. IOEnv env a -> IOEnv env a
unsafeInterleaveM (IfL (Maybe a) -> IfL (Maybe a)) -> IfL (Maybe a) -> IfL (Maybe a)
forall a b. (a -> b) -> a -> b
$ IfL (Maybe a) -> IfL (Maybe a)
forall env a. IOEnv env a -> IOEnv env a
uninterruptibleMaskM_ (IfL (Maybe a) -> IfL (Maybe a)) -> IfL (Maybe a) -> IfL (Maybe a)
forall a b. (a -> b) -> a -> b
$ (Env IfGblEnv IfLclEnv -> Env IfGblEnv IfLclEnv)
-> IfL (Maybe a) -> IfL (Maybe a)
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\env :: Env IfGblEnv IfLclEnv
env -> Env IfGblEnv IfLclEnv
env { env_us :: IORef UniqSupply
env_us = IORef UniqSupply
child_env_us }) (IfL (Maybe a) -> IfL (Maybe a)) -> IfL (Maybe a) -> IfL (Maybe a)
forall a b. (a -> b) -> a -> b
$
        do { SDoc -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
text "Starting fork {" SDoc -> SDoc -> SDoc
<+> SDoc
doc)
           ; Either IOEnvFailure a
mb_res <- IfL a -> IOEnv (Env IfGblEnv IfLclEnv) (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM (IfL a -> IOEnv (Env IfGblEnv IfLclEnv) (Either IOEnvFailure a))
-> IfL a -> IOEnv (Env IfGblEnv IfLclEnv) (Either IOEnvFailure a)
forall a b. (a -> b) -> a -> b
$
                       (IfLclEnv -> IfLclEnv) -> IfL a -> IfL a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\env :: IfLclEnv
env -> IfLclEnv
env { if_loc :: SDoc
if_loc = IfLclEnv -> SDoc
if_loc IfLclEnv
env SDoc -> SDoc -> SDoc
$$ SDoc
doc }) (IfL a -> IfL a) -> IfL a -> IfL a
forall a b. (a -> b) -> a -> b
$
                       IfL a
thing_inside
           ; case Either IOEnvFailure a
mb_res of
                Right r :: a
r  -> do  { SDoc -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
text "} ending fork" SDoc -> SDoc -> SDoc
<+> SDoc
doc)
                                ; Maybe a -> IfL (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
r) }
                Left exn :: IOEnvFailure
exn -> do {

                    -- Bleat about errors in the forked thread, if -ddump-if-trace is on
                    -- Otherwise we silently discard errors. Errors can legitimately
                    -- happen when compiling interface signatures (see tcInterfaceSigs)
                      DumpFlag
-> IOEnv (Env IfGblEnv IfLclEnv) ()
-> IOEnv (Env IfGblEnv IfLclEnv) ()
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
Opt_D_dump_if_trace (IOEnv (Env IfGblEnv IfLclEnv) ()
 -> IOEnv (Env IfGblEnv IfLclEnv) ())
-> IOEnv (Env IfGblEnv IfLclEnv) ()
-> IOEnv (Env IfGblEnv IfLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
                          DynFlags
dflags <- IOEnv (Env IfGblEnv IfLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                          let msg :: SDoc
msg = SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
text "forkM failed:" SDoc -> SDoc -> SDoc
<+> SDoc
doc)
                                       2 (FilePath -> SDoc
text (IOEnvFailure -> FilePath
forall a. Show a => a -> FilePath
show IOEnvFailure
exn))
                          IO () -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env IfGblEnv IfLclEnv) ())
-> IO () -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
putLogMsg DynFlags
dflags
                                             WarnReason
NoReason
                                             Severity
SevFatal
                                             SrcSpan
noSrcSpan
                                             (DynFlags -> PprStyle
defaultErrStyle DynFlags
dflags)
                                             SDoc
msg

                    ; SDoc -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
text "} ending fork (badly)" SDoc -> SDoc -> SDoc
<+> SDoc
doc)
                    ; Maybe a -> IfL (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing }
        }}

forkM :: SDoc -> IfL a -> IfL a
forkM :: SDoc -> IfL a -> IfL a
forkM doc :: SDoc
doc thing_inside :: IfL a
thing_inside
 = do   { Maybe a
mb_res <- SDoc -> IfL a -> IfL (Maybe a)
forall a. SDoc -> IfL a -> IfL (Maybe a)
forkM_maybe SDoc
doc IfL a
thing_inside
        ; a -> IfL a
forall (m :: * -> *) a. Monad m => a -> m a
return (case Maybe a
mb_res of
                        Nothing -> FilePath -> a
forall a. FilePath -> a
pgmError "Cannot continue after interface file error"
                                   -- pprPanic "forkM" doc
                        Just r :: a
r  -> a
r) }

setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
setImplicitEnvM tenv :: TypeEnv
tenv m :: IfL a
m = (IfLclEnv -> IfLclEnv) -> IfL a -> IfL a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\lcl :: IfLclEnv
lcl -> IfLclEnv
lcl
                                     { if_implicits_env :: Maybe TypeEnv
if_implicits_env = TypeEnv -> Maybe TypeEnv
forall a. a -> Maybe a
Just TypeEnv
tenv }) IfL a
m

{-
Note [Masking exceptions in forkM_maybe]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When using GHC-as-API it must be possible to interrupt snippets of code
executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
by throwing an asynchronous interrupt to the GHC thread. However, there is a
subtle problem: runStmt first typechecks the code before running it, and the
exception might interrupt the type checker rather than the code. Moreover, the
typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
more importantly might be inside an exception handler inside that
unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
asynchronous exception as a synchronous exception, and the exception will end
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 :: TcGblEnv -> IORef CostCentreState
extractCostCentreState = TcGblEnv -> IORef CostCentreState
tcg_cc_st

instance ContainsCostCentreState DsGblEnv where
  extractCostCentreState :: DsGblEnv -> IORef CostCentreState
extractCostCentreState = DsGblEnv -> IORef CostCentreState
ds_cc_st

-- | Get the next cost centre index associated with a given name.
getCCIndexM :: (ContainsCostCentreState gbl)
            => FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM :: FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM nm :: FastString
nm = do
  gbl
env <- TcRnIf gbl lcl gbl
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
  let cc_st_ref :: IORef CostCentreState
cc_st_ref = gbl -> IORef CostCentreState
forall e. ContainsCostCentreState e => e -> IORef CostCentreState
extractCostCentreState gbl
env
  CostCentreState
cc_st <- IORef CostCentreState -> TcRnIf gbl lcl CostCentreState
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef CostCentreState
cc_st_ref
  let (idx :: CostCentreIndex
idx, cc_st' :: CostCentreState
cc_st') = FastString -> CostCentreState -> (CostCentreIndex, CostCentreState)
getCCIndex FastString
nm CostCentreState
cc_st
  IORef CostCentreState -> CostCentreState -> TcRnIf gbl lcl ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef CostCentreState
cc_st_ref CostCentreState
cc_st'
  CostCentreIndex -> TcRnIf gbl lcl CostCentreIndex
forall (m :: * -> *) a. Monad m => a -> m a
return CostCentreIndex
idx