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 hs_match ss) = ppr ss <+> pprMatchContext hs_match
data EquationInfo
= EqnInfo { eqn_pats :: [Pat GhcTc]
, eqn_orig :: Origin
, eqn_rhs :: MatchResult CoreExpr
}
instance Outputable EquationInfo where
ppr (EqnInfo pats _ _) = ppr pats
type DsWrapper = CoreExpr -> CoreExpr
idDsWrapper :: DsWrapper
idDsWrapper e = e
data MatchResult a
= MR_Infallible (DsM a)
| MR_Fallible (CoreExpr -> DsM a)
deriving (Functor)
instance Applicative MatchResult where
pure v = MR_Infallible (pure v)
MR_Infallible f <*> MR_Infallible x = MR_Infallible (f <*> x)
f <*> x = MR_Fallible $ \fail -> runMatchResult fail f <*> runMatchResult fail x
runMatchResult :: CoreExpr -> MatchResult a -> DsM a
runMatchResult fail = \case
MR_Infallible body -> body
MR_Fallible body_fn -> body_fn fail
fixDs :: (a -> DsM a) -> DsM a
fixDs = fixM
type DsWarning = (SrcSpan, SDoc)
initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a)
initDsTc thing_inside
= do { tcg_env <- getGblEnv
; msg_var <- liftIO $ newIORef emptyMessages
; hsc_env <- getTopEnv
; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
; e_result <- tryM $
setEnvs envs thing_inside
; msgs <- liftIO $ readIORef msg_var
; return (msgs, case e_result of Left _ -> Nothing
Right x -> Just x)
}
initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a)
initDs hsc_env tcg_env thing_inside
= do { msg_var <- newIORef emptyMessages
; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
; runDs hsc_env envs thing_inside
}
mkDsEnvsFromTcGbl :: MonadIO m
=> HscEnv -> IORef (Messages DsMessage) -> TcGblEnv
-> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
= do { cc_st_var <- liftIO $ newIORef newCostCentreState
; eps <- liftIO $ hscEPS hsc_env
; let unit_env = hsc_unit_env hsc_env
this_mod = tcg_mod tcg_env
type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
fam_inst_env = tcg_fam_inst_env tcg_env
complete_matches = hptCompleteSigs hsc_env
++ tcg_complete_matches tcg_env
++ eps_complete_matches eps
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env
msg_var cc_st_var next_wrapper_num_var complete_matches
}
runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a)
runDs hsc_env (ds_gbl, ds_lcl) thing_inside
= do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
(tryM thing_inside)
; msgs <- readIORef (ds_msgs ds_gbl)
; let final_res
| errorsFound msgs = Nothing
| Right r <- res = Just r
| otherwise = panic "initDs"
; return (msgs, final_res)
}
initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a)
initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
, mg_tcs = tycons, mg_fam_insts = fam_insts
, mg_patsyns = patsyns, mg_rdr_env = rdr_env
, mg_fam_inst_env = fam_inst_env
, mg_complete_matches = local_complete_matches
}) thing_inside
= do { cc_st_var <- newIORef newCostCentreState
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
complete_matches = hptCompleteSigs hsc_env
++ local_complete_matches
++ eps_complete_matches eps
bindsToIds (NonRec v _) = [v]
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
envs = mkDsEnvs unit_env this_mod rdr_env type_env
fam_inst_env msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
}
initTcDsForSolver :: TcM a -> DsM a
initTcDsForSolver thing_inside
= do { (gbl, lcl) <- getEnvs
; hsc_env <- getTopEnv
; let DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env } = gbl
DsLclEnv { dsl_loc = loc } = lcl
; (msgs, mb_ret) <- liftIO $ initTc hsc_env HsSrcFile False mod loc $
updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env
, tcg_rdr_env = rdr_env }) $
thing_inside
; case mb_ret of
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) }
mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
, if_rec_types = KnotVars [mod] (\that_mod -> if that_mod == mod || isInteractiveModule mod
then Just (return type_env)
else Nothing) }
if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
NotBoot
real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
gbl_env = DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
, ds_unqual = mkPrintUnqualified unit_env rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
, ds_next_wrapper_num = next_wrapper_num
}
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span
, dsl_nablas = initNablas
}
in (gbl_env, lcl_env)
newUniqueId :: Id -> Mult -> Type -> DsM Id
newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id)))
duplicateLocalDs :: Id -> DsM Id
duplicateLocalDs old_local
= do { uniq <- newUnique
; return (setIdUnique old_local uniq) }
newPredVarDs :: PredType -> DsM Var
newPredVarDs
= mkSysLocalOrCoVarM (fsLit "ds") Many
newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id
newSysLocalDs = mkSysLocalM (fsLit "ds")
newFailLocalDs = mkSysLocalM (fsLit "fail")
newSysLocalsDs :: [Scaled Type] -> DsM [Id]
newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t)
getGhcModeDs :: DsM GhcMode
getGhcModeDs = getDynFlags >>= return . ghcMode
getPmNablas :: DsM Nablas
getPmNablas = do { env <- getLclEnv; return (dsl_nablas env) }
updPmNablas :: Nablas -> DsM a -> DsM a
updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas })
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv
; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs (UnhelpfulSpan {}) thing_inside
= thing_inside
putSrcSpanDs (RealSrcSpan real_span _) thing_inside
= updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA loc = putSrcSpanDs (locA loc)
diagnosticDs :: DsMessage -> DsM ()
diagnosticDs dsMessage
= do { env <- getGblEnv
; loc <- getSrcSpanDs
; !diag_opts <- initDiagOpts <$> getDynFlags
; let msg = mkMsgEnvelope diag_opts loc (ds_unqual env) dsMessage
; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
errDsCoreExpr :: DsMessage -> DsM CoreExpr
errDsCoreExpr msg
= do { diagnosticDs msg
; return unitExpr }
failWithDs :: DsMessage -> DsM a
failWithDs msg
= do { diagnosticDs msg
; failM }
failDs :: DsM a
failDs = failM
mkPrintUnqualifiedDs :: DsM PrintUnqualified
mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
lookupThing = dsLookupGlobal
dsLookupGlobal :: Name -> DsM TyThing
dsLookupGlobal name
= do { env <- getGblEnv
; setEnvs (ds_if_env env)
(tcIfaceGlobal name) }
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId name
= tyThingId <$> dsLookupGlobal name
dsLookupTyCon :: Name -> DsM TyCon
dsLookupTyCon name
= tyThingTyCon <$> dsLookupGlobal name
dsLookupDataCon :: Name -> DsM DataCon
dsLookupDataCon name
= tyThingDataCon <$> dsLookupGlobal name
dsLookupConLike :: Name -> DsM ConLike
dsLookupConLike name
= tyThingConLike <$> dsLookupGlobal name
dsGetFamInstEnvs :: DsM FamInstEnvs
dsGetFamInstEnvs
= do { eps <- getEps; env <- getGblEnv
; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
dsGetCompleteMatches :: DsM CompleteMatches
dsGetCompleteMatches = ds_complete_matches <$> getGblEnv
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv menv thing_inside
= updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
discardWarningsDs :: DsM a -> DsM a
discardWarningsDs thing_inside
= do { env <- getGblEnv
; old_msgs <- readTcRef (ds_msgs env)
; result <- thing_inside
; writeTcRef (ds_msgs env) old_msgs
; return result }
pprRuntimeTrace :: String
-> SDoc
-> CoreExpr
-> DsM CoreExpr
pprRuntimeTrace str doc expr = do
traceId <- dsLookupGlobalId traceName
unpackCStringId <- dsLookupGlobalId unpackCStringName
dflags <- getDynFlags
let message :: CoreExpr
message = App (Var unpackCStringId) $
Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc)
return $ mkApps (Var traceId) [Type (exprType expr), message, expr]
getCCIndexDsM :: FastString -> DsM CostCentreIndex
getCCIndexDsM = getCCIndexM ds_cc_st