{-# 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, newSysLocalDsNoLP, newSysLocalDs,
        newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,
        newFailLocalDs, newPredVarDs,
        getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
        mkPrintUnqualifiedDs,
        newUnique,
        UniqSupply, newUniqueSupply,
        getGhcModeDs, dsGetFamInstEnvs,
        dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
        dsLookupDataCon, dsLookupConLike,
        getCCIndexDsM,

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

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

        -- Get COMPLETE sets of a TyCon
        dsGetCompleteMatches,

        -- Warnings and errors
        DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
        failWithDs, failDs, discardWarningsDs,
        askNoErrsDs,

        -- Data types
        DsMatchContext(..),
        EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,

        -- Levity polymorphism
        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,

        -- Trace injection
        pprRuntimeTrace
    ) where

import GHC.Prelude

import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Ppr

import GHC.Hs

import GHC.HsToCore.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, isExprLevPoly )
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.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr )

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.Basic ( Origin )
import GHC.Types.SourceFile
import GHC.Types.Id
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.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Error

import Data.IORef

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

data DsMatchContext
  = DsMatchContext (HsMatchContext GhcRn) SrcSpan
  deriving ()

instance Outputable DsMatchContext where
  ppr :: DsMatchContext -> SDoc
ppr (DsMatchContext HsMatchContext GhcRn
hs_match SrcSpan
ss) = forall a. Outputable a => a -> SDoc
ppr SrcSpan
ss SDoc -> SDoc -> SDoc
<+> forall p.
(Outputable (IdP p), UnXRec p) =>
HsMatchContext p -> SDoc
pprMatchContext HsMatchContext GhcRn
hs_match

data EquationInfo
  = EqnInfo { EquationInfo -> [Pat GhcTc]
eqn_pats :: [Pat GhcTc]
              -- ^ The patterns for an equation
              --
              -- NB: We have /already/ applied 'decideBangHood' to
              -- these patterns.  See Note [decideBangHood] in "GHC.HsToCore.Utils"

            , EquationInfo -> Origin
eqn_orig :: Origin
              -- ^ Was this equation present in the user source?
              --
              -- This helps us avoid warnings on patterns that GHC elaborated.
              --
              -- For instance, the pattern @-1 :: Word@ gets desugared into
              -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
              -- literal for /both/ of these cases.

            , EquationInfo -> MatchResult CoreExpr
eqn_rhs  :: MatchResult CoreExpr
              -- ^ What to do after match
            }

instance Outputable EquationInfo where
    ppr :: EquationInfo -> SDoc
ppr (EqnInfo [Pat GhcTc]
pats Origin
_ MatchResult CoreExpr
_) = forall a. Outputable a => a -> SDoc
ppr [Pat GhcTc]
pats

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 -> 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
<$ :: forall a b. a -> MatchResult b -> MatchResult a
$c<$ :: forall a b. a -> MatchResult b -> MatchResult a
fmap :: forall a b. (a -> b) -> MatchResult a -> MatchResult b
$cfmap :: forall a b. (a -> b) -> MatchResult a -> MatchResult b
Functor)

-- | Product is an "or" on falliblity---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 falliblity of the entire group. See 'mkDataConCase' for
-- an example.
instance Applicative MatchResult where
  pure :: forall a. a -> MatchResult a
pure a
v = forall a. DsM a -> MatchResult a
MR_Infallible (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 = forall a. DsM a -> MatchResult a
MR_Infallible (DsM (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DsM a
x)
  MatchResult (a -> b)
f <*> MatchResult a
x = forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible forall a b. (a -> b) -> a -> b
$ \CoreExpr
fail -> forall a. CoreExpr -> MatchResult a -> DsM a
runMatchResult CoreExpr
fail MatchResult (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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    = 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 print_unqual stuff later on to turn it
        -- into a Doc.

-- | Run a 'DsM' action inside the 'TcM' monad.
initDsTc :: DsM a -> TcM a
initDsTc :: forall a. DsM a -> TcM a
initDsTc DsM a
thing_inside
  = do { TcGblEnv
tcg_env  <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; TcRef (Messages DecoratedSDoc)
msg_var  <- TcRn (TcRef (Messages DecoratedSDoc))
getErrsVar
       ; HscEnv
hsc_env  <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
       ; (DsGblEnv, DsLclEnv)
envs     <- forall (m :: * -> *).
MonadIO m =>
HscEnv
-> TcRef (Messages DecoratedSDoc)
-> TcGblEnv
-> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env TcRef (Messages DecoratedSDoc)
msg_var TcGblEnv
tcg_env
       ; forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (DsGblEnv, DsLclEnv)
envs DsM a
thing_inside
       }

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

-- | Build a set of desugarer environments derived from a 'TcGblEnv'.
mkDsEnvsFromTcGbl :: MonadIO m
                  => HscEnv -> IORef (Messages DecoratedSDoc) -> TcGblEnv
                  -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl :: forall (m :: * -> *).
MonadIO m =>
HscEnv
-> TcRef (Messages DecoratedSDoc)
-> TcGblEnv
-> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env TcRef (Messages DecoratedSDoc)
msg_var TcGblEnv
tcg_env
  = do { IORef CostCentreState
cc_st_var   <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef CostCentreState
newCostCentreState
       ; ExternalPackageState
eps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
       ; let unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
             this_mod :: Module
this_mod = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
             type_env :: TypeEnv
type_env = TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
tcg_env
             rdr_env :: GlobalRdrEnv
rdr_env  = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
tcg_env
             fam_inst_env :: FamInstEnv
fam_inst_env = TcGblEnv -> FamInstEnv
tcg_fam_inst_env TcGblEnv
tcg_env
             complete_matches :: [CompleteMatch]
complete_matches = HscEnv -> [CompleteMatch]
hptCompleteSigs HscEnv
hsc_env         -- from the home package
                                forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [CompleteMatch]
tcg_complete_matches TcGblEnv
tcg_env -- from the current module
                                forall a. [a] -> [a] -> [a]
++ ExternalPackageState -> [CompleteMatch]
eps_complete_matches ExternalPackageState
eps     -- from imports
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> TcRef (Messages DecoratedSDoc)
-> IORef CostCentreState
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs UnitEnv
unit_env Module
this_mod GlobalRdrEnv
rdr_env TypeEnv
type_env FamInstEnv
fam_inst_env
                           TcRef (Messages DecoratedSDoc)
msg_var IORef CostCentreState
cc_st_var [CompleteMatch]
complete_matches
       }

runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)
runDs :: forall a.
HscEnv
-> (DsGblEnv, DsLclEnv)
-> DsM a
-> IO (Messages DecoratedSDoc, Maybe a)
runDs HscEnv
hsc_env (DsGblEnv
ds_gbl, DsLclEnv
ds_lcl) DsM a
thing_inside
  = do { Either IOEnvFailure a
res    <- 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
                              (forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM DsM a
thing_inside)
       ; Messages DecoratedSDoc
msgs   <- forall a. IORef a -> IO a
readIORef (DsGblEnv -> TcRef (Messages DecoratedSDoc)
ds_msgs DsGblEnv
ds_gbl)
       ; let final_res :: Maybe a
final_res
               | forall e. Messages e -> Bool
errorsFound Messages DecoratedSDoc
msgs = forall a. Maybe a
Nothing
               | Right a
r <- Either IOEnvFailure a
res   = forall a. a -> Maybe a
Just a
r
               | Bool
otherwise        = forall a. String -> a
panic String
"initDs"
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (Messages DecoratedSDoc
msgs, Maybe a
final_res)
       }

-- | Run a 'DsM' action in the context of an existing 'ModGuts'
initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)
initDsWithModGuts :: forall a.
HscEnv -> ModGuts -> DsM a -> IO (Messages DecoratedSDoc, 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 { IORef CostCentreState
cc_st_var   <- forall a. a -> IO (IORef a)
newIORef CostCentreState
newCostCentreState
       ; TcRef (Messages DecoratedSDoc)
msg_var <- forall a. a -> IO (IORef a)
newIORef forall e. Messages e
emptyMessages
       ; ExternalPackageState
eps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
       ; let unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
             type_env :: TypeEnv
type_env = [Id] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv
typeEnvFromEntities [Id]
ids [TyCon]
tycons [PatSyn]
patsyns [FamInst]
fam_insts
             complete_matches :: [CompleteMatch]
complete_matches = HscEnv -> [CompleteMatch]
hptCompleteSigs HscEnv
hsc_env     -- from the home package
                                forall a. [a] -> [a] -> [a]
++ [CompleteMatch]
local_complete_matches  -- from the current module
                                forall a. [a] -> [a] -> [a]
++ ExternalPackageState -> [CompleteMatch]
eps_complete_matches ExternalPackageState
eps -- from imports

             bindsToIds :: Bind a -> [a]
bindsToIds (NonRec a
v Expr a
_)   = [a
v]
             bindsToIds (Rec    [(a, Expr a)]
binds) = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, Expr a)]
binds
             ids :: [Id]
ids = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. Bind a -> [a]
bindsToIds CoreProgram
binds

             envs :: (DsGblEnv, DsLclEnv)
envs  = UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> TcRef (Messages DecoratedSDoc)
-> IORef CostCentreState
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs UnitEnv
unit_env Module
this_mod GlobalRdrEnv
rdr_env TypeEnv
type_env
                              FamInstEnv
fam_inst_env TcRef (Messages DecoratedSDoc)
msg_var IORef CostCentreState
cc_st_var
                              [CompleteMatch]
complete_matches
       ; forall a.
HscEnv
-> (DsGblEnv, DsLclEnv)
-> DsM a
-> IO (Messages DecoratedSDoc, Maybe a)
runDs HscEnv
hsc_env (DsGblEnv, DsLclEnv)
envs DsM a
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 { (DsGblEnv
gbl, DsLclEnv
lcl) <- forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs
       ; HscEnv
hsc_env    <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv

       ; let DsGblEnv { ds_mod :: DsGblEnv -> Module
ds_mod = Module
mod
                      , ds_fam_inst_env :: DsGblEnv -> FamInstEnv
ds_fam_inst_env = FamInstEnv
fam_inst_env
                      , ds_gbl_rdr_env :: DsGblEnv -> GlobalRdrEnv
ds_gbl_rdr_env  = GlobalRdrEnv
rdr_env }      = DsGblEnv
gbl
       -- This is *the* use of ds_gbl_rdr_env:
       -- Make sure the solver (used by the pattern-match overlap checker) has
       -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it
       -- knows how to reduce type families, and which newtypes it can unwrap.


             DsLclEnv { dsl_loc :: DsLclEnv -> RealSrcSpan
dsl_loc = RealSrcSpan
loc }                  = DsLclEnv
lcl

       ; (Messages DecoratedSDoc
msgs, Maybe a
mb_ret) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTc HscEnv
hsc_env HscSource
HsSrcFile Bool
False Module
mod RealSrcSpan
loc forall a b. (a -> b) -> a -> b
$
         forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\TcGblEnv
tc_gbl -> TcGblEnv
tc_gbl { tcg_fam_inst_env :: FamInstEnv
tcg_fam_inst_env = FamInstEnv
fam_inst_env
                                      , tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env      = GlobalRdrEnv
rdr_env }) forall a b. (a -> b) -> a -> b
$
         TcM a
thing_inside
       ; case Maybe a
mb_ret of
           Just a
ret -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ret
           Maybe a
Nothing  -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"initTcDsForSolver" ([SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope DecoratedSDoc) -> [SDoc]
pprMsgEnvelopeBagWithLoc (forall e. Messages e -> Bag (MsgEnvelope e)
getErrorMessages Messages DecoratedSDoc
msgs)) }

mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
         -> IORef (Messages DecoratedSDoc) -> IORef CostCentreState -> CompleteMatches
         -> (DsGblEnv, DsLclEnv)
mkDsEnvs :: UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> TcRef (Messages DecoratedSDoc)
-> IORef CostCentreState
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs UnitEnv
unit_env Module
mod GlobalRdrEnv
rdr_env TypeEnv
type_env FamInstEnv
fam_inst_env TcRef (Messages DecoratedSDoc)
msg_var IORef CostCentreState
cc_st_var
         [CompleteMatch]
complete_matches
  = let if_genv :: IfGblEnv
if_genv = IfGblEnv { if_doc :: SDoc
if_doc       = String -> SDoc
text String
"mkDsEnvs",
                             if_rec_types :: Maybe (Module, IfG TypeEnv)
if_rec_types = forall a. a -> Maybe a
Just (Module
mod, forall (m :: * -> *) a. Monad m => a -> m a
return TypeEnv
type_env) }
        if_lenv :: IfLclEnv
if_lenv = Module -> SDoc -> IsBootInterface -> IfLclEnv
mkIfLclEnv Module
mod (String -> SDoc
text String
"GHC error in desugarer lookup in" SDoc -> SDoc -> 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 (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_unqual :: PrintUnqualified
ds_unqual  = UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified UnitEnv
unit_env GlobalRdrEnv
rdr_env
                           , ds_msgs :: TcRef (Messages DecoratedSDoc)
ds_msgs    = TcRef (Messages DecoratedSDoc)
msg_var
                           , ds_complete_matches :: [CompleteMatch]
ds_complete_matches = [CompleteMatch]
complete_matches
                           , ds_cc_st :: IORef CostCentreState
ds_cc_st   = IORef CostCentreState
cc_st_var
                           }
        lcl_env :: DsLclEnv
lcl_env = DsLclEnv { dsl_meta :: DsMetaEnv
dsl_meta    = forall a. NameEnv a
emptyNameEnv
                           , dsl_loc :: RealSrcSpan
dsl_loc     = RealSrcSpan
real_span
                           , dsl_nablas :: Nablas
dsl_nablas  = Nablas
initNablas
                           }
    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.

Note [Levity polymorphism checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
According to the "Levity Polymorphism" paper (PLDI '17), levity
polymorphism is forbidden in precisely two places: in the type of a bound
term-level argument and in the type of an argument to a function. The paper
explains it more fully, but briefly: expressions in these contexts need to be
stored in registers, and it's hard (read, impossible) to store something
that's levity polymorphic.

We cannot check for bad levity polymorphism conveniently in the type checker,
because we can't tell, a priori, which levity metavariables will be solved.
At one point, I (Richard) thought we could check in the zonker, but it's hard
to know where precisely are the abstracted variables and the arguments. So
we check in the desugarer, the only place where we can see the Core code and
still report respectable syntax to the user. This covers the vast majority
of cases; see calls to GHC.HsToCore.Monad.dsNoLevPoly and friends.

Levity polymorphism is also prohibited in the types of binders, and the
desugarer checks for this in GHC-generated Ids. (The zonker handles
the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.
The newSysLocalDs variant is used in the vast majority of cases where
the binder is obviously not levity polymorphic, omitting the check.
It would be nice to ASSERT that there is no levity polymorphism here,
but we can't, because of the fixM in GHC.HsToCore.Arrows. It's all OK, though:
Core Lint will catch an error here.

However, the desugarer is the wrong place for certain checks. In particular,
the desugarer can't report a sensible error message if an HsWrapper is malformed.
After all, GHC itself produced the HsWrapper. So we store some message text
in the appropriate HsWrappers (e.g. WpFun) that we can print out in the
desugarer.

There are a few more checks in places where Core is generated outside the
desugarer. For example, in datatype and class declarations, where levity
polymorphism is checked for during validity checking. It would be nice to
have one central place for all this, but that doesn't seem possible while
still reporting nice error messages.

-}

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

duplicateLocalDs :: Id -> DsM Id
duplicateLocalDs :: Id -> DsM Id
duplicateLocalDs Id
old_local
  = do  { Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Unique -> Id
setIdUnique Id
old_local Unique
uniq) }

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

newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id
newSysLocalDsNoLP :: Type -> Type -> DsM Id
newSysLocalDsNoLP  = FastString -> Type -> Type -> DsM Id
mk_local (String -> FastString
fsLit String
"ds")

-- this variant should be used when the caller can be sure that the variable type
-- is not levity-polymorphic. It is necessary when the type is knot-tied because
-- of the fixM used in GHC.HsToCore.Arrows. See Note [Levity polymorphism checking]
newSysLocalDs :: Type -> Type -> DsM Id
newSysLocalDs = forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalM (String -> FastString
fsLit String
"ds")
newFailLocalDs :: Type -> Type -> DsM Id
newFailLocalDs = forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalM (String -> FastString
fsLit String
"fail")
  -- the fail variable is used only in a situation where we can tell that
  -- levity-polymorphism is impossible.

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

mk_local :: FastString -> Mult -> Type -> DsM Id
mk_local :: FastString -> Type -> Type -> DsM Id
mk_local FastString
fs Type
w Type
ty = do { Type -> SDoc -> DsM ()
dsNoLevPoly Type
ty (String -> SDoc
text String
"When trying to create a variable of type:" SDoc -> SDoc -> SDoc
<+>
                                        forall a. Outputable a => a -> SDoc
ppr Type
ty)  -- could improve the msg with another
                                                 -- parameter indicating context
                      ; forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalOrCoVarM FastString
fs Type
w Type
ty }

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

getGhcModeDs :: DsM GhcMode
getGhcModeDs :: DsM GhcMode
getGhcModeDs =  forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return 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 { DsLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (DsLclEnv -> Nablas
dsl_nablas DsLclEnv
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 = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\DsLclEnv
env -> DsLclEnv
env { dsl_nablas :: Nablas
dsl_nablas = Nablas
nablas })

getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { DsLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
                  ; forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (DsLclEnv -> RealSrcSpan
dsl_loc DsLclEnv
env) forall a. Maybe a
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
  = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ DsLclEnv
env -> DsLclEnv
env {dsl_loc :: RealSrcSpan
dsl_loc = RealSrcSpan
real_span}) DsM a
thing_inside

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

-- | Emit a warning for the current source location
-- NB: Warns whether or not -Wxyz is set
warnDs :: WarnReason -> SDoc -> DsM ()
warnDs :: WarnReason -> SDoc -> DsM ()
warnDs WarnReason
reason SDoc
warn
  = do { DsGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; SrcSpan
loc <- DsM SrcSpan
getSrcSpanDs
       ; let msg :: MsgEnvelope DecoratedSDoc
msg = forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning WarnReason
reason forall a b. (a -> b) -> a -> b
$
                   SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkWarnMsg SrcSpan
loc (DsGblEnv -> PrintUnqualified
ds_unqual DsGblEnv
env) SDoc
warn
       ; forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> TcRef (Messages DecoratedSDoc)
ds_msgs DsGblEnv
env) (\ Messages DecoratedSDoc
msgs -> MsgEnvelope DecoratedSDoc
msg forall e. MsgEnvelope e -> Messages e -> Messages e
`addMessage` Messages DecoratedSDoc
msgs) }

-- | Emit a warning only if the correct WarnReason is set in the DynFlags
warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
warnIfSetDs WarningFlag
flag SDoc
warn
  = forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
flag forall a b. (a -> b) -> a -> b
$
    WarnReason -> SDoc -> DsM ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
flag) SDoc
warn

errDs :: SDoc -> DsM ()
errDs :: SDoc -> DsM ()
errDs SDoc
err
  = do  { DsGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; SrcSpan
loc <- DsM SrcSpan
getSrcSpanDs
        ; let msg :: MsgEnvelope DecoratedSDoc
msg = SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkMsgEnvelope SrcSpan
loc (DsGblEnv -> PrintUnqualified
ds_unqual DsGblEnv
env) SDoc
err
        ; forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> TcRef (Messages DecoratedSDoc)
ds_msgs DsGblEnv
env) (\ Messages DecoratedSDoc
msgs -> MsgEnvelope DecoratedSDoc
msg forall e. MsgEnvelope e -> Messages e -> Messages e
`addMessage` Messages DecoratedSDoc
msgs) }

-- | Issue an error, but return the expression for (), so that we can continue
-- reporting errors.
errDsCoreExpr :: SDoc -> DsM CoreExpr
errDsCoreExpr :: SDoc -> DsM CoreExpr
errDsCoreExpr SDoc
err
  = do { SDoc -> DsM ()
errDs SDoc
err
       ; forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
unitExpr }

failWithDs :: SDoc -> DsM a
failWithDs :: forall a. SDoc -> DsM a
failWithDs SDoc
err
  = do  { SDoc -> DsM ()
errDs SDoc
err
        ; forall env a. IOEnv env a
failM }

failDs :: DsM a
failDs :: forall a. DsM a
failDs = forall env a. IOEnv env a
failM

-- (askNoErrsDs m) runs m
-- If m fails,
--    then (askNoErrsDs m) fails
-- If m succeeds with result r,
--    then (askNoErrsDs 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
--
-- c.f. GHC.Tc.Utils.Monad.askNoErrs
askNoErrsDs :: DsM a -> DsM (a, Bool)
askNoErrsDs :: forall a. DsM a -> DsM (a, Bool)
askNoErrsDs DsM a
thing_inside
 = do { TcRef (Messages DecoratedSDoc)
errs_var <- forall a env. a -> IOEnv env (IORef a)
newMutVar forall e. Messages e
emptyMessages
      ; DsGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
      ; Either IOEnvFailure a
mb_res <- forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM forall a b. (a -> b) -> a -> b
$  -- Be careful to catch exceptions
                          -- so that we propagate errors correctly
                          -- (#13642)
                  forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv (DsGblEnv
env { ds_msgs :: TcRef (Messages DecoratedSDoc)
ds_msgs = TcRef (Messages DecoratedSDoc)
errs_var }) forall a b. (a -> b) -> a -> b
$
                  DsM a
thing_inside

      -- Propagate errors
      ; Messages DecoratedSDoc
msgs <- forall a env. IORef a -> IOEnv env a
readMutVar TcRef (Messages DecoratedSDoc)
errs_var
      ; forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> TcRef (Messages DecoratedSDoc)
ds_msgs DsGblEnv
env) (forall e. Messages e -> Messages e -> Messages e
unionMessages Messages DecoratedSDoc
msgs)

      -- And return
      ; case Either IOEnvFailure a
mb_res of
           Left IOEnvFailure
_    -> forall env a. IOEnv env a
failM
           Right a
res -> do { let errs_found :: Bool
errs_found = forall e. Messages e -> Bool
errorsFound Messages DecoratedSDoc
msgs
                           ; forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, Bool -> Bool
not Bool
errs_found) } }

mkPrintUnqualifiedDs :: DsM PrintUnqualified
mkPrintUnqualifiedDs :: DsM PrintUnqualified
mkPrintUnqualifiedDs = DsGblEnv -> PrintUnqualified
ds_unqual forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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  { DsGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (DsGblEnv -> (IfGblEnv, IfLclEnv)
ds_if_env DsGblEnv
env)
                  (Name -> IfL TyThing
tcIfaceGlobal Name
name) }

dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId Name
name
  = HasDebugCallStack => TyThing -> Id
tyThingId 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
tyThingTyCon 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
tyThingDataCon 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
tyThingConLike 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 { ExternalPackageState
eps <- forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps; DsGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (ExternalPackageState -> FamInstEnv
eps_fam_inst_env ExternalPackageState
eps, DsGblEnv -> FamInstEnv
ds_fam_inst_env DsGblEnv
env) }

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

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

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

dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv :: forall a. DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv DsMetaEnv
menv DsM a
thing_inside
  = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\DsLclEnv
env -> DsLclEnv
env { dsl_meta :: DsMetaEnv
dsl_meta = DsLclEnv -> DsMetaEnv
dsl_meta DsLclEnv
env forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` DsMetaEnv
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  { DsGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; Messages DecoratedSDoc
old_msgs <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef (DsGblEnv -> TcRef (Messages DecoratedSDoc)
ds_msgs DsGblEnv
env)

        ; a
result <- DsM a
thing_inside

        -- Revert messages to old_msgs
        ; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (DsGblEnv -> TcRef (Messages DecoratedSDoc)
ds_msgs DsGblEnv
env) Messages DecoratedSDoc
old_msgs

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

-- | Fail with an error message if the type is levity polymorphic.
dsNoLevPoly :: Type -> SDoc -> DsM ()
-- See Note [Levity polymorphism checking]
dsNoLevPoly :: Type -> SDoc -> DsM ()
dsNoLevPoly Type
ty SDoc
doc = forall (m :: * -> *).
Monad m =>
(SDoc -> m ()) -> SDoc -> Type -> m ()
checkForLevPolyX forall a. SDoc -> DsM a
failWithDs SDoc
doc Type
ty

-- | Check an expression for levity polymorphism, failing if it is
-- levity polymorphic.
dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
-- See Note [Levity polymorphism checking]
dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
dsNoLevPolyExpr CoreExpr
e SDoc
doc
  | CoreExpr -> Bool
isExprLevPoly CoreExpr
e = SDoc -> DsM ()
errDs (Type -> SDoc
formatLevPolyErr (CoreExpr -> Type
exprType CoreExpr
e) SDoc -> SDoc -> SDoc
$$ SDoc
doc)
  | Bool
otherwise       = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Runs the thing_inside. If there are no errors, then returns the expr
-- given. Otherwise, returns unitExpr. This is useful for doing a bunch
-- of levity polymorphism checks and then avoiding making a core App.
-- (If we make a core App on a levity polymorphic argument, detecting how
-- to handle the let/app invariant might call isUnliftedType, which panics
-- on a levity polymorphic type.)
-- See #12709 for an example of why this machinery is necessary.
dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs :: forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs DsM a
thing_inside a -> CoreExpr
mk_expr
  = do { (a
result, Bool
no_errs) <- forall a. DsM a -> DsM (a, Bool)
askNoErrsDs DsM a
thing_inside
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
no_errs
                  then a -> CoreExpr
mk_expr a
result
                  else CoreExpr
unitExpr }

-- | 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
  Id
traceId <- Name -> DsM Id
dsLookupGlobalId Name
traceName
  Id
unpackCStringId <- Name -> DsM Id
dsLookupGlobalId Name
unpackCStringName
  DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let message :: CoreExpr
      message :: CoreExpr
message = forall b. Expr b -> Expr b -> Expr b
App (forall b. Id -> Expr b
Var Id
unpackCStringId) forall a b. (a -> b) -> a -> b
$
                forall b. Literal -> Expr b
Lit forall a b. (a -> b) -> a -> b
$ String -> Literal
mkLitString forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
str) Int
4 SDoc
doc)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
traceId) [forall b. Type -> Expr b
Type (CoreExpr -> Type
exprType CoreExpr
expr), CoreExpr
message, CoreExpr
expr]

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