{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ViewPatterns #-}
module DsMonad (
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,
mkPrintUnqualifiedDs,
newUnique,
UniqSupply, newUniqueSupply,
getGhcModeDs, dsGetFamInstEnvs,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
dsLookupDataCon, dsLookupConLike,
DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
getPmDelta, updPmDelta,
dsGetCompleteMatches,
DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
failWithDs, failDs, discardWarningsDs,
askNoErrsDs,
DsMatchContext(..),
EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
CanItFail(..), orFail,
dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
pprRuntimeTrace
) where
import GhcPrelude
import TcRnMonad
import FamInstEnv
import CoreSyn
import MkCore ( unitExpr )
import CoreUtils ( exprType, isExprLevPoly )
import GHC.Hs
import TcIface
import TcMType ( checkForLevPolyX, formatLevPolyErr )
import PrelNames
import RdrName
import HscTypes
import Bag
import BasicTypes ( Origin )
import DataCon
import ConLike
import TyCon
import GHC.HsToCore.PmCheck.Types
import Id
import Module
import Outputable
import SrcLoc
import Type
import UniqSupply
import Name
import NameEnv
import DynFlags
import ErrUtils
import FastString
import UniqFM ( lookupWithDefaultUFM )
import Literal ( mkLitString )
import CostCentreState
import Data.IORef
data DsMatchContext
= DsMatchContext (HsMatchContext Name) SrcSpan
deriving ()
instance Outputable DsMatchContext where
ppr :: DsMatchContext -> SDoc
ppr (DsMatchContext HsMatchContext Name
hs_match SrcSpan
ss) = SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
ss SDoc -> SDoc -> SDoc
<+> HsMatchContext Name -> SDoc
forall id.
(Outputable (NameOrRdrName id), Outputable id) =>
HsMatchContext id -> SDoc
pprMatchContext HsMatchContext Name
hs_match
data EquationInfo
= EqnInfo { EquationInfo -> [Pat GhcTc]
eqn_pats :: [Pat GhcTc]
, EquationInfo -> Origin
eqn_orig :: Origin
, EquationInfo -> MatchResult
eqn_rhs :: MatchResult
}
instance Outputable EquationInfo where
ppr :: EquationInfo -> SDoc
ppr (EqnInfo [Pat GhcTc]
pats Origin
_ MatchResult
_) = [Pat GhcTc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Pat GhcTc]
pats
type DsWrapper = CoreExpr -> CoreExpr
idDsWrapper :: DsWrapper
idDsWrapper :: DsWrapper
idDsWrapper CoreExpr
e = CoreExpr
e
data MatchResult
= MatchResult
CanItFail
(CoreExpr -> DsM CoreExpr)
data CanItFail = CanFail | CantFail
orFail :: CanItFail -> CanItFail -> CanItFail
orFail :: CanItFail -> CanItFail -> CanItFail
orFail CanItFail
CantFail CanItFail
CantFail = CanItFail
CantFail
orFail CanItFail
_ CanItFail
_ = CanItFail
CanFail
fixDs :: (a -> DsM a) -> DsM a
fixDs :: (a -> DsM a) -> DsM a
fixDs = (a -> DsM a) -> DsM a
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM
type DsWarning = (SrcSpan, SDoc)
initDsTc :: DsM a -> TcM a
initDsTc :: DsM a -> TcM a
initDsTc DsM a
thing_inside
= do { TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; TcRef Messages
msg_var <- TcRn (TcRef Messages)
getErrsVar
; HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; (DsGblEnv, DsLclEnv)
envs <- HscEnv
-> TcRef Messages
-> TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (DsGblEnv, DsLclEnv)
forall (m :: * -> *).
MonadIO m =>
HscEnv -> TcRef Messages -> TcGblEnv -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env TcRef Messages
msg_var TcGblEnv
tcg_env
; (DsGblEnv, DsLclEnv) -> DsM a -> TcM a
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (DsGblEnv, DsLclEnv)
envs DsM a
thing_inside
}
initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
initDs HscEnv
hsc_env TcGblEnv
tcg_env DsM a
thing_inside
= do { TcRef Messages
msg_var <- Messages -> IO (TcRef Messages)
forall a. a -> IO (IORef a)
newIORef Messages
emptyMessages
; (DsGblEnv, DsLclEnv)
envs <- HscEnv -> TcRef Messages -> TcGblEnv -> IO (DsGblEnv, DsLclEnv)
forall (m :: * -> *).
MonadIO m =>
HscEnv -> TcRef Messages -> TcGblEnv -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env TcRef Messages
msg_var TcGblEnv
tcg_env
; HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
forall a.
HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
runDs HscEnv
hsc_env (DsGblEnv, DsLclEnv)
envs DsM a
thing_inside
}
mkDsEnvsFromTcGbl :: MonadIO m
=> HscEnv -> IORef Messages -> TcGblEnv
-> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl :: HscEnv -> TcRef Messages -> TcGblEnv -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env TcRef Messages
msg_var TcGblEnv
tcg_env
= do { IORef CostCentreState
cc_st_var <- IO (IORef CostCentreState) -> m (IORef CostCentreState)
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
; let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags 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
[CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [CompleteMatch]
tcg_complete_matches TcGblEnv
tcg_env
; (DsGblEnv, DsLclEnv) -> m (DsGblEnv, DsLclEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return ((DsGblEnv, DsLclEnv) -> m (DsGblEnv, DsLclEnv))
-> (DsGblEnv, DsLclEnv) -> m (DsGblEnv, DsLclEnv)
forall a b. (a -> b) -> a -> b
$ DynFlags
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> TcRef Messages
-> IORef CostCentreState
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs DynFlags
dflags Module
this_mod GlobalRdrEnv
rdr_env TypeEnv
type_env FamInstEnv
fam_inst_env
TcRef Messages
msg_var IORef CostCentreState
cc_st_var [CompleteMatch]
complete_matches
}
runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
runDs HscEnv
hsc_env (DsGblEnv
ds_gbl, DsLclEnv
ds_lcl) DsM a
thing_inside
= do { Either IOEnvFailure a
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)
; Messages
msgs <- TcRef Messages -> IO Messages
forall a. IORef a -> IO a
readIORef (DsGblEnv -> TcRef Messages
ds_msgs DsGblEnv
ds_gbl)
; let final_res :: Maybe a
final_res
| DynFlags -> Messages -> Bool
errorsFound DynFlags
dflags Messages
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. String -> a
panic String
"initDs"
; (Messages, Maybe a) -> IO (Messages, Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages
msgs, Maybe a
final_res)
}
where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
initDsWithModGuts HscEnv
hsc_env ModGuts
guts DsM a
thing_inside
= do { IORef CostCentreState
cc_st_var <- CostCentreState -> IO (IORef CostCentreState)
forall a. a -> IO (IORef a)
newIORef CostCentreState
newCostCentreState
; TcRef Messages
msg_var <- Messages -> IO (TcRef Messages)
forall a. a -> IO (IORef a)
newIORef Messages
emptyMessages
; let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
type_env :: TypeEnv
type_env = [Id] -> [TyCon] -> [FamInst] -> TypeEnv
typeEnvFromEntities [Id]
ids (ModGuts -> [TyCon]
mg_tcs ModGuts
guts) (ModGuts -> [FamInst]
mg_fam_insts ModGuts
guts)
rdr_env :: GlobalRdrEnv
rdr_env = ModGuts -> GlobalRdrEnv
mg_rdr_env ModGuts
guts
fam_inst_env :: FamInstEnv
fam_inst_env = ModGuts -> FamInstEnv
mg_fam_inst_env ModGuts
guts
this_mod :: Module
this_mod = ModGuts -> Module
mg_module ModGuts
guts
complete_matches :: [CompleteMatch]
complete_matches = HscEnv -> [CompleteMatch]
hptCompleteSigs HscEnv
hsc_env
[CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ ModGuts -> [CompleteMatch]
mg_complete_sigs ModGuts
guts
bindsToIds :: Bind b -> [b]
bindsToIds (NonRec b
v Expr b
_) = [b
v]
bindsToIds (Rec [(b, Expr b)]
binds) = ((b, Expr b) -> b) -> [(b, Expr b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, Expr b) -> b
forall a b. (a, b) -> a
fst [(b, Expr b)]
binds
ids :: [Id]
ids = (Bind Id -> [Id]) -> [Bind Id] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind Id -> [Id]
forall b. Bind b -> [b]
bindsToIds (ModGuts -> [Bind Id]
mg_binds ModGuts
guts)
envs :: (DsGblEnv, DsLclEnv)
envs = DynFlags
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> TcRef Messages
-> IORef CostCentreState
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs DynFlags
dflags Module
this_mod GlobalRdrEnv
rdr_env TypeEnv
type_env
FamInstEnv
fam_inst_env TcRef Messages
msg_var IORef CostCentreState
cc_st_var
[CompleteMatch]
complete_matches
; HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
forall a.
HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
runDs HscEnv
hsc_env (DsGblEnv, DsLclEnv)
envs DsM a
thing_inside
}
initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
initTcDsForSolver TcM a
thing_inside
= do { (DsGblEnv
gbl, DsLclEnv
lcl) <- TcRnIf DsGblEnv DsLclEnv (DsGblEnv, DsLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs
; HscEnv
hsc_env <- TcRnIf DsGblEnv DsLclEnv HscEnv
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 } = DsGblEnv
gbl
DsLclEnv { dsl_loc :: DsLclEnv -> RealSrcSpan
dsl_loc = RealSrcSpan
loc } = DsLclEnv
lcl
; IO (Messages, Maybe a) -> DsM (Messages, Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages, Maybe a) -> DsM (Messages, Maybe a))
-> IO (Messages, Maybe a) -> DsM (Messages, Maybe a)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM a
-> IO (Messages, Maybe a)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages, Maybe r)
initTc HscEnv
hsc_env HscSource
HsSrcFile Bool
False Module
mod RealSrcSpan
loc (TcM a -> IO (Messages, Maybe a))
-> TcM a -> IO (Messages, Maybe a)
forall a b. (a -> b) -> a -> b
$
(TcGblEnv -> TcGblEnv) -> TcM a -> TcM a
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 }) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside }
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> IORef Messages -> IORef CostCentreState -> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs :: DynFlags
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> TcRef Messages
-> IORef CostCentreState
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs DynFlags
dflags Module
mod GlobalRdrEnv
rdr_env TypeEnv
type_env FamInstEnv
fam_inst_env TcRef Messages
msg_var IORef CostCentreState
cc_st_var
[CompleteMatch]
complete_matches
= let if_genv :: IfGblEnv
if_genv = IfGblEnv :: SDoc -> Maybe (Module, IfG TypeEnv) -> IfGblEnv
IfGblEnv { if_doc :: SDoc
if_doc = String -> SDoc
text String
"mkDsEnvs",
if_rec_types :: Maybe (Module, IfG TypeEnv)
if_rec_types = (Module, IfG TypeEnv) -> Maybe (Module, IfG TypeEnv)
forall a. a -> Maybe a
Just (Module
mod, TypeEnv -> IfG TypeEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TypeEnv
type_env) }
if_lenv :: IfLclEnv
if_lenv = Module -> SDoc -> Bool -> IfLclEnv
mkIfLclEnv Module
mod (String -> SDoc
text String
"GHC error in desugarer lookup in" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
Bool
False
real_span :: RealSrcSpan
real_span = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (ModuleName -> FastString
moduleNameFS (Module -> ModuleName
moduleName Module
mod)) Int
1 Int
1)
completeMatchMap :: CompleteMatchMap
completeMatchMap = [CompleteMatch] -> CompleteMatchMap
mkCompleteMatchMap [CompleteMatch]
complete_matches
gbl_env :: DsGblEnv
gbl_env = DsGblEnv :: Module
-> FamInstEnv
-> PrintUnqualified
-> TcRef Messages
-> (IfGblEnv, IfLclEnv)
-> CompleteMatchMap
-> IORef CostCentreState
-> DsGblEnv
DsGblEnv { ds_mod :: Module
ds_mod = Module
mod
, ds_fam_inst_env :: FamInstEnv
ds_fam_inst_env = FamInstEnv
fam_inst_env
, ds_if_env :: (IfGblEnv, IfLclEnv)
ds_if_env = (IfGblEnv
if_genv, IfLclEnv
if_lenv)
, ds_unqual :: PrintUnqualified
ds_unqual = DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified DynFlags
dflags GlobalRdrEnv
rdr_env
, ds_msgs :: TcRef Messages
ds_msgs = TcRef Messages
msg_var
, ds_complete_matches :: CompleteMatchMap
ds_complete_matches = CompleteMatchMap
completeMatchMap
, ds_cc_st :: IORef CostCentreState
ds_cc_st = IORef CostCentreState
cc_st_var
}
lcl_env :: DsLclEnv
lcl_env = DsLclEnv :: DsMetaEnv -> RealSrcSpan -> Delta -> DsLclEnv
DsLclEnv { dsl_meta :: DsMetaEnv
dsl_meta = DsMetaEnv
forall a. NameEnv a
emptyNameEnv
, dsl_loc :: RealSrcSpan
dsl_loc = RealSrcSpan
real_span
, dsl_delta :: Delta
dsl_delta = Delta
initDelta
}
in (DsGblEnv
gbl_env, DsLclEnv
lcl_env)
newUniqueId :: Id -> Type -> DsM Id
newUniqueId :: Id -> Type -> DsM Id
newUniqueId Id
id = FastString -> 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 <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; Id -> DsM Id
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 Type
pred
= Type -> DsM Id
newSysLocalDs Type
pred
newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
newSysLocalDsNoLP :: Type -> DsM Id
newSysLocalDsNoLP = FastString -> Type -> DsM Id
mk_local (String -> FastString
fsLit String
"ds")
newSysLocalDs :: Type -> DsM Id
newSysLocalDs = FastString -> Type -> DsM Id
forall (m :: * -> *). MonadUnique m => FastString -> Type -> m Id
mkSysLocalOrCoVarM (String -> FastString
fsLit String
"ds")
newFailLocalDs :: Type -> DsM Id
newFailLocalDs = FastString -> Type -> DsM Id
forall (m :: * -> *). MonadUnique m => FastString -> Type -> m Id
mkSysLocalOrCoVarM (String -> FastString
fsLit String
"fail")
newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]
newSysLocalsDsNoLP :: [Type] -> DsM [Id]
newSysLocalsDsNoLP = (Type -> DsM Id) -> [Type] -> DsM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM Id
newSysLocalDsNoLP
newSysLocalsDs :: [Type] -> DsM [Id]
newSysLocalsDs = (Type -> DsM Id) -> [Type] -> DsM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM Id
newSysLocalDs
mk_local :: FastString -> Type -> DsM Id
mk_local :: FastString -> Type -> DsM Id
mk_local FastString
fs Type
ty = do { Type -> SDoc -> DsM ()
dsNoLevPoly Type
ty (String -> SDoc
text String
"When trying to create a variable of type:" SDoc -> SDoc -> SDoc
<+>
Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
; FastString -> Type -> DsM Id
forall (m :: * -> *). MonadUnique m => FastString -> Type -> m Id
mkSysLocalOrCoVarM FastString
fs Type
ty }
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GhcMode -> DsM GhcMode
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
getPmDelta :: DsM Delta
getPmDelta :: DsM Delta
getPmDelta = do { DsLclEnv
env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; Delta -> DsM Delta
forall (m :: * -> *) a. Monad m => a -> m a
return (DsLclEnv -> Delta
dsl_delta DsLclEnv
env) }
updPmDelta :: Delta -> DsM a -> DsM a
updPmDelta :: Delta -> DsM a -> DsM a
updPmDelta Delta
delta = (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_delta :: Delta
dsl_delta = Delta
delta })
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { DsLclEnv
env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; SrcSpan -> DsM SrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> SrcSpan
RealSrcSpan (DsLclEnv -> RealSrcSpan
dsl_loc DsLclEnv
env)) }
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs (UnhelpfulSpan {}) DsM a
thing_inside
= DsM a
thing_inside
putSrcSpanDs (RealSrcSpan RealSrcSpan
real_span) 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 :: RealSrcSpan
dsl_loc = RealSrcSpan
real_span}) DsM a
thing_inside
warnDs :: WarnReason -> SDoc -> DsM ()
warnDs :: WarnReason -> SDoc -> DsM ()
warnDs WarnReason
reason SDoc
warn
= do { DsGblEnv
env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; SrcSpan
loc <- DsM SrcSpan
getSrcSpanDs
; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let msg :: ErrMsg
msg = WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning WarnReason
reason (ErrMsg -> ErrMsg) -> ErrMsg -> ErrMsg
forall a b. (a -> b) -> a -> b
$
DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkWarnMsg DynFlags
dflags SrcSpan
loc (DsGblEnv -> PrintUnqualified
ds_unqual DsGblEnv
env) SDoc
warn
; TcRef Messages -> (Messages -> Messages) -> DsM ()
forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> TcRef Messages
ds_msgs DsGblEnv
env) (\ (WarningMessages
w,WarningMessages
e) -> (WarningMessages
w WarningMessages -> ErrMsg -> WarningMessages
forall a. Bag a -> a -> Bag a
`snocBag` ErrMsg
msg, WarningMessages
e)) }
warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
warnIfSetDs WarningFlag
flag SDoc
warn
= WarningFlag -> DsM () -> DsM ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
flag (DsM () -> DsM ()) -> DsM () -> DsM ()
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 <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; SrcSpan
loc <- DsM SrcSpan
getSrcSpanDs
; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let msg :: ErrMsg
msg = DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkErrMsg DynFlags
dflags SrcSpan
loc (DsGblEnv -> PrintUnqualified
ds_unqual DsGblEnv
env) SDoc
err
; TcRef Messages -> (Messages -> Messages) -> DsM ()
forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> TcRef Messages
ds_msgs DsGblEnv
env) (\ (WarningMessages
w,WarningMessages
e) -> (WarningMessages
w, WarningMessages
e WarningMessages -> ErrMsg -> WarningMessages
forall a. Bag a -> a -> Bag a
`snocBag` ErrMsg
msg)) }
errDsCoreExpr :: SDoc -> DsM CoreExpr
errDsCoreExpr :: SDoc -> DsM CoreExpr
errDsCoreExpr SDoc
err
= do { SDoc -> DsM ()
errDs SDoc
err
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
unitExpr }
failWithDs :: SDoc -> DsM a
failWithDs :: SDoc -> DsM a
failWithDs SDoc
err
= do { SDoc -> DsM ()
errDs SDoc
err
; DsM a
forall env a. IOEnv env a
failM }
failDs :: DsM a
failDs :: DsM a
failDs = DsM a
forall env a. IOEnv env a
failM
askNoErrsDs :: DsM a -> DsM (a, Bool)
askNoErrsDs :: DsM a -> DsM (a, Bool)
askNoErrsDs DsM a
thing_inside
= do { TcRef Messages
errs_var <- Messages -> IOEnv (Env DsGblEnv DsLclEnv) (TcRef Messages)
forall a env. a -> IOEnv env (IORef a)
newMutVar Messages
emptyMessages
; DsGblEnv
env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; Either IOEnvFailure a
mb_res <- DsM a -> IOEnv (Env DsGblEnv DsLclEnv) (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM (DsM a -> IOEnv (Env DsGblEnv DsLclEnv) (Either IOEnvFailure a))
-> DsM a -> IOEnv (Env DsGblEnv DsLclEnv) (Either IOEnvFailure a)
forall a b. (a -> b) -> a -> b
$
DsGblEnv -> DsM a -> DsM a
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv (DsGblEnv
env { ds_msgs :: TcRef Messages
ds_msgs = TcRef Messages
errs_var }) (DsM a -> DsM a) -> DsM a -> DsM a
forall a b. (a -> b) -> a -> b
$
DsM a
thing_inside
; msgs :: Messages
msgs@(WarningMessages
warns, WarningMessages
errs) <- TcRef Messages -> IOEnv (Env DsGblEnv DsLclEnv) Messages
forall a env. IORef a -> IOEnv env a
readMutVar TcRef Messages
errs_var
; TcRef Messages -> (Messages -> Messages) -> DsM ()
forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> TcRef Messages
ds_msgs DsGblEnv
env) (\ (WarningMessages
w,WarningMessages
e) -> (WarningMessages
w WarningMessages -> WarningMessages -> WarningMessages
forall a. Bag a -> Bag a -> Bag a
`unionBags` WarningMessages
warns, WarningMessages
e WarningMessages -> WarningMessages -> WarningMessages
forall a. Bag a -> Bag a -> Bag a
`unionBags` WarningMessages
errs))
; case Either IOEnvFailure a
mb_res of
Left IOEnvFailure
_ -> DsM (a, Bool)
forall env a. IOEnv env a
failM
Right a
res -> do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let errs_found :: Bool
errs_found = DynFlags -> Messages -> Bool
errorsFound DynFlags
dflags Messages
msgs
; (a, Bool) -> DsM (a, Bool)
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 (DsGblEnv -> PrintUnqualified)
-> TcRnIf DsGblEnv DsLclEnv DsGblEnv -> DsM PrintUnqualified
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 { DsGblEnv
env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; (IfGblEnv, IfLclEnv)
-> TcRnIf IfGblEnv IfLclEnv TyThing
-> IOEnv (Env DsGblEnv DsLclEnv) TyThing
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 -> TcRnIf IfGblEnv IfLclEnv TyThing
tcIfaceGlobal Name
name) }
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId Name
name
= TyThing -> Id
tyThingId (TyThing -> Id) -> IOEnv (Env DsGblEnv DsLclEnv) TyThing -> DsM Id
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
= 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
= 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
= 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 { ExternalPackageState
eps <- TcRnIf DsGblEnv DsLclEnv ExternalPackageState
forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps; DsGblEnv
env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; FamInstEnvs -> DsM FamInstEnvs
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 <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; DsMetaEnv -> DsM DsMetaEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (DsLclEnv -> DsMetaEnv
dsl_meta DsLclEnv
env) }
dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
dsGetCompleteMatches TyCon
tc = do
ExternalPackageState
eps <- TcRnIf DsGblEnv DsLclEnv ExternalPackageState
forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps
DsGblEnv
env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let lookup_completes :: UniqFM [a] -> [a]
lookup_completes UniqFM [a]
ufm = UniqFM [a] -> [a] -> TyCon -> [a]
forall key elt. Uniquable key => UniqFM elt -> elt -> key -> elt
lookupWithDefaultUFM UniqFM [a]
ufm [] TyCon
tc
eps_matches_list :: [CompleteMatch]
eps_matches_list = CompleteMatchMap -> [CompleteMatch]
forall a. UniqFM [a] -> [a]
lookup_completes (CompleteMatchMap -> [CompleteMatch])
-> CompleteMatchMap -> [CompleteMatch]
forall a b. (a -> b) -> a -> b
$ ExternalPackageState -> CompleteMatchMap
eps_complete_matches ExternalPackageState
eps
env_matches_list :: [CompleteMatch]
env_matches_list = CompleteMatchMap -> [CompleteMatch]
forall a. UniqFM [a] -> [a]
lookup_completes (CompleteMatchMap -> [CompleteMatch])
-> CompleteMatchMap -> [CompleteMatch]
forall a b. (a -> b) -> a -> b
$ DsGblEnv -> CompleteMatchMap
ds_complete_matches DsGblEnv
env
[CompleteMatch] -> DsM [CompleteMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CompleteMatch] -> DsM [CompleteMatch])
-> [CompleteMatch] -> DsM [CompleteMatch]
forall a b. (a -> b) -> a -> b
$ [CompleteMatch]
eps_matches_list [CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ [CompleteMatch]
env_matches_list
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv Name
name = do { DsLclEnv
env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; Maybe DsMetaVal -> DsM (Maybe DsMetaVal)
forall (m :: * -> *) a. Monad m => a -> m a
return (DsMetaEnv -> Name -> Maybe DsMetaVal
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (DsLclEnv -> DsMetaEnv
dsl_meta DsLclEnv
env) Name
name) }
dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv :: 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 :: DsMetaEnv
dsl_meta = DsLclEnv -> DsMetaEnv
dsl_meta DsLclEnv
env DsMetaEnv -> DsMetaEnv -> DsMetaEnv
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` DsMetaEnv
menv }) DsM a
thing_inside
discardWarningsDs :: DsM a -> DsM a
discardWarningsDs :: DsM a -> DsM a
discardWarningsDs DsM a
thing_inside
= do { DsGblEnv
env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; Messages
old_msgs <- TcRef Messages -> IOEnv (Env DsGblEnv DsLclEnv) Messages
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef (DsGblEnv -> TcRef Messages
ds_msgs DsGblEnv
env)
; a
result <- DsM a
thing_inside
; TcRef Messages -> Messages -> DsM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (DsGblEnv -> TcRef Messages
ds_msgs DsGblEnv
env) Messages
old_msgs
; a -> DsM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result }
dsNoLevPoly :: Type -> SDoc -> DsM ()
dsNoLevPoly :: Type -> SDoc -> DsM ()
dsNoLevPoly Type
ty SDoc
doc = (SDoc -> DsM ()) -> SDoc -> Type -> DsM ()
forall (m :: * -> *).
Monad m =>
(SDoc -> m ()) -> SDoc -> Type -> m ()
checkForLevPolyX SDoc -> DsM ()
errDs SDoc
doc Type
ty
dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
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 = () -> DsM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs DsM a
thing_inside a -> CoreExpr
mk_expr
= do { (a
result, Bool
no_errs) <- DsM a -> DsM (a, Bool)
forall a. DsM a -> DsM (a, Bool)
askNoErrsDs DsM a
thing_inside
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ if Bool
no_errs
then a -> CoreExpr
mk_expr a
result
else CoreExpr
unitExpr }
pprRuntimeTrace :: String
-> SDoc
-> CoreExpr
-> 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 <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let message :: CoreExpr
message :: CoreExpr
message = CoreExpr -> DsWrapper
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
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
text String
str) Int
4 SDoc
doc)
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
traceId) [Type -> CoreExpr
forall b. Type -> Expr b
Type (CoreExpr -> Type
exprType CoreExpr
expr), CoreExpr
message, CoreExpr
expr]