{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


Monadery used in desugaring
-}

module GHC.HsToCore.Monad (
        DsM, mapM, mapAndUnzipM,
        initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
        foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
        Applicative(..),(<$>),

        duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
        newSysLocalMDs, newSysLocalsMDs, newFailLocalMDs,
        newUniqueId, newPredVarDs,
        getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
        mkNamePprCtxDs,
        newUnique,
        UniqSupply, newUniqueSupply,
        getGhcModeDs, dsGetFamInstEnvs, dsGetGlobalRdrEnv,
        dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
        dsLookupDataCon, dsLookupConLike,
        getCCIndexDsM,

        DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,

        -- Getting and setting pattern match oracle states
        getPmNablas, updPmNablas,

        -- Tracking evidence variable coherence
        addUnspecables, getUnspecables, zapUnspecables,

        -- Get COMPLETE sets of a TyCon
        dsGetCompleteMatches,

        -- Warnings and errors
        DsWarning, diagnosticDs, errDsCoreExpr,
        failWithDs, failDs, discardWarningsDs,

        -- Data types
        DsMatchContext(..),
        EquationInfo(..), EquationInfoNE, prependPats, mkEqnInfo, eqnMatchResult,
        MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,

        -- Trace injection
        pprRuntimeTrace
    ) where

import GHC.Prelude

import GHC.Driver.Env
import GHC.Driver.DynFlags
import GHC.Driver.Ppr
import GHC.Driver.Config.Diagnostic

import GHC.Hs

import GHC.HsToCore.Types
import GHC.HsToCore.Errors.Types
import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)

import GHC.Core.FamInstEnv
import GHC.Core
import GHC.Core.Make  ( unitExpr )
import GHC.Core.Utils ( exprType )
import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Multiplicity

import GHC.IfaceToCore

import GHC.Tc.Utils.Monad

import GHC.Builtin.Names

import GHC.Data.FastString

import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts

import GHC.Types.Name.Reader
import GHC.Types.SourceFile
import GHC.Types.Id
import GHC.Types.Var (EvId)
import GHC.Types.SrcLoc
import GHC.Types.TypeEnv
import GHC.Types.Unique.Supply
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Ppr
import GHC.Types.Literal ( mkLitString )
import GHC.Types.CostCentre.State
import GHC.Types.TyThing
import GHC.Types.Error
import GHC.Types.CompleteMatch
import GHC.Types.Unique.DSet

import GHC.Tc.Utils.Env (lookupGlobal)

import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
import qualified GHC.Data.Strict as Strict

import Data.IORef
import GHC.Driver.Env.KnotVars
import qualified Data.Set as S
import GHC.IO.Unsafe (unsafeInterleaveIO)

{-
************************************************************************
*                                                                      *
                Data types for the desugarer
*                                                                      *
************************************************************************
-}

data DsMatchContext
  = DsMatchContext HsMatchContextRn SrcSpan
  deriving ()

instance Outputable DsMatchContext where
  ppr :: DsMatchContext -> SDoc
ppr (DsMatchContext HsMatchContextRn
hs_match SrcSpan
ss) = SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
ss SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsMatchContext (GenLocated SrcSpanAnnN Name) -> SDoc
forall fn. Outputable fn => HsMatchContext fn -> SDoc
pprMatchContext HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
hs_match

data EquationInfo
  = EqnMatch  { EquationInfo -> LPat GhcTc
eqn_pat :: LPat GhcTc
                -- ^ The first pattern of the equation
                --
                -- NB: The location info is used to determine whether the
                -- pattern is generated or not.
                -- This helps us avoid warnings on patterns that GHC elaborated.
                --
                -- NB: We have /already/ applied 'decideBangHood' to this
                -- pattern. See Note [decideBangHood] in "GHC.HsToCore.Utils"

              , EquationInfo -> EquationInfo
eqn_rest :: EquationInfo }
                -- ^ The rest of the equation after its first pattern

  | EqnDone
  -- The empty tail of an equation having no more patterns
            (MatchResult CoreExpr)
            -- ^ What to do after match

type EquationInfoNE = EquationInfo
-- An EquationInfo which has at least one pattern
--   i.e. it's an EqnMatch, not EqnDone

prependPats :: [LPat GhcTc] -> EquationInfo -> EquationInfo
prependPats :: [LPat GhcTc] -> EquationInfo -> EquationInfo
prependPats [] EquationInfo
eqn = EquationInfo
eqn
prependPats (LPat GhcTc
pat:[LPat GhcTc]
pats) EquationInfo
eqn = EqnMatch { eqn_pat :: LPat GhcTc
eqn_pat = LPat GhcTc
pat, eqn_rest :: EquationInfo
eqn_rest = [LPat GhcTc] -> EquationInfo -> EquationInfo
prependPats [LPat GhcTc]
pats EquationInfo
eqn }

mkEqnInfo :: [LPat GhcTc] -> MatchResult CoreExpr -> EquationInfo
mkEqnInfo :: [LPat GhcTc] -> MatchResult CoreExpr -> EquationInfo
mkEqnInfo [LPat GhcTc]
pats = [LPat GhcTc] -> EquationInfo -> EquationInfo
prependPats [LPat GhcTc]
pats (EquationInfo -> EquationInfo)
-> (MatchResult CoreExpr -> EquationInfo)
-> MatchResult CoreExpr
-> EquationInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatchResult CoreExpr -> EquationInfo
EqnDone

eqnMatchResult :: EquationInfo -> MatchResult CoreExpr
eqnMatchResult :: EquationInfo -> MatchResult CoreExpr
eqnMatchResult (EqnDone MatchResult CoreExpr
rhs) = MatchResult CoreExpr
rhs
eqnMatchResult (EqnMatch { eqn_rest :: EquationInfo -> EquationInfo
eqn_rest = EquationInfo
eq }) = EquationInfo -> MatchResult CoreExpr
eqnMatchResult EquationInfo
eq

instance Outputable EquationInfo where
    ppr :: EquationInfo -> SDoc
ppr = [Pat GhcTc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Pat GhcTc] -> SDoc)
-> (EquationInfo -> [Pat GhcTc]) -> EquationInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EquationInfo -> [Pat GhcTc]
allEqnPats where
      allEqnPats :: EquationInfo -> [Pat GhcTc]
allEqnPats (EqnDone {}) = []
      allEqnPats (EqnMatch { eqn_pat :: EquationInfo -> LPat GhcTc
eqn_pat = LPat GhcTc
pat, eqn_rest :: EquationInfo -> EquationInfo
eqn_rest = EquationInfo
eq }) = GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat Pat GhcTc -> [Pat GhcTc] -> [Pat GhcTc]
forall a. a -> [a] -> [a]
: EquationInfo -> [Pat GhcTc]
allEqnPats EquationInfo
eq

type DsWrapper = CoreExpr -> CoreExpr
idDsWrapper :: DsWrapper
idDsWrapper :: DsWrapper
idDsWrapper CoreExpr
e = CoreExpr
e

-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult CoreExpr
--      \fail. wrap (case vs of { pats -> rhs fail })
-- where vs are not bound by wrap

-- | This is a value of type a with potentially a CoreExpr-shaped hole in it.
-- This is used to deal with cases where we are potentially handling pattern
-- match failure, and want to later specify how failure is handled.
data MatchResult a
  -- | We represent the case where there is no hole without a function from
  -- 'CoreExpr', like this, because sometimes we have nothing to put in the
  -- hole and so want to be sure there is in fact no hole.
  = MR_Infallible (DsM a)
  | MR_Fallible (CoreExpr -> DsM a)
  deriving ((forall a b. (a -> b) -> MatchResult a -> MatchResult b)
-> (forall a b. a -> MatchResult b -> MatchResult a)
-> Functor MatchResult
forall a b. a -> MatchResult b -> MatchResult a
forall a b. (a -> b) -> MatchResult a -> MatchResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> MatchResult a -> MatchResult b
fmap :: forall a b. (a -> b) -> MatchResult a -> MatchResult b
$c<$ :: forall a b. a -> MatchResult b -> MatchResult a
<$ :: forall a b. a -> MatchResult b -> MatchResult a
Functor)

-- | Product is an "or" on fallibility---the combined match result is infallible
-- only if the left and right argument match results both were.
--
-- This is useful for combining a bunch of alternatives together and then
-- getting the overall fallibility of the entire group. See 'mkDataConCase' for
-- an example.
instance Applicative MatchResult where
  pure :: forall a. a -> MatchResult a
pure a
v = DsM a -> MatchResult a
forall a. DsM a -> MatchResult a
MR_Infallible (a -> DsM a
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v)
  MR_Infallible DsM (a -> b)
f <*> :: forall a b. MatchResult (a -> b) -> MatchResult a -> MatchResult b
<*> MR_Infallible DsM a
x = DsM b -> MatchResult b
forall a. DsM a -> MatchResult a
MR_Infallible (DsM (a -> b)
f DsM (a -> b) -> DsM a -> DsM b
forall a b.
IOEnv (Env DsGblEnv DsLclEnv) (a -> b)
-> IOEnv (Env DsGblEnv DsLclEnv) a
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DsM a
x)
  MatchResult (a -> b)
f <*> MatchResult a
x = (CoreExpr -> DsM b) -> MatchResult b
forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible ((CoreExpr -> DsM b) -> MatchResult b)
-> (CoreExpr -> DsM b) -> MatchResult b
forall a b. (a -> b) -> a -> b
$ \CoreExpr
fail -> CoreExpr -> MatchResult (a -> b) -> DsM (a -> b)
forall a. CoreExpr -> MatchResult a -> DsM a
runMatchResult CoreExpr
fail MatchResult (a -> b)
f DsM (a -> b) -> DsM a -> DsM b
forall a b.
IOEnv (Env DsGblEnv DsLclEnv) (a -> b)
-> IOEnv (Env DsGblEnv DsLclEnv) a
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreExpr -> MatchResult a -> DsM a
forall a. CoreExpr -> MatchResult a -> DsM a
runMatchResult CoreExpr
fail MatchResult a
x

-- Given a fail expression to use, and a MatchResult CoreExpr, compute the filled CoreExpr whether
-- the MatchResult CoreExpr was failable or not.
runMatchResult :: CoreExpr -> MatchResult a -> DsM a
runMatchResult :: forall a. CoreExpr -> MatchResult a -> DsM a
runMatchResult CoreExpr
fail = \case
  MR_Infallible DsM a
body -> DsM a
body
  MR_Fallible CoreExpr -> DsM a
body_fn -> CoreExpr -> DsM a
body_fn CoreExpr
fail

{-
************************************************************************
*                                                                      *
                Monad functions
*                                                                      *
************************************************************************
-}

-- Compatibility functions
fixDs :: (a -> DsM a) -> DsM a
fixDs :: forall a. (a -> DsM a) -> DsM a
fixDs    = (a -> IOEnv (Env DsGblEnv DsLclEnv) a)
-> IOEnv (Env DsGblEnv DsLclEnv) a
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM

type DsWarning = (SrcSpan, SDoc)
        -- Not quite the same as a WarnMsg, we have an SDoc here
        -- and we'll do the name_ppr_ctx stuff later on to turn it
        -- into a Doc.

-- | Run a 'DsM' action inside the 'TcM' monad.
initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a)
initDsTc :: forall a. DsM a -> TcM (Messages DsMessage, Maybe a)
initDsTc DsM a
thing_inside
  = do { tcg_env  <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; msg_var  <- liftIO $ newIORef emptyMessages
       ; hsc_env  <- getTopEnv
       ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
       ; e_result <- tryM $  -- need to tryM so that we don't discard
                             -- DsMessages
                     setEnvs envs thing_inside
       ; msgs     <- liftIO $ readIORef msg_var
       ; return (msgs, case e_result of Left IOEnvFailure
_  -> Maybe a
forall a. Maybe a
Nothing
                                        Right a
x -> a -> Maybe a
forall a. a -> Maybe a
Just a
x)
       }

-- | Run a 'DsM' action inside the 'IO' monad.
initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a)
initDs :: forall a.
HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a)
initDs HscEnv
hsc_env TcGblEnv
tcg_env DsM a
thing_inside
  = do { msg_var <- Messages DsMessage -> IO (IORef (Messages DsMessage))
forall a. a -> IO (IORef a)
newIORef Messages DsMessage
forall e. Messages e
emptyMessages
       ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
       ; runDs hsc_env envs thing_inside
       }

-- | Build a set of desugarer environments derived from a 'TcGblEnv'.
mkDsEnvsFromTcGbl :: MonadIO m
                  => HscEnv -> IORef (Messages DsMessage) -> TcGblEnv
                  -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl :: forall (m :: * -> *).
MonadIO m =>
HscEnv
-> IORef (Messages DsMessage) -> TcGblEnv -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env IORef (Messages DsMessage)
msg_var TcGblEnv
tcg_env
  = do { cc_st_var   <- IO (IORef CostCentreState) -> m (IORef CostCentreState)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef CostCentreState) -> m (IORef CostCentreState))
-> IO (IORef CostCentreState) -> m (IORef CostCentreState)
forall a b. (a -> b) -> a -> b
$ CostCentreState -> IO (IORef CostCentreState)
forall a. a -> IO (IORef a)
newIORef CostCentreState
newCostCentreState
       ; eps <- liftIO $ hscEPS hsc_env
       ; let unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
             this_mod = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
             type_env = TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
tcg_env
             rdr_env  = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
tcg_env
             fam_inst_env = TcGblEnv -> FamInstEnv
tcg_fam_inst_env TcGblEnv
tcg_env
             ptc = DynFlags -> PromotionTickContext
initPromotionTickContext (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
             -- re-use existing next_wrapper_num to ensure uniqueness
             next_wrapper_num_var = TcGblEnv -> TcRef (ModuleEnv Int)
tcg_next_wrapper_num TcGblEnv
tcg_env

       ; ds_complete_matches <-
           liftIO $ unsafeInterleaveIO $
             -- This call to 'unsafeInterleaveIO' ensures we only do this work
             -- when we need to look at the COMPLETE pragmas, avoiding doing work
             -- when we don't need them.
             --
             -- Relevant test case: MultiLayerModulesTH_Make, which regresses
             -- in allocations by ~5% if we don't do this.
           traverse (lookupCompleteMatch type_env hsc_env) $
             localAndImportedCompleteMatches (tcg_complete_matches tcg_env) hsc_env eps
       ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
                           msg_var cc_st_var next_wrapper_num_var ds_complete_matches
       }

-- | We have in hand the `CompleteMatches` for the module, but when
-- doing pattern-match overlap checking we want the `ConLike` for each
-- data constructor, not just its `Name`.  This function makes the
-- transition.
lookupCompleteMatch :: TypeEnv -> HscEnv -> CompleteMatch -> IO DsCompleteMatch
lookupCompleteMatch :: TypeEnv -> HscEnv -> CompleteMatch -> IO DsCompleteMatch
lookupCompleteMatch TypeEnv
type_env HscEnv
hsc_env (CompleteMatch { cmConLikes :: forall con. CompleteMatchX con -> UniqDSet con
cmConLikes = UniqDSet Name
nms, cmResultTyCon :: forall con. CompleteMatchX con -> Maybe Name
cmResultTyCon = Maybe Name
mb_tc })
  = do { cons <- (Name -> IO ConLike) -> UniqDSet Name -> IO (UniqDSet ConLike)
forall (m :: * -> *) b a.
(Monad m, Uniquable b) =>
(a -> m b) -> UniqDSet a -> m (UniqDSet b)
mapMUniqDSet Name -> IO ConLike
lookup_conLike UniqDSet Name
nms
       ; return $ CompleteMatch { cmConLikes = cons, cmResultTyCon = mb_tc } }
  where
    lookup_conLike :: Name -> IO ConLike
    lookup_conLike :: Name -> IO ConLike
lookup_conLike Name
nm
      | Just TyThing
ty <- Name -> Maybe TyThing
wiredInNameTyThing_maybe Name
nm
      = TyThing -> IO ConLike
go TyThing
ty
      | Just TyThing
ty <- TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
type_env Name
nm
      = TyThing -> IO ConLike
go TyThing
ty
      | Bool
otherwise
      = TyThing -> IO ConLike
go (TyThing -> IO ConLike) -> IO TyThing -> IO ConLike
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
nm
      where
        go :: TyThing -> IO ConLike
        go :: TyThing -> IO ConLike
go (AConLike ConLike
cl) = ConLike -> IO ConLike
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ConLike
cl
        go TyThing
ty = String -> SDoc -> IO ConLike
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookup_conLike not a ConLike" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
ty)

runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a)
runDs :: forall a.
HscEnv
-> (DsGblEnv, DsLclEnv)
-> DsM a
-> IO (Messages DsMessage, Maybe a)
runDs HscEnv
hsc_env (DsGblEnv
ds_gbl, DsLclEnv
ds_lcl) DsM a
thing_inside
  = do { res    <- Char
-> HscEnv
-> DsGblEnv
-> DsLclEnv
-> TcRnIf DsGblEnv DsLclEnv (Either IOEnvFailure a)
-> IO (Either IOEnvFailure a)
forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf Char
'd' HscEnv
hsc_env DsGblEnv
ds_gbl DsLclEnv
ds_lcl
                              (DsM a -> TcRnIf DsGblEnv DsLclEnv (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM DsM a
thing_inside)
       ; msgs   <- readIORef (ds_msgs ds_gbl)
       ; let final_res
               | Messages DsMessage -> Bool
forall e. Diagnostic e => Messages e -> Bool
errorsFound Messages DsMessage
msgs = Maybe a
forall a. Maybe a
Nothing
               | Right a
r <- Either IOEnvFailure a
res   = a -> Maybe a
forall a. a -> Maybe a
Just a
r
               | Bool
otherwise        = String -> Maybe a
forall a. HasCallStack => String -> a
panic String
"initDs"
       ; return (msgs, final_res)
       }

-- | Run a 'DsM' action in the context of an existing 'ModGuts'
initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a)
initDsWithModGuts :: forall a.
HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a)
initDsWithModGuts HscEnv
hsc_env (ModGuts { mg_module :: ModGuts -> Module
mg_module = Module
this_mod, mg_binds :: ModGuts -> CoreProgram
mg_binds = CoreProgram
binds
                                   , mg_tcs :: ModGuts -> [TyCon]
mg_tcs = [TyCon]
tycons, mg_fam_insts :: ModGuts -> [FamInst]
mg_fam_insts = [FamInst]
fam_insts
                                   , mg_patsyns :: ModGuts -> [PatSyn]
mg_patsyns = [PatSyn]
patsyns, mg_rdr_env :: ModGuts -> GlobalRdrEnv
mg_rdr_env = GlobalRdrEnv
rdr_env
                                   , mg_fam_inst_env :: ModGuts -> FamInstEnv
mg_fam_inst_env = FamInstEnv
fam_inst_env
                                   , mg_complete_matches :: ModGuts -> [CompleteMatch]
mg_complete_matches = [CompleteMatch]
local_complete_matches
                          }) DsM a
thing_inside
  = do { cc_st_var   <- CostCentreState -> IO (IORef CostCentreState)
forall a. a -> IO (IORef a)
newIORef CostCentreState
newCostCentreState
       ; next_wrapper_num <- newIORef emptyModuleEnv
       ; msg_var <- newIORef emptyMessages
       ; eps <- liftIO $ hscEPS hsc_env
       ; let unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
             type_env = [EvVar] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv
typeEnvFromEntities [EvVar]
ids [TyCon]
tycons [PatSyn]
patsyns [FamInst]
fam_insts
             ptc = DynFlags -> PromotionTickContext
initPromotionTickContext (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
             bindsToIds (NonRec a
v Expr a
_)   = [a
v]
             bindsToIds (Rec    [(a, Expr a)]
binds) = ((a, Expr a) -> a) -> [(a, Expr a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Expr a) -> a
forall a b. (a, b) -> a
fst [(a, Expr a)]
binds
             ids = (Bind EvVar -> [EvVar]) -> CoreProgram -> [EvVar]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind EvVar -> [EvVar]
forall {a}. Bind a -> [a]
bindsToIds CoreProgram
binds
       ; ds_complete_matches <- traverse (lookupCompleteMatch type_env hsc_env) $
            localAndImportedCompleteMatches local_complete_matches hsc_env eps
       ; let
             envs  = UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage)
-> IORef CostCentreState
-> TcRef (ModuleEnv Int)
-> [DsCompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs UnitEnv
unit_env Module
this_mod GlobalRdrEnv
rdr_env TypeEnv
type_env
                              FamInstEnv
fam_inst_env PromotionTickContext
ptc IORef (Messages DsMessage)
msg_var IORef CostCentreState
cc_st_var
                              TcRef (ModuleEnv Int)
next_wrapper_num [DsCompleteMatch]
ds_complete_matches
       ; runDs hsc_env envs thing_inside
       }

initTcDsForSolver :: TcM a -> DsM a
-- Spin up a TcM context so that we can run the constraint solver
-- Returns any error messages generated by the constraint solver
-- and (Just res) if no error happened; Nothing if an error happened
--
-- Simon says: I'm not very happy about this.  We spin up a complete TcM monad
--             only to immediately refine it to a TcS monad.
-- Better perhaps to make TcS into its own monad, rather than building on TcS
-- But that may in turn interact with plugins

initTcDsForSolver :: forall a. TcM a -> DsM a
initTcDsForSolver TcM a
thing_inside
  = do { (gbl, lcl) <- TcRnIf DsGblEnv DsLclEnv (DsGblEnv, DsLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs
       ; hsc_env    <- getTopEnv

         -- The DsGblEnv is used to inform the typechecker's solver of a few
         -- key pieces of information:
         --
         --  - ds_fam_inst_env tells it how to reduce type families,
         --  - ds_gbl_rdr_env  tells it which newtypes it can unwrap.
       ; let DsGblEnv { ds_mod = mod
                      , ds_fam_inst_env = fam_inst_env
                      , ds_gbl_rdr_env  = rdr_env
                      } = gbl
             DsLclEnv { dsl_loc = loc } = lcl

       ; (msgs, mb_ret) <- liftIO $ initTc hsc_env HsSrcFile False mod loc $
         updGblEnv (\TcGblEnv
tc_gbl -> TcGblEnv
tc_gbl { tcg_fam_inst_env = fam_inst_env
                                      , tcg_rdr_env      = rdr_env }) $
         thing_inside
       ; case mb_ret of
           Just a
ret -> a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ret
           Maybe a
Nothing  -> String -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"initTcDsForSolver" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope TcRnMessage) -> [SDoc]
forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLocDefault (Messages TcRnMessage -> Bag (MsgEnvelope TcRnMessage)
forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getErrorMessages Messages TcRnMessage
msgs)) }

mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
         -> PromotionTickContext
         -> IORef (Messages DsMessage) -> IORef CostCentreState
         -> IORef (ModuleEnv Int) -> DsCompleteMatches
         -> (DsGblEnv, DsLclEnv)
mkDsEnvs :: UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage)
-> IORef CostCentreState
-> TcRef (ModuleEnv Int)
-> [DsCompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs UnitEnv
unit_env Module
mod GlobalRdrEnv
rdr_env TypeEnv
type_env FamInstEnv
fam_inst_env PromotionTickContext
ptc IORef (Messages DsMessage)
msg_var IORef CostCentreState
cc_st_var
         TcRef (ModuleEnv Int)
next_wrapper_num [DsCompleteMatch]
complete_matches
  = let if_genv :: IfGblEnv
if_genv = IfGblEnv { if_doc :: SDoc
if_doc       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"mkDsEnvs"
  -- Failing tests here are `ghci` and `T11985` if you get this wrong.
  -- this is very very "at a distance" because the reason for this check is that the type_env in interactive
  -- mode is the smushed together of all the interactive modules.
  -- See Note [Why is KnotVars not a ModuleEnv]
                             , if_rec_types :: KnotVars (IfG TypeEnv)
if_rec_types = [Module]
-> (Module -> Maybe (IfG TypeEnv)) -> KnotVars (IfG TypeEnv)
forall a. [Module] -> (Module -> Maybe a) -> KnotVars a
KnotVars [Module
mod] (\Module
that_mod -> if Module
that_mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
mod Bool -> Bool -> Bool
|| Module -> Bool
isInteractiveModule Module
mod
                                                          then IfG TypeEnv -> Maybe (IfG TypeEnv)
forall a. a -> Maybe a
Just (TypeEnv -> IfG TypeEnv
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return TypeEnv
type_env)
                                                          else Maybe (IfG TypeEnv)
forall a. Maybe a
Nothing) }
        if_lenv :: IfLclEnv
if_lenv = Module -> SDoc -> IsBootInterface -> IfLclEnv
mkIfLclEnv Module
mod (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"GHC error in desugarer lookup in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
                             IsBootInterface
NotBoot
        real_span :: RealSrcSpan
real_span = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)) Int
1 Int
1)
        gbl_env :: DsGblEnv
gbl_env = DsGblEnv { ds_mod :: Module
ds_mod     = Module
mod
                           , ds_fam_inst_env :: FamInstEnv
ds_fam_inst_env = FamInstEnv
fam_inst_env
                           , ds_gbl_rdr_env :: GlobalRdrEnv
ds_gbl_rdr_env  = GlobalRdrEnv
rdr_env
                           , ds_if_env :: (IfGblEnv, IfLclEnv)
ds_if_env  = (IfGblEnv
if_genv, IfLclEnv
if_lenv)
                           , ds_name_ppr_ctx :: NamePprCtx
ds_name_ppr_ctx = PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
forall info.
Outputable info =>
PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
mkNamePprCtx PromotionTickContext
ptc UnitEnv
unit_env GlobalRdrEnv
rdr_env
                           , ds_msgs :: IORef (Messages DsMessage)
ds_msgs    = IORef (Messages DsMessage)
msg_var
                           , ds_complete_matches :: [DsCompleteMatch]
ds_complete_matches = [DsCompleteMatch]
complete_matches
                           , ds_cc_st :: IORef CostCentreState
ds_cc_st   = IORef CostCentreState
cc_st_var
                           , ds_next_wrapper_num :: TcRef (ModuleEnv Int)
ds_next_wrapper_num = TcRef (ModuleEnv Int)
next_wrapper_num
                           }
        lcl_env :: DsLclEnv
lcl_env = DsLclEnv { dsl_meta :: DsMetaEnv
dsl_meta        = DsMetaEnv
forall a. NameEnv a
emptyNameEnv
                           , dsl_loc :: RealSrcSpan
dsl_loc         = RealSrcSpan
real_span
                           , dsl_nablas :: Nablas
dsl_nablas      = Nablas
initNablas
                           , dsl_unspecables :: Set EvVar
dsl_unspecables = Set EvVar
forall a. Monoid a => a
mempty
                           }
    in (DsGblEnv
gbl_env, DsLclEnv
lcl_env)


{-
************************************************************************
*                                                                      *
                Operations in the monad
*                                                                      *
************************************************************************

And all this mysterious stuff is so we can occasionally reach out and
grab one or more names.  @newLocalDs@ isn't exported---exported
functions are defined with it.  The difference in name-strings makes
it easier to read debugging output.

-}

-- Make a new Id with the same print name, but different type, and new unique
newUniqueId :: Id -> Mult -> Type -> DsM Id
newUniqueId :: EvVar -> Mult -> Mult -> DsM EvVar
newUniqueId EvVar
id = FastString -> Mult -> Mult -> DsM EvVar
forall (m :: * -> *).
MonadUnique m =>
FastString -> Mult -> Mult -> m EvVar
mkSysLocalOrCoVarM (OccName -> FastString
occNameFS (Name -> OccName
nameOccName (EvVar -> Name
idName EvVar
id)))

duplicateLocalDs :: Id -> DsM Id
duplicateLocalDs :: EvVar -> DsM EvVar
duplicateLocalDs EvVar
old_local
  = do  { uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
        ; return (setIdUnique old_local uniq) }

newPredVarDs :: PredType -> DsM Var
newPredVarDs :: Mult -> DsM EvVar
newPredVarDs
 = FastString -> Mult -> Mult -> DsM EvVar
forall (m :: * -> *).
MonadUnique m =>
FastString -> Mult -> Mult -> m EvVar
mkSysLocalOrCoVarM (String -> FastString
fsLit String
"ds") Mult
ManyTy  -- like newSysLocalDs, but we allow covars

newSysLocalMDs, newFailLocalMDs :: Type -> DsM Id
-- Implicitly have ManyTy multiplicity, hence the "M"
newSysLocalMDs :: Mult -> DsM EvVar
newSysLocalMDs  = FastString -> Mult -> Mult -> DsM EvVar
forall (m :: * -> *).
MonadUnique m =>
FastString -> Mult -> Mult -> m EvVar
mkSysLocalM (String -> FastString
fsLit String
"ds")    Mult
ManyTy
newFailLocalMDs :: Mult -> DsM EvVar
newFailLocalMDs = FastString -> Mult -> Mult -> DsM EvVar
forall (m :: * -> *).
MonadUnique m =>
FastString -> Mult -> Mult -> m EvVar
mkSysLocalM (String -> FastString
fsLit String
"fail") Mult
ManyTy

newSysLocalsMDs :: [Type] -> DsM [Id]
newSysLocalsMDs :: [Mult] -> DsM [EvVar]
newSysLocalsMDs = (Mult -> DsM EvVar) -> [Mult] -> DsM [EvVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Mult -> DsM EvVar
newSysLocalMDs

newSysLocalDs :: Scaled Type -> DsM Id
newSysLocalDs :: Scaled Mult -> DsM EvVar
newSysLocalDs (Scaled Mult
w Mult
t) = FastString -> Mult -> Mult -> DsM EvVar
forall (m :: * -> *).
MonadUnique m =>
FastString -> Mult -> Mult -> m EvVar
mkSysLocalM (String -> FastString
fsLit String
"ds") Mult
w Mult
t

newSysLocalsDs :: [Scaled Type] -> DsM [Id]
newSysLocalsDs :: [Scaled Mult] -> DsM [EvVar]
newSysLocalsDs = (Scaled Mult -> DsM EvVar) -> [Scaled Mult] -> DsM [EvVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Scaled Mult -> DsM EvVar
newSysLocalDs

{-
We can also reach out and either set/grab location information from
the @SrcSpan@ being carried around.
-}

getGhcModeDs :: DsM GhcMode
getGhcModeDs :: DsM GhcMode
getGhcModeDs =  IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags IOEnv (Env DsGblEnv DsLclEnv) DynFlags
-> (DynFlags -> DsM GhcMode) -> DsM GhcMode
forall a b.
IOEnv (Env DsGblEnv DsLclEnv) a
-> (a -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GhcMode -> DsM GhcMode
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GhcMode -> DsM GhcMode)
-> (DynFlags -> GhcMode) -> DynFlags -> DsM GhcMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> GhcMode
ghcMode

-- | Get the current pattern match oracle state. See 'dsl_nablas'.
getPmNablas :: DsM Nablas
getPmNablas :: DsM Nablas
getPmNablas = do { env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (dsl_nablas env) }

-- | Set the pattern match oracle state within the scope of the given action.
-- See 'dsl_nablas'.
updPmNablas :: Nablas -> DsM a -> DsM a
updPmNablas :: forall a. Nablas -> DsM a -> DsM a
updPmNablas Nablas
nablas = (DsLclEnv -> DsLclEnv)
-> TcRnIf DsGblEnv DsLclEnv a -> TcRnIf DsGblEnv DsLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\DsLclEnv
env -> DsLclEnv
env { dsl_nablas = nablas })

addUnspecables :: S.Set EvId -> DsM a -> DsM a
addUnspecables :: forall a. Set EvVar -> DsM a -> DsM a
addUnspecables Set EvVar
unspecables = (DsLclEnv -> DsLclEnv)
-> TcRnIf DsGblEnv DsLclEnv a -> TcRnIf DsGblEnv DsLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\DsLclEnv
env -> DsLclEnv
env{ dsl_unspecables = unspecables `mappend` dsl_unspecables env })

zapUnspecables :: DsM a -> DsM a
zapUnspecables :: forall a. DsM a -> DsM a
zapUnspecables = (DsLclEnv -> DsLclEnv)
-> TcRnIf DsGblEnv DsLclEnv a -> TcRnIf DsGblEnv DsLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\DsLclEnv
env -> DsLclEnv
env{ dsl_unspecables = mempty })

getUnspecables :: DsM (S.Set EvId)
getUnspecables :: DsM (Set EvVar)
getUnspecables = DsLclEnv -> Set EvVar
dsl_unspecables (DsLclEnv -> Set EvVar)
-> TcRnIf DsGblEnv DsLclEnv DsLclEnv -> DsM (Set EvVar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv

getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
                  ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }

putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs :: forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (UnhelpfulSpan {}) DsM a
thing_inside
  = DsM a
thing_inside
putSrcSpanDs (RealSrcSpan RealSrcSpan
real_span Maybe BufSpan
_) DsM a
thing_inside
  = (DsLclEnv -> DsLclEnv) -> DsM a -> DsM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ DsLclEnv
env -> DsLclEnv
env {dsl_loc = real_span}) DsM a
thing_inside

putSrcSpanDsA :: EpAnn ann -> DsM a -> DsM a
putSrcSpanDsA :: forall ann a. EpAnn ann -> DsM a -> DsM a
putSrcSpanDsA EpAnn ann
loc = SrcSpan -> DsM a -> DsM a
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (EpAnn ann -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn ann
loc)

-- | Emit a diagnostic for the current source location. In case the diagnostic is a warning,
-- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags.
-- See Note [Discarding Messages] in 'GHC.Types.Error'.
diagnosticDs :: DsMessage -> DsM ()
diagnosticDs :: DsMessage -> DsM ()
diagnosticDs DsMessage
dsMessage
  = do { env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; loc <- getSrcSpanDs
       ; !diag_opts <- initDiagOpts <$> getDynFlags
       ; let msg = DiagOpts
-> SrcSpan -> NamePprCtx -> DsMessage -> MsgEnvelope DsMessage
forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkMsgEnvelope DiagOpts
diag_opts SrcSpan
loc (DsGblEnv -> NamePprCtx
ds_name_ppr_ctx DsGblEnv
env) DsMessage
dsMessage
       ; updMutVar (ds_msgs env) (\ Messages DsMessage
msgs -> MsgEnvelope DsMessage
msg MsgEnvelope DsMessage -> Messages DsMessage -> Messages DsMessage
forall e. MsgEnvelope e -> Messages e -> Messages e
`addMessage` Messages DsMessage
msgs) }

-- | Issue an error, but return the expression for (), so that we can continue
-- reporting errors.
errDsCoreExpr :: DsMessage -> DsM CoreExpr
errDsCoreExpr :: DsMessage -> DsM CoreExpr
errDsCoreExpr DsMessage
msg
  = do { DsMessage -> DsM ()
diagnosticDs DsMessage
msg
       ; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
unitExpr }

failWithDs :: DsMessage -> DsM a
failWithDs :: forall a. DsMessage -> DsM a
failWithDs DsMessage
msg
  = do  { DsMessage -> DsM ()
diagnosticDs DsMessage
msg
        ; IOEnv (Env DsGblEnv DsLclEnv) a
forall env a. IOEnv env a
failM }

failDs :: DsM a
failDs :: forall a. DsM a
failDs = IOEnv (Env DsGblEnv DsLclEnv) a
forall env a. IOEnv env a
failM

mkNamePprCtxDs :: DsM NamePprCtx
mkNamePprCtxDs :: DsM NamePprCtx
mkNamePprCtxDs = DsGblEnv -> NamePprCtx
ds_name_ppr_ctx (DsGblEnv -> NamePprCtx)
-> TcRnIf DsGblEnv DsLclEnv DsGblEnv -> DsM NamePprCtx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv

instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
    lookupThing :: Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
lookupThing = Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal

dsLookupGlobal :: Name -> DsM TyThing
-- Very like GHC.Tc.Utils.Env.tcLookupGlobal
dsLookupGlobal :: Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal Name
name
  = do  { env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; setEnvs (ds_if_env env)
                  (tcIfaceGlobal name) }

dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId :: Name -> DsM EvVar
dsLookupGlobalId Name
name
  = HasDebugCallStack => TyThing -> EvVar
TyThing -> EvVar
tyThingId (TyThing -> EvVar)
-> IOEnv (Env DsGblEnv DsLclEnv) TyThing -> DsM EvVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal Name
name

dsLookupTyCon :: Name -> DsM TyCon
dsLookupTyCon :: Name -> IOEnv (Env DsGblEnv DsLclEnv) TyCon
dsLookupTyCon Name
name
  = HasDebugCallStack => TyThing -> TyCon
TyThing -> TyCon
tyThingTyCon (TyThing -> TyCon)
-> IOEnv (Env DsGblEnv DsLclEnv) TyThing
-> IOEnv (Env DsGblEnv DsLclEnv) TyCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal Name
name

dsLookupDataCon :: Name -> DsM DataCon
dsLookupDataCon :: Name -> IOEnv (Env DsGblEnv DsLclEnv) DataCon
dsLookupDataCon Name
name
  = HasDebugCallStack => TyThing -> DataCon
TyThing -> DataCon
tyThingDataCon (TyThing -> DataCon)
-> IOEnv (Env DsGblEnv DsLclEnv) TyThing
-> IOEnv (Env DsGblEnv DsLclEnv) DataCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal Name
name

dsLookupConLike :: Name -> DsM ConLike
dsLookupConLike :: Name -> DsM ConLike
dsLookupConLike Name
name
  = HasDebugCallStack => TyThing -> ConLike
TyThing -> ConLike
tyThingConLike (TyThing -> ConLike)
-> IOEnv (Env DsGblEnv DsLclEnv) TyThing -> DsM ConLike
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal Name
name


dsGetFamInstEnvs :: DsM FamInstEnvs
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
dsGetFamInstEnvs :: DsM FamInstEnvs
dsGetFamInstEnvs
  = do { eps <- TcRnIf DsGblEnv DsLclEnv ExternalPackageState
forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps; env <- getGblEnv
       ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }

dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv :: DsM DsMetaEnv
dsGetMetaEnv = do { env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (dsl_meta env) }

dsGetGlobalRdrEnv :: DsM GlobalRdrEnv
dsGetGlobalRdrEnv :: DsM GlobalRdrEnv
dsGetGlobalRdrEnv = DsGblEnv -> GlobalRdrEnv
ds_gbl_rdr_env (DsGblEnv -> GlobalRdrEnv)
-> TcRnIf DsGblEnv DsLclEnv DsGblEnv -> DsM GlobalRdrEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv

-- | The @COMPLETE@ pragmas that are in scope.
dsGetCompleteMatches :: DsM DsCompleteMatches
dsGetCompleteMatches :: DsM [DsCompleteMatch]
dsGetCompleteMatches = DsGblEnv -> [DsCompleteMatch]
ds_complete_matches (DsGblEnv -> [DsCompleteMatch])
-> TcRnIf DsGblEnv DsLclEnv DsGblEnv -> DsM [DsCompleteMatch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv

dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv Name
name = do { env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (lookupNameEnv (dsl_meta env) name) }

dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv :: forall a. DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv DsMetaEnv
menv DsM a
thing_inside
  = (DsLclEnv -> DsLclEnv) -> DsM a -> DsM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\DsLclEnv
env -> DsLclEnv
env { dsl_meta = dsl_meta env `plusNameEnv` menv }) DsM a
thing_inside

discardWarningsDs :: DsM a -> DsM a
-- Ignore warnings inside the thing inside;
-- used to ignore inaccessible cases etc. inside generated code
discardWarningsDs :: forall a. DsM a -> DsM a
discardWarningsDs DsM a
thing_inside
  = do  { env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; old_msgs <- readTcRef (ds_msgs env)

        ; result <- thing_inside

        -- Revert messages to old_msgs
        ; writeTcRef (ds_msgs env) old_msgs

        ; return result }

-- | Inject a trace message into the compiled program. Whereas
-- pprTrace prints out information *while compiling*, pprRuntimeTrace
-- captures that information and causes it to be printed *at runtime*
-- using Debug.Trace.trace.
--
--   pprRuntimeTrace hdr doc expr
--
-- will produce an expression that looks like
--
--   trace (hdr + doc) expr
--
-- When using this to debug a module that Debug.Trace depends on,
-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
-- but that doesn't seem worth the effort and maintenance cost.
pprRuntimeTrace :: String   -- ^ header
                -> SDoc     -- ^ information to output
                -> CoreExpr -- ^ expression
                -> DsM CoreExpr
pprRuntimeTrace :: String -> SDoc -> CoreExpr -> DsM CoreExpr
pprRuntimeTrace String
str SDoc
doc CoreExpr
expr = do
  traceId <- Name -> DsM EvVar
dsLookupGlobalId Name
traceName
  unpackCStringId <- dsLookupGlobalId unpackCStringName
  dflags <- getDynFlags
  let message :: CoreExpr
      message = CoreExpr -> DsWrapper
forall b. Expr b -> Expr b -> Expr b
App (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
unpackCStringId) DsWrapper -> DsWrapper
forall a b. (a -> b) -> a -> b
$
                Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr) -> Literal -> CoreExpr
forall a b. (a -> b) -> a -> b
$ String -> Literal
mkLitString (String -> Literal) -> String -> Literal
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
str) Int
4 SDoc
doc)
  return $ mkApps (Var traceId) [Type (exprType expr), message, expr]

-- | See 'getCCIndexM'.
getCCIndexDsM :: FastString -> DsM CostCentreIndex
getCCIndexDsM :: FastString -> DsM CostCentreIndex
getCCIndexDsM = (DsGblEnv -> IORef CostCentreState)
-> FastString -> DsM CostCentreIndex
forall gbl lcl.
(gbl -> IORef CostCentreState)
-> FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM DsGblEnv -> IORef CostCentreState
ds_cc_st