{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
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,
getPmNablas, updPmNablas,
addUnspecables, getUnspecables, zapUnspecables,
dsGetCompleteMatches,
DsWarning, diagnosticDs, errDsCoreExpr,
failWithDs, failDs, discardWarningsDs,
DsMatchContext(..),
EquationInfo(..), EquationInfoNE, prependPats, mkEqnInfo, eqnMatchResult,
MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
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 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
, EquationInfo -> EquationInfo
eqn_rest :: EquationInfo }
| EqnDone
(MatchResult CoreExpr)
type EquationInfoNE = EquationInfo
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
data MatchResult a
= 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)
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
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
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)
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 $
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)
}
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
}
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)
next_wrapper_num_var = TcGblEnv -> TcRef (ModuleEnv Int)
tcg_next_wrapper_num TcGblEnv
tcg_env
; ds_complete_matches <-
liftIO $ unsafeInterleaveIO $
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
}
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)
}
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
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
; 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"
, 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)
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
newSysLocalMDs, newFailLocalMDs :: Type -> DsM Id
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
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
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) }
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)
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) }
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
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
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
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
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
; writeTcRef (ds_msgs env) old_msgs
; return result }
pprRuntimeTrace :: String
-> SDoc
-> CoreExpr
-> 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]
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