{-# 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,
mkNamePprCtxDs,
newUnique,
UniqSupply, newUniqueSupply,
getGhcModeDs, dsGetFamInstEnvs,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
dsLookupDataCon, dsLookupConLike,
getCCIndexDsM,
DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
getPmNablas, updPmNablas,
addUnspecables, getUnspecables,
dsGetCompleteMatches,
DsWarning, diagnosticDs, errDsCoreExpr,
failWithDs, failDs, discardWarningsDs,
addMessagesDs, captureMessagesDs,
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.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
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 { 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
ptc :: PromotionTickContext
ptc = DynFlags -> PromotionTickContext
initPromotionTickContext (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_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
-> PromotionTickContext
-> 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 PromotionTickContext
ptc
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. HasCallStack => 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 = [EvVar] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv
typeEnvFromEntities [EvVar]
ids [TyCon]
tycons [PatSyn]
patsyns [FamInst]
fam_insts
ptc :: PromotionTickContext
ptc = DynFlags -> PromotionTickContext
initPromotionTickContext (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
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 :: [EvVar]
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
envs :: (DsGblEnv, DsLclEnv)
envs = UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> PromotionTickContext
-> 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 PromotionTickContext
ptc 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 = fam_inst_env
, tcg_rdr_env = 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
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) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
mkDsEnvs :: UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> PromotionTickContext
-> 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 PromotionTickContext
ptc 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
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 :: [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
, 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 { Unique
uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; EvVar -> DsM EvVar
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvVar -> Unique -> EvVar
setIdUnique EvVar
old_local Unique
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
newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id
newSysLocalDs :: Mult -> Mult -> DsM EvVar
newSysLocalDs = FastString -> Mult -> Mult -> DsM EvVar
forall (m :: * -> *).
MonadUnique m =>
FastString -> Mult -> Mult -> m EvVar
mkSysLocalM (String -> FastString
fsLit String
"ds")
newFailLocalDs :: Mult -> Mult -> DsM EvVar
newFailLocalDs = FastString -> Mult -> Mult -> DsM EvVar
forall (m :: * -> *).
MonadUnique m =>
FastString -> Mult -> Mult -> m EvVar
mkSysLocalM (String -> FastString
fsLit String
"fail")
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
w Mult
t) -> Mult -> Mult -> DsM EvVar
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 })
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 })
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 { 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 = 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 { 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 -> 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
; 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) }
addMessagesDs :: Messages DsMessage -> DsM ()
addMessagesDs :: Messages DsMessage -> DsM ()
addMessagesDs Messages DsMessage
msgs1
= do { IORef (Messages DsMessage)
msg_var <- DsGblEnv -> IORef (Messages DsMessage)
ds_msgs (DsGblEnv -> IORef (Messages DsMessage))
-> TcRnIf DsGblEnv DsLclEnv DsGblEnv
-> IOEnv (Env DsGblEnv DsLclEnv) (IORef (Messages DsMessage))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; Messages DsMessage
msgs0 <- IO (Messages DsMessage)
-> IOEnv (Env DsGblEnv DsLclEnv) (Messages DsMessage)
forall a. IO a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages DsMessage)
-> IOEnv (Env DsGblEnv DsLclEnv) (Messages DsMessage))
-> IO (Messages DsMessage)
-> IOEnv (Env DsGblEnv DsLclEnv) (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
; IO () -> DsM ()
forall a. IO a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DsM ()) -> IO () -> DsM ()
forall a b. (a -> b) -> a -> b
$ IORef (Messages DsMessage) -> Messages DsMessage -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Messages DsMessage)
msg_var (Messages DsMessage
msgs0 Messages DsMessage -> Messages DsMessage -> Messages DsMessage
forall e. Messages e -> Messages e -> Messages e
`unionMessages` Messages DsMessage
msgs1) }
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
captureMessagesDs :: DsM a -> DsM (Messages DsMessage, a)
captureMessagesDs :: forall a. DsM a -> DsM (Messages DsMessage, a)
captureMessagesDs DsM a
thing_inside
= do { IORef (Messages DsMessage)
msg_var <- IO (IORef (Messages DsMessage))
-> IOEnv (Env DsGblEnv DsLclEnv) (IORef (Messages DsMessage))
forall a. IO a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Messages DsMessage))
-> IOEnv (Env DsGblEnv DsLclEnv) (IORef (Messages DsMessage)))
-> IO (IORef (Messages DsMessage))
-> IOEnv (Env DsGblEnv DsLclEnv) (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
; a
res <- (DsGblEnv -> DsGblEnv) -> DsM a -> DsM a
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\DsGblEnv
gbl -> DsGblEnv
gbl {ds_msgs = msg_var}) DsM a
thing_inside
; Messages DsMessage
msgs <- IO (Messages DsMessage)
-> IOEnv (Env DsGblEnv DsLclEnv) (Messages DsMessage)
forall a. IO a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages DsMessage)
-> IOEnv (Env DsGblEnv DsLclEnv) (Messages DsMessage))
-> IO (Messages DsMessage)
-> IOEnv (Env DsGblEnv DsLclEnv) (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, a) -> DsM (Messages DsMessage, a)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages DsMessage
msgs, a
res) }
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 { 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 EvVar
dsLookupGlobalId Name
name
= (() :: Constraint) => 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
= (() :: 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 = 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 { DsGblEnv
env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; Messages DsMessage
old_msgs <- IORef (Messages DsMessage)
-> IOEnv (Env DsGblEnv DsLclEnv) (Messages DsMessage)
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef (DsGblEnv -> IORef (Messages DsMessage)
ds_msgs DsGblEnv
env)
; a
result <- DsM a
thing_inside
; IORef (Messages DsMessage) -> Messages DsMessage -> DsM ()
forall (m :: * -> *) a. MonadIO m => TcRef a -> a -> m ()
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
EvVar
traceId <- Name -> DsM EvVar
dsLookupGlobalId Name
traceName
EvVar
unpackCStringId <- Name -> DsM EvVar
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 (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)
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 (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
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