{-# 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, newUniqueId,
newFailLocalDs, newPredVarDs,
getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
mkPrintUnqualifiedDs,
newUnique,
UniqSupply, newUniqueSupply,
getGhcModeDs, dsGetFamInstEnvs,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
dsLookupDataCon, dsLookupConLike,
getCCIndexDsM,
DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
getPmNablas, updPmNablas,
dsGetCompleteMatches,
DsWarning, diagnosticDs, errDsCoreExpr,
failWithDs, failDs, discardWarningsDs,
DsMatchContext(..),
EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
pprRuntimeTrace
) where
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.Session
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.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.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
import qualified GHC.Data.Strict as Strict
import Data.IORef
import GHC.Driver.Env.KnotVars
data DsMatchContext
= DsMatchContext (HsMatchContext GhcRn) SrcSpan
deriving ()
instance Outputable DsMatchContext where
ppr :: DsMatchContext -> SDoc
ppr (DsMatchContext HsMatchContext GhcRn
hs_match SrcSpan
ss) = SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
ss SDoc -> SDoc -> SDoc
<+> HsMatchContext GhcRn -> SDoc
forall p.
(Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) =>
HsMatchContext p -> SDoc
pprMatchContext HsMatchContext GhcRn
hs_match
data EquationInfo
= EqnInfo { EquationInfo -> [Pat GhcTc]
eqn_pats :: [Pat GhcTc]
, EquationInfo -> Origin
eqn_orig :: Origin
, EquationInfo -> MatchResult CoreExpr
eqn_rhs :: MatchResult CoreExpr
}
instance Outputable EquationInfo where
ppr :: EquationInfo -> SDoc
ppr (EqnInfo [Pat GhcTc]
pats Origin
_ MatchResult CoreExpr
_) = [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 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 { TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; IORef (Messages DsMessage)
msg_var <- IO (IORef (Messages DsMessage))
-> IOEnv (Env TcGblEnv TcLclEnv) (IORef (Messages DsMessage))
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Messages DsMessage))
-> IOEnv (Env TcGblEnv TcLclEnv) (IORef (Messages DsMessage)))
-> IO (IORef (Messages DsMessage))
-> IOEnv (Env TcGblEnv TcLclEnv) (IORef (Messages DsMessage))
forall a b. (a -> b) -> a -> b
$ Messages DsMessage -> IO (IORef (Messages DsMessage))
forall a. a -> IO (IORef a)
newIORef Messages DsMessage
forall e. Messages e
emptyMessages
; HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; (DsGblEnv, DsLclEnv)
envs <- HscEnv
-> IORef (Messages DsMessage)
-> TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (DsGblEnv, DsLclEnv)
forall (m :: * -> *).
MonadIO m =>
HscEnv
-> IORef (Messages DsMessage) -> TcGblEnv -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env IORef (Messages DsMessage)
msg_var TcGblEnv
tcg_env
; Either IOEnvFailure a
e_result <- IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM (IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a))
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall a b. (a -> b) -> a -> b
$
(DsGblEnv, DsLclEnv) -> DsM a -> IOEnv (Env TcGblEnv TcLclEnv) 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
; Messages DsMessage
msgs <- IO (Messages DsMessage)
-> IOEnv (Env TcGblEnv TcLclEnv) (Messages DsMessage)
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages DsMessage)
-> IOEnv (Env TcGblEnv TcLclEnv) (Messages DsMessage))
-> IO (Messages DsMessage)
-> IOEnv (Env TcGblEnv TcLclEnv) (Messages DsMessage)
forall a b. (a -> b) -> a -> b
$ IORef (Messages DsMessage) -> IO (Messages DsMessage)
forall a. IORef a -> IO a
readIORef IORef (Messages DsMessage)
msg_var
; (Messages DsMessage, Maybe a) -> TcM (Messages DsMessage, Maybe a)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages DsMessage
msgs, case Either IOEnvFailure a
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 { IORef (Messages DsMessage)
msg_var <- Messages DsMessage -> IO (IORef (Messages DsMessage))
forall a. a -> IO (IORef a)
newIORef Messages DsMessage
forall e. Messages e
emptyMessages
; (DsGblEnv, DsLclEnv)
envs <- HscEnv
-> IORef (Messages DsMessage)
-> TcGblEnv
-> IO (DsGblEnv, DsLclEnv)
forall (m :: * -> *).
MonadIO m =>
HscEnv
-> IORef (Messages DsMessage) -> TcGblEnv -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env IORef (Messages DsMessage)
msg_var TcGblEnv
tcg_env
; HscEnv
-> (DsGblEnv, DsLclEnv)
-> DsM a
-> IO (Messages DsMessage, Maybe a)
forall a.
HscEnv
-> (DsGblEnv, DsLclEnv)
-> DsM a
-> IO (Messages DsMessage, Maybe a)
runDs HscEnv
hsc_env (DsGblEnv, DsLclEnv)
envs DsM a
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 { IORef CostCentreState
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
; ExternalPackageState
eps <- IO ExternalPackageState -> m ExternalPackageState
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> m ExternalPackageState)
-> IO ExternalPackageState -> m ExternalPackageState
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
[CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [CompleteMatch]
tcg_complete_matches TcGblEnv
tcg_env
[CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ ExternalPackageState -> [CompleteMatch]
eps_complete_matches ExternalPackageState
eps
next_wrapper_num_var :: TcRef (ModuleEnv Int)
next_wrapper_num_var = TcGblEnv -> TcRef (ModuleEnv Int)
tcg_next_wrapper_num TcGblEnv
tcg_env
; (DsGblEnv, DsLclEnv) -> m (DsGblEnv, DsLclEnv)
forall a. a -> m a
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
$ UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> IORef (Messages DsMessage)
-> IORef CostCentreState
-> TcRef (ModuleEnv Int)
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs UnitEnv
unit_env Module
this_mod GlobalRdrEnv
rdr_env TypeEnv
type_env FamInstEnv
fam_inst_env
IORef (Messages DsMessage)
msg_var IORef CostCentreState
cc_st_var TcRef (ModuleEnv Int)
next_wrapper_num_var [CompleteMatch]
complete_matches
}
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 { 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 DsMessage
msgs <- IORef (Messages DsMessage) -> IO (Messages DsMessage)
forall a. IORef a -> IO a
readIORef (DsGblEnv -> IORef (Messages DsMessage)
ds_msgs DsGblEnv
ds_gbl)
; let final_res :: Maybe a
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. String -> a
panic String
"initDs"
; (Messages DsMessage, Maybe a) -> IO (Messages DsMessage, Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages DsMessage
msgs, Maybe a
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 { IORef CostCentreState
cc_st_var <- CostCentreState -> IO (IORef CostCentreState)
forall a. a -> IO (IORef a)
newIORef CostCentreState
newCostCentreState
; TcRef (ModuleEnv Int)
next_wrapper_num <- ModuleEnv Int -> IO (TcRef (ModuleEnv Int))
forall a. a -> IO (IORef a)
newIORef ModuleEnv Int
forall a. ModuleEnv a
emptyModuleEnv
; IORef (Messages DsMessage)
msg_var <- Messages DsMessage -> IO (IORef (Messages DsMessage))
forall a. a -> IO (IORef a)
newIORef Messages DsMessage
forall e. Messages e
emptyMessages
; ExternalPackageState
eps <- IO ExternalPackageState -> IO ExternalPackageState
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> IO ExternalPackageState)
-> IO ExternalPackageState -> IO ExternalPackageState
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
[CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ [CompleteMatch]
local_complete_matches
[CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ ExternalPackageState -> [CompleteMatch]
eps_complete_matches ExternalPackageState
eps
bindsToIds :: Bind a -> [a]
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 :: [Id]
ids = (Bind Id -> [Id]) -> CoreProgram -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind Id -> [Id]
forall {a}. Bind a -> [a]
bindsToIds CoreProgram
binds
envs :: (DsGblEnv, DsLclEnv)
envs = UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> IORef (Messages DsMessage)
-> IORef CostCentreState
-> TcRef (ModuleEnv Int)
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs UnitEnv
unit_env Module
this_mod GlobalRdrEnv
rdr_env TypeEnv
type_env
FamInstEnv
fam_inst_env IORef (Messages DsMessage)
msg_var IORef CostCentreState
cc_st_var
TcRef (ModuleEnv Int)
next_wrapper_num [CompleteMatch]
complete_matches
; HscEnv
-> (DsGblEnv, DsLclEnv)
-> DsM a
-> IO (Messages DsMessage, Maybe a)
forall a.
HscEnv
-> (DsGblEnv, DsLclEnv)
-> DsM a
-> IO (Messages DsMessage, Maybe a)
runDs HscEnv
hsc_env (DsGblEnv, DsLclEnv)
envs DsM a
thing_inside
}
initTcDsForSolver :: TcM a -> DsM a
initTcDsForSolver :: forall a. TcM a -> DsM 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
, ds_gbl_rdr_env :: DsGblEnv -> GlobalRdrEnv
ds_gbl_rdr_env = GlobalRdrEnv
rdr_env } = DsGblEnv
gbl
DsLclEnv { dsl_loc :: DsLclEnv -> RealSrcSpan
dsl_loc = RealSrcSpan
loc } = DsLclEnv
lcl
; (Messages TcRnMessage
msgs, Maybe a
mb_ret) <- IO (Messages TcRnMessage, Maybe a)
-> IOEnv (Env DsGblEnv DsLclEnv) (Messages TcRnMessage, Maybe a)
forall a. IO a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages TcRnMessage, Maybe a)
-> IOEnv (Env DsGblEnv DsLclEnv) (Messages TcRnMessage, Maybe a))
-> IO (Messages TcRnMessage, Maybe a)
-> IOEnv (Env DsGblEnv DsLclEnv) (Messages TcRnMessage, Maybe a)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM a
-> IO (Messages TcRnMessage, Maybe a)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc HscEnv
hsc_env HscSource
HsSrcFile Bool
False Module
mod RealSrcSpan
loc (TcM a -> IO (Messages TcRnMessage, Maybe a))
-> TcM a -> IO (Messages TcRnMessage, 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
, tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env = GlobalRdrEnv
rdr_env }) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
; case Maybe a
mb_ret of
Just a
ret -> a -> DsM 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 -> DsM a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"initTcDsForSolver" ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope TcRnMessage) -> [SDoc]
forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc (Messages TcRnMessage -> Bag (MsgEnvelope TcRnMessage)
forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getErrorMessages Messages TcRnMessage
msgs)) }
mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
mkDsEnvs :: UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> IORef (Messages DsMessage)
-> IORef CostCentreState
-> TcRef (ModuleEnv Int)
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs UnitEnv
unit_env Module
mod GlobalRdrEnv
rdr_env TypeEnv
type_env FamInstEnv
fam_inst_env IORef (Messages DsMessage)
msg_var IORef CostCentreState
cc_st_var
TcRef (ModuleEnv Int)
next_wrapper_num [CompleteMatch]
complete_matches
= let if_genv :: IfGblEnv
if_genv = IfGblEnv { if_doc :: SDoc
if_doc = String -> SDoc
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
text String
"GHC error in desugarer lookup in" SDoc -> SDoc -> SDoc
<+> 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_unqual :: PrintUnqualified
ds_unqual = UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified UnitEnv
unit_env GlobalRdrEnv
rdr_env
, ds_msgs :: IORef (Messages DsMessage)
ds_msgs = IORef (Messages DsMessage)
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
, 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
}
in (DsGblEnv
gbl_env, DsLclEnv
lcl_env)
newUniqueId :: Id -> Mult -> Type -> DsM Id
newUniqueId :: Id -> Mult -> Mult -> DsM Id
newUniqueId Id
id = FastString -> Mult -> Mult -> DsM Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> Mult -> Mult -> m Id
mkSysLocalOrCoVarM (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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Unique -> Id
setIdUnique Id
old_local Unique
uniq) }
newPredVarDs :: PredType -> DsM Var
newPredVarDs :: Mult -> DsM Id
newPredVarDs
= FastString -> Mult -> Mult -> DsM Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> Mult -> Mult -> m Id
mkSysLocalOrCoVarM (String -> FastString
fsLit String
"ds") Mult
Many
newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id
newSysLocalDs :: Mult -> Mult -> DsM Id
newSysLocalDs = FastString -> Mult -> Mult -> DsM Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> Mult -> Mult -> m Id
mkSysLocalM (String -> FastString
fsLit String
"ds")
newFailLocalDs :: Mult -> Mult -> DsM Id
newFailLocalDs = FastString -> Mult -> Mult -> DsM Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> Mult -> Mult -> m Id
mkSysLocalM (String -> FastString
fsLit String
"fail")
newSysLocalsDs :: [Scaled Type] -> DsM [Id]
newSysLocalsDs :: [Scaled Mult] -> DsM [Id]
newSysLocalsDs = (Scaled Mult -> DsM Id) -> [Scaled Mult] -> DsM [Id]
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
w Mult
t) -> Mult -> Mult -> DsM Id
newSysLocalDs Mult
w Mult
t)
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 { DsLclEnv
env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; Nablas -> DsM Nablas
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsLclEnv -> Nablas
dsl_nablas DsLclEnv
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
dsl_nablas = Nablas
nablas })
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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (DsLclEnv -> RealSrcSpan
dsl_loc DsLclEnv
env) Maybe BufSpan
forall a. Maybe a
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 :: 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 = SrcSpan -> DsM a -> DsM a
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (SrcSpanAnn' ann -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' ann
loc)
diagnosticDs :: DsMessage -> DsM ()
diagnosticDs :: DsMessage -> DsM ()
diagnosticDs DsMessage
dsMessage
= do { DsGblEnv
env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; SrcSpan
loc <- DsM SrcSpan
getSrcSpanDs
; !DiagOpts
diag_opts <- DynFlags -> DiagOpts
initDiagOpts (DynFlags -> DiagOpts)
-> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
-> IOEnv (Env DsGblEnv DsLclEnv) DiagOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let msg :: MsgEnvelope DsMessage
msg = DiagOpts
-> SrcSpan
-> PrintUnqualified
-> DsMessage
-> MsgEnvelope DsMessage
forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkMsgEnvelope DiagOpts
diag_opts SrcSpan
loc (DsGblEnv -> PrintUnqualified
ds_unqual DsGblEnv
env) DsMessage
dsMessage
; IORef (Messages DsMessage)
-> (Messages DsMessage -> Messages DsMessage) -> DsM ()
forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> IORef (Messages DsMessage)
ds_msgs DsGblEnv
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
; DsM 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
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
= (() :: Constraint) => TyThing -> Id
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
= (() :: Constraint) => 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
= (() :: Constraint) => 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
= (() :: Constraint) => 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 { 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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsLclEnv -> DsMetaEnv
dsl_meta DsLclEnv
env) }
dsGetCompleteMatches :: DsM CompleteMatches
dsGetCompleteMatches :: DsM [CompleteMatch]
dsGetCompleteMatches = DsGblEnv -> [CompleteMatch]
ds_complete_matches (DsGblEnv -> [CompleteMatch])
-> TcRnIf DsGblEnv DsLclEnv DsGblEnv -> DsM [CompleteMatch]
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 { DsLclEnv
env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; Maybe DsMetaVal -> DsM (Maybe DsMetaVal)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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 :: 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 :: 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 :: forall a. 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 DsMessage
old_msgs <- IORef (Messages DsMessage)
-> TcRnIf DsGblEnv DsLclEnv (Messages DsMessage)
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef (DsGblEnv -> IORef (Messages DsMessage)
ds_msgs DsGblEnv
env)
; a
result <- DsM a
thing_inside
; IORef (Messages DsMessage) -> Messages DsMessage -> DsM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (DsGblEnv -> IORef (Messages DsMessage)
ds_msgs DsGblEnv
env) Messages DsMessage
old_msgs
; a -> DsM a
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result }
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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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) [Mult -> CoreExpr
forall b. Mult -> Expr b
Type ((() :: Constraint) => CoreExpr -> Mult
CoreExpr -> Mult
exprType CoreExpr
expr), CoreExpr
message, CoreExpr
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