{-# 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, newSysLocalDsNoLP, newSysLocalDs,
newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,
newFailLocalDs, newPredVarDs,
getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
mkPrintUnqualifiedDs,
newUnique,
UniqSupply, newUniqueSupply,
getGhcModeDs, dsGetFamInstEnvs,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
dsLookupDataCon, dsLookupConLike,
getCCIndexDsM,
DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
getPmNablas, updPmNablas,
dsGetCompleteMatches,
DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
failWithDs, failDs, discardWarningsDs,
askNoErrsDs,
DsMatchContext(..),
EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
pprRuntimeTrace
) where
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Hs
import GHC.HsToCore.Types
import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)
import GHC.Core.FamInstEnv
import GHC.Core
import GHC.Core.Make ( unitExpr )
import GHC.Core.Utils ( exprType, isExprLevPoly )
import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.IfaceToCore
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr )
import GHC.Builtin.Names
import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
import GHC.Types.Name.Reader
import GHC.Types.Basic ( Origin )
import GHC.Types.SourceFile
import GHC.Types.Id
import GHC.Types.SrcLoc
import GHC.Types.TypeEnv
import GHC.Types.Unique.Supply
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Ppr
import GHC.Types.Literal ( mkLitString )
import GHC.Types.CostCentre.State
import GHC.Types.TyThing
import GHC.Types.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Error
import Data.IORef
data DsMatchContext
= DsMatchContext (HsMatchContext GhcRn) SrcSpan
deriving ()
instance Outputable DsMatchContext where
ppr :: DsMatchContext -> SDoc
ppr (DsMatchContext HsMatchContext GhcRn
hs_match SrcSpan
ss) = forall a. Outputable a => a -> SDoc
ppr SrcSpan
ss SDoc -> SDoc -> SDoc
<+> forall p.
(Outputable (IdP p), UnXRec p) =>
HsMatchContext p -> SDoc
pprMatchContext HsMatchContext GhcRn
hs_match
data EquationInfo
= EqnInfo { EquationInfo -> [Pat GhcTc]
eqn_pats :: [Pat GhcTc]
, 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
_) = 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 -> MatchResult b -> MatchResult a
forall a b. (a -> b) -> MatchResult a -> MatchResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> MatchResult b -> MatchResult a
$c<$ :: forall a b. a -> MatchResult b -> MatchResult a
fmap :: forall a b. (a -> b) -> MatchResult a -> MatchResult b
$cfmap :: forall a b. (a -> b) -> MatchResult a -> MatchResult b
Functor)
instance Applicative MatchResult where
pure :: forall a. a -> MatchResult a
pure a
v = forall a. DsM a -> MatchResult a
MR_Infallible (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v)
MR_Infallible DsM (a -> b)
f <*> :: forall a b. MatchResult (a -> b) -> MatchResult a -> MatchResult b
<*> MR_Infallible DsM a
x = forall a. DsM a -> MatchResult a
MR_Infallible (DsM (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DsM a
x)
MatchResult (a -> b)
f <*> MatchResult a
x = forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible forall a b. (a -> b) -> a -> b
$ \CoreExpr
fail -> forall a. CoreExpr -> MatchResult a -> DsM a
runMatchResult CoreExpr
fail MatchResult (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. CoreExpr -> MatchResult a -> DsM a
runMatchResult CoreExpr
fail MatchResult a
x
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 = forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM
type DsWarning = (SrcSpan, SDoc)
initDsTc :: DsM a -> TcM a
initDsTc :: forall a. DsM a -> TcM a
initDsTc DsM a
thing_inside
= do { TcGblEnv
tcg_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; TcRef (Messages DecoratedSDoc)
msg_var <- TcRn (TcRef (Messages DecoratedSDoc))
getErrsVar
; HscEnv
hsc_env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; (DsGblEnv, DsLclEnv)
envs <- forall (m :: * -> *).
MonadIO m =>
HscEnv
-> TcRef (Messages DecoratedSDoc)
-> TcGblEnv
-> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env TcRef (Messages DecoratedSDoc)
msg_var TcGblEnv
tcg_env
; forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (DsGblEnv, DsLclEnv)
envs DsM a
thing_inside
}
initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)
initDs :: forall a.
HscEnv -> TcGblEnv -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)
initDs HscEnv
hsc_env TcGblEnv
tcg_env DsM a
thing_inside
= do { TcRef (Messages DecoratedSDoc)
msg_var <- forall a. a -> IO (IORef a)
newIORef forall e. Messages e
emptyMessages
; (DsGblEnv, DsLclEnv)
envs <- forall (m :: * -> *).
MonadIO m =>
HscEnv
-> TcRef (Messages DecoratedSDoc)
-> TcGblEnv
-> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env TcRef (Messages DecoratedSDoc)
msg_var TcGblEnv
tcg_env
; forall a.
HscEnv
-> (DsGblEnv, DsLclEnv)
-> DsM a
-> IO (Messages DecoratedSDoc, Maybe a)
runDs HscEnv
hsc_env (DsGblEnv, DsLclEnv)
envs DsM a
thing_inside
}
mkDsEnvsFromTcGbl :: MonadIO m
=> HscEnv -> IORef (Messages DecoratedSDoc) -> TcGblEnv
-> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl :: forall (m :: * -> *).
MonadIO m =>
HscEnv
-> TcRef (Messages DecoratedSDoc)
-> TcGblEnv
-> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env TcRef (Messages DecoratedSDoc)
msg_var TcGblEnv
tcg_env
= do { IORef CostCentreState
cc_st_var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef CostCentreState
newCostCentreState
; ExternalPackageState
eps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
; let unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
this_mod :: Module
this_mod = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
type_env :: TypeEnv
type_env = TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
tcg_env
rdr_env :: GlobalRdrEnv
rdr_env = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
tcg_env
fam_inst_env :: FamInstEnv
fam_inst_env = TcGblEnv -> FamInstEnv
tcg_fam_inst_env TcGblEnv
tcg_env
complete_matches :: [CompleteMatch]
complete_matches = HscEnv -> [CompleteMatch]
hptCompleteSigs HscEnv
hsc_env
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [CompleteMatch]
tcg_complete_matches TcGblEnv
tcg_env
forall a. [a] -> [a] -> [a]
++ ExternalPackageState -> [CompleteMatch]
eps_complete_matches ExternalPackageState
eps
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> TcRef (Messages DecoratedSDoc)
-> IORef CostCentreState
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs UnitEnv
unit_env Module
this_mod GlobalRdrEnv
rdr_env TypeEnv
type_env FamInstEnv
fam_inst_env
TcRef (Messages DecoratedSDoc)
msg_var IORef CostCentreState
cc_st_var [CompleteMatch]
complete_matches
}
runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)
runDs :: forall a.
HscEnv
-> (DsGblEnv, DsLclEnv)
-> DsM a
-> IO (Messages DecoratedSDoc, Maybe a)
runDs HscEnv
hsc_env (DsGblEnv
ds_gbl, DsLclEnv
ds_lcl) DsM a
thing_inside
= do { Either IOEnvFailure a
res <- forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf Char
'd' HscEnv
hsc_env DsGblEnv
ds_gbl DsLclEnv
ds_lcl
(forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM DsM a
thing_inside)
; Messages DecoratedSDoc
msgs <- forall a. IORef a -> IO a
readIORef (DsGblEnv -> TcRef (Messages DecoratedSDoc)
ds_msgs DsGblEnv
ds_gbl)
; let final_res :: Maybe a
final_res
| forall e. Messages e -> Bool
errorsFound Messages DecoratedSDoc
msgs = forall a. Maybe a
Nothing
| Right a
r <- Either IOEnvFailure a
res = forall a. a -> Maybe a
Just a
r
| Bool
otherwise = forall a. String -> a
panic String
"initDs"
; forall (m :: * -> *) a. Monad m => a -> m a
return (Messages DecoratedSDoc
msgs, Maybe a
final_res)
}
initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)
initDsWithModGuts :: forall a.
HscEnv -> ModGuts -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)
initDsWithModGuts HscEnv
hsc_env (ModGuts { mg_module :: ModGuts -> Module
mg_module = Module
this_mod, mg_binds :: ModGuts -> CoreProgram
mg_binds = CoreProgram
binds
, mg_tcs :: ModGuts -> [TyCon]
mg_tcs = [TyCon]
tycons, mg_fam_insts :: ModGuts -> [FamInst]
mg_fam_insts = [FamInst]
fam_insts
, mg_patsyns :: ModGuts -> [PatSyn]
mg_patsyns = [PatSyn]
patsyns, mg_rdr_env :: ModGuts -> GlobalRdrEnv
mg_rdr_env = GlobalRdrEnv
rdr_env
, mg_fam_inst_env :: ModGuts -> FamInstEnv
mg_fam_inst_env = FamInstEnv
fam_inst_env
, mg_complete_matches :: ModGuts -> [CompleteMatch]
mg_complete_matches = [CompleteMatch]
local_complete_matches
}) DsM a
thing_inside
= do { IORef CostCentreState
cc_st_var <- forall a. a -> IO (IORef a)
newIORef CostCentreState
newCostCentreState
; TcRef (Messages DecoratedSDoc)
msg_var <- forall a. a -> IO (IORef a)
newIORef forall e. Messages e
emptyMessages
; ExternalPackageState
eps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
; let unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
type_env :: TypeEnv
type_env = [Id] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv
typeEnvFromEntities [Id]
ids [TyCon]
tycons [PatSyn]
patsyns [FamInst]
fam_insts
complete_matches :: [CompleteMatch]
complete_matches = HscEnv -> [CompleteMatch]
hptCompleteSigs HscEnv
hsc_env
forall a. [a] -> [a] -> [a]
++ [CompleteMatch]
local_complete_matches
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) = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, Expr a)]
binds
ids :: [Id]
ids = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. Bind a -> [a]
bindsToIds CoreProgram
binds
envs :: (DsGblEnv, DsLclEnv)
envs = UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> TcRef (Messages DecoratedSDoc)
-> IORef CostCentreState
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs UnitEnv
unit_env Module
this_mod GlobalRdrEnv
rdr_env TypeEnv
type_env
FamInstEnv
fam_inst_env TcRef (Messages DecoratedSDoc)
msg_var IORef CostCentreState
cc_st_var
[CompleteMatch]
complete_matches
; forall a.
HscEnv
-> (DsGblEnv, DsLclEnv)
-> DsM a
-> IO (Messages DecoratedSDoc, Maybe a)
runDs HscEnv
hsc_env (DsGblEnv, DsLclEnv)
envs DsM a
thing_inside
}
initTcDsForSolver :: TcM a -> DsM a
initTcDsForSolver :: forall a. TcM a -> DsM a
initTcDsForSolver TcM a
thing_inside
= do { (DsGblEnv
gbl, DsLclEnv
lcl) <- forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs
; HscEnv
hsc_env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; let DsGblEnv { ds_mod :: DsGblEnv -> Module
ds_mod = Module
mod
, ds_fam_inst_env :: DsGblEnv -> FamInstEnv
ds_fam_inst_env = FamInstEnv
fam_inst_env
, ds_gbl_rdr_env :: DsGblEnv -> GlobalRdrEnv
ds_gbl_rdr_env = GlobalRdrEnv
rdr_env } = DsGblEnv
gbl
DsLclEnv { dsl_loc :: DsLclEnv -> RealSrcSpan
dsl_loc = RealSrcSpan
loc } = DsLclEnv
lcl
; (Messages DecoratedSDoc
msgs, Maybe a
mb_ret) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTc HscEnv
hsc_env HscSource
HsSrcFile Bool
False Module
mod RealSrcSpan
loc forall a b. (a -> b) -> a -> b
$
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\TcGblEnv
tc_gbl -> TcGblEnv
tc_gbl { tcg_fam_inst_env :: FamInstEnv
tcg_fam_inst_env = FamInstEnv
fam_inst_env
, tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env = GlobalRdrEnv
rdr_env }) forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
; case Maybe a
mb_ret of
Just a
ret -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ret
Maybe a
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"initTcDsForSolver" ([SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope DecoratedSDoc) -> [SDoc]
pprMsgEnvelopeBagWithLoc (forall e. Messages e -> Bag (MsgEnvelope e)
getErrorMessages Messages DecoratedSDoc
msgs)) }
mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> IORef (Messages DecoratedSDoc) -> IORef CostCentreState -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
mkDsEnvs :: UnitEnv
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> TcRef (Messages DecoratedSDoc)
-> IORef CostCentreState
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs UnitEnv
unit_env Module
mod GlobalRdrEnv
rdr_env TypeEnv
type_env FamInstEnv
fam_inst_env TcRef (Messages DecoratedSDoc)
msg_var IORef CostCentreState
cc_st_var
[CompleteMatch]
complete_matches
= let if_genv :: IfGblEnv
if_genv = IfGblEnv { if_doc :: SDoc
if_doc = String -> SDoc
text String
"mkDsEnvs",
if_rec_types :: Maybe (Module, IfG TypeEnv)
if_rec_types = forall a. a -> Maybe a
Just (Module
mod, forall (m :: * -> *) a. Monad m => a -> m a
return TypeEnv
type_env) }
if_lenv :: IfLclEnv
if_lenv = Module -> SDoc -> IsBootInterface -> IfLclEnv
mkIfLclEnv Module
mod (String -> SDoc
text String
"GHC error in desugarer lookup in" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Module
mod)
IsBootInterface
NotBoot
real_span :: RealSrcSpan
real_span = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (ModuleName -> FastString
moduleNameFS (forall unit. GenModule unit -> ModuleName
moduleName Module
mod)) Int
1 Int
1)
gbl_env :: DsGblEnv
gbl_env = DsGblEnv { ds_mod :: Module
ds_mod = Module
mod
, ds_fam_inst_env :: FamInstEnv
ds_fam_inst_env = FamInstEnv
fam_inst_env
, ds_gbl_rdr_env :: GlobalRdrEnv
ds_gbl_rdr_env = GlobalRdrEnv
rdr_env
, ds_if_env :: (IfGblEnv, IfLclEnv)
ds_if_env = (IfGblEnv
if_genv, IfLclEnv
if_lenv)
, ds_unqual :: PrintUnqualified
ds_unqual = UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified UnitEnv
unit_env GlobalRdrEnv
rdr_env
, ds_msgs :: TcRef (Messages DecoratedSDoc)
ds_msgs = TcRef (Messages DecoratedSDoc)
msg_var
, ds_complete_matches :: [CompleteMatch]
ds_complete_matches = [CompleteMatch]
complete_matches
, ds_cc_st :: IORef CostCentreState
ds_cc_st = IORef CostCentreState
cc_st_var
}
lcl_env :: DsLclEnv
lcl_env = DsLclEnv { dsl_meta :: DsMetaEnv
dsl_meta = forall a. NameEnv a
emptyNameEnv
, dsl_loc :: RealSrcSpan
dsl_loc = RealSrcSpan
real_span
, dsl_nablas :: Nablas
dsl_nablas = Nablas
initNablas
}
in (DsGblEnv
gbl_env, DsLclEnv
lcl_env)
newUniqueId :: Id -> Mult -> Type -> DsM Id
newUniqueId :: Id -> Type -> Type -> DsM Id
newUniqueId Id
id = FastString -> Type -> Type -> DsM Id
mk_local (OccName -> FastString
occNameFS (Name -> OccName
nameOccName (Id -> Name
idName Id
id)))
duplicateLocalDs :: Id -> DsM Id
duplicateLocalDs :: Id -> DsM Id
duplicateLocalDs Id
old_local
= do { Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Unique -> Id
setIdUnique Id
old_local Unique
uniq) }
newPredVarDs :: PredType -> DsM Var
newPredVarDs :: Type -> DsM Id
newPredVarDs
= forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalOrCoVarM (String -> FastString
fsLit String
"ds") Type
Many
newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id
newSysLocalDsNoLP :: Type -> Type -> DsM Id
newSysLocalDsNoLP = FastString -> Type -> Type -> DsM Id
mk_local (String -> FastString
fsLit String
"ds")
newSysLocalDs :: Type -> Type -> DsM Id
newSysLocalDs = forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalM (String -> FastString
fsLit String
"ds")
newFailLocalDs :: Type -> Type -> DsM Id
newFailLocalDs = forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalM (String -> FastString
fsLit String
"fail")
newSysLocalsDsNoLP, newSysLocalsDs :: [Scaled Type] -> DsM [Id]
newSysLocalsDsNoLP :: [Scaled Type] -> DsM [Id]
newSysLocalsDsNoLP = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Scaled Type
w Type
t) -> Type -> Type -> DsM Id
newSysLocalDsNoLP Type
w Type
t)
newSysLocalsDs :: [Scaled Type] -> DsM [Id]
newSysLocalsDs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Scaled Type
w Type
t) -> Type -> Type -> DsM Id
newSysLocalDs Type
w Type
t)
mk_local :: FastString -> Mult -> Type -> DsM Id
mk_local :: FastString -> Type -> Type -> DsM Id
mk_local FastString
fs Type
w Type
ty = do { Type -> SDoc -> DsM ()
dsNoLevPoly Type
ty (String -> SDoc
text String
"When trying to create a variable of type:" SDoc -> SDoc -> SDoc
<+>
forall a. Outputable a => a -> SDoc
ppr Type
ty)
; forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalOrCoVarM FastString
fs Type
w Type
ty }
getGhcModeDs :: DsM GhcMode
getGhcModeDs :: DsM GhcMode
getGhcModeDs = forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> GhcMode
ghcMode
getPmNablas :: DsM Nablas
getPmNablas :: DsM Nablas
getPmNablas = do { DsLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (DsLclEnv -> Nablas
dsl_nablas DsLclEnv
env) }
updPmNablas :: Nablas -> DsM a -> DsM a
updPmNablas :: forall a. Nablas -> DsM a -> DsM a
updPmNablas Nablas
nablas = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\DsLclEnv
env -> DsLclEnv
env { dsl_nablas :: Nablas
dsl_nablas = Nablas
nablas })
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { DsLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (DsLclEnv -> RealSrcSpan
dsl_loc DsLclEnv
env) forall a. Maybe a
Nothing) }
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs :: forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (UnhelpfulSpan {}) DsM a
thing_inside
= DsM a
thing_inside
putSrcSpanDs (RealSrcSpan RealSrcSpan
real_span Maybe BufSpan
_) DsM a
thing_inside
= forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ DsLclEnv
env -> DsLclEnv
env {dsl_loc :: RealSrcSpan
dsl_loc = RealSrcSpan
real_span}) DsM a
thing_inside
putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA :: forall ann a. SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnn' ann
loc = forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' ann
loc)
warnDs :: WarnReason -> SDoc -> DsM ()
warnDs :: WarnReason -> SDoc -> DsM ()
warnDs WarnReason
reason SDoc
warn
= do { DsGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; SrcSpan
loc <- DsM SrcSpan
getSrcSpanDs
; let msg :: MsgEnvelope DecoratedSDoc
msg = forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning WarnReason
reason forall a b. (a -> b) -> a -> b
$
SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkWarnMsg SrcSpan
loc (DsGblEnv -> PrintUnqualified
ds_unqual DsGblEnv
env) SDoc
warn
; forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> TcRef (Messages DecoratedSDoc)
ds_msgs DsGblEnv
env) (\ Messages DecoratedSDoc
msgs -> MsgEnvelope DecoratedSDoc
msg forall e. MsgEnvelope e -> Messages e -> Messages e
`addMessage` Messages DecoratedSDoc
msgs) }
warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
warnIfSetDs WarningFlag
flag SDoc
warn
= forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
flag forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> DsM ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
flag) SDoc
warn
errDs :: SDoc -> DsM ()
errDs :: SDoc -> DsM ()
errDs SDoc
err
= do { DsGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; SrcSpan
loc <- DsM SrcSpan
getSrcSpanDs
; let msg :: MsgEnvelope DecoratedSDoc
msg = SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkMsgEnvelope SrcSpan
loc (DsGblEnv -> PrintUnqualified
ds_unqual DsGblEnv
env) SDoc
err
; forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> TcRef (Messages DecoratedSDoc)
ds_msgs DsGblEnv
env) (\ Messages DecoratedSDoc
msgs -> MsgEnvelope DecoratedSDoc
msg forall e. MsgEnvelope e -> Messages e -> Messages e
`addMessage` Messages DecoratedSDoc
msgs) }
errDsCoreExpr :: SDoc -> DsM CoreExpr
errDsCoreExpr :: SDoc -> DsM CoreExpr
errDsCoreExpr SDoc
err
= do { SDoc -> DsM ()
errDs SDoc
err
; forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
unitExpr }
failWithDs :: SDoc -> DsM a
failWithDs :: forall a. SDoc -> DsM a
failWithDs SDoc
err
= do { SDoc -> DsM ()
errDs SDoc
err
; forall env a. IOEnv env a
failM }
failDs :: DsM a
failDs :: forall a. DsM a
failDs = forall env a. IOEnv env a
failM
askNoErrsDs :: DsM a -> DsM (a, Bool)
askNoErrsDs :: forall a. DsM a -> DsM (a, Bool)
askNoErrsDs DsM a
thing_inside
= do { TcRef (Messages DecoratedSDoc)
errs_var <- forall a env. a -> IOEnv env (IORef a)
newMutVar forall e. Messages e
emptyMessages
; DsGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; Either IOEnvFailure a
mb_res <- forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM forall a b. (a -> b) -> a -> b
$
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv (DsGblEnv
env { ds_msgs :: TcRef (Messages DecoratedSDoc)
ds_msgs = TcRef (Messages DecoratedSDoc)
errs_var }) forall a b. (a -> b) -> a -> b
$
DsM a
thing_inside
; Messages DecoratedSDoc
msgs <- forall a env. IORef a -> IOEnv env a
readMutVar TcRef (Messages DecoratedSDoc)
errs_var
; forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> TcRef (Messages DecoratedSDoc)
ds_msgs DsGblEnv
env) (forall e. Messages e -> Messages e -> Messages e
unionMessages Messages DecoratedSDoc
msgs)
; case Either IOEnvFailure a
mb_res of
Left IOEnvFailure
_ -> forall env a. IOEnv env a
failM
Right a
res -> do { let errs_found :: Bool
errs_found = forall e. Messages e -> Bool
errorsFound Messages DecoratedSDoc
msgs
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, Bool -> Bool
not Bool
errs_found) } }
mkPrintUnqualifiedDs :: DsM PrintUnqualified
mkPrintUnqualifiedDs :: DsM PrintUnqualified
mkPrintUnqualifiedDs = DsGblEnv -> PrintUnqualified
ds_unqual forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
lookupThing :: Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
lookupThing = Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal
dsLookupGlobal :: Name -> DsM TyThing
dsLookupGlobal :: Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal Name
name
= do { DsGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (DsGblEnv -> (IfGblEnv, IfLclEnv)
ds_if_env DsGblEnv
env)
(Name -> IfL TyThing
tcIfaceGlobal Name
name) }
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId Name
name
= HasDebugCallStack => TyThing -> Id
tyThingId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal Name
name
dsLookupTyCon :: Name -> DsM TyCon
dsLookupTyCon :: Name -> IOEnv (Env DsGblEnv DsLclEnv) TyCon
dsLookupTyCon Name
name
= HasDebugCallStack => TyThing -> TyCon
tyThingTyCon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal Name
name
dsLookupDataCon :: Name -> DsM DataCon
dsLookupDataCon :: Name -> IOEnv (Env DsGblEnv DsLclEnv) DataCon
dsLookupDataCon Name
name
= HasDebugCallStack => TyThing -> DataCon
tyThingDataCon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal Name
name
dsLookupConLike :: Name -> DsM ConLike
dsLookupConLike :: Name -> DsM ConLike
dsLookupConLike Name
name
= HasDebugCallStack => TyThing -> ConLike
tyThingConLike forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal Name
name
dsGetFamInstEnvs :: DsM FamInstEnvs
dsGetFamInstEnvs :: DsM FamInstEnvs
dsGetFamInstEnvs
= do { ExternalPackageState
eps <- forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps; DsGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (ExternalPackageState -> FamInstEnv
eps_fam_inst_env ExternalPackageState
eps, DsGblEnv -> FamInstEnv
ds_fam_inst_env DsGblEnv
env) }
dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv :: DsM DsMetaEnv
dsGetMetaEnv = do { DsLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (DsLclEnv -> DsMetaEnv
dsl_meta DsLclEnv
env) }
dsGetCompleteMatches :: DsM CompleteMatches
dsGetCompleteMatches :: DsM [CompleteMatch]
dsGetCompleteMatches = DsGblEnv -> [CompleteMatch]
ds_complete_matches forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv Name
name = do { DsLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (DsLclEnv -> DsMetaEnv
dsl_meta DsLclEnv
env) Name
name) }
dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv :: forall a. DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv DsMetaEnv
menv DsM a
thing_inside
= forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\DsLclEnv
env -> DsLclEnv
env { dsl_meta :: DsMetaEnv
dsl_meta = DsLclEnv -> DsMetaEnv
dsl_meta DsLclEnv
env forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` DsMetaEnv
menv }) DsM a
thing_inside
discardWarningsDs :: DsM a -> DsM a
discardWarningsDs :: forall a. DsM a -> DsM a
discardWarningsDs DsM a
thing_inside
= do { DsGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; Messages DecoratedSDoc
old_msgs <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef (DsGblEnv -> TcRef (Messages DecoratedSDoc)
ds_msgs DsGblEnv
env)
; a
result <- DsM a
thing_inside
; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (DsGblEnv -> TcRef (Messages DecoratedSDoc)
ds_msgs DsGblEnv
env) Messages DecoratedSDoc
old_msgs
; forall (m :: * -> *) a. Monad m => a -> m a
return a
result }
dsNoLevPoly :: Type -> SDoc -> DsM ()
dsNoLevPoly :: Type -> SDoc -> DsM ()
dsNoLevPoly Type
ty SDoc
doc = forall (m :: * -> *).
Monad m =>
(SDoc -> m ()) -> SDoc -> Type -> m ()
checkForLevPolyX forall a. SDoc -> DsM a
failWithDs SDoc
doc Type
ty
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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs :: forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs DsM a
thing_inside a -> CoreExpr
mk_expr
= do { (a
result, Bool
no_errs) <- forall a. DsM a -> DsM (a, Bool)
askNoErrsDs DsM a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
no_errs
then a -> CoreExpr
mk_expr a
result
else CoreExpr
unitExpr }
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 <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let message :: CoreExpr
message :: CoreExpr
message = forall b. Expr b -> Expr b -> Expr b
App (forall b. Id -> Expr b
Var Id
unpackCStringId) forall a b. (a -> b) -> a -> b
$
forall b. Literal -> Expr b
Lit forall a b. (a -> b) -> a -> b
$ String -> Literal
mkLitString forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
str) Int
4 SDoc
doc)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
traceId) [forall b. Type -> Expr b
Type (CoreExpr -> Type
exprType CoreExpr
expr), CoreExpr
message, CoreExpr
expr]
getCCIndexDsM :: FastString -> DsM CostCentreIndex
getCCIndexDsM :: FastString -> DsM CostCentreIndex
getCCIndexDsM = forall gbl lcl.
(gbl -> IORef CostCentreState)
-> FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM DsGblEnv -> IORef CostCentreState
ds_cc_st