{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


Monadery used in desugaring
-}

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,

        -- Getting and setting pattern match oracle states
        getPmNablas, updPmNablas,

        -- Get COMPLETE sets of a TyCon
        dsGetCompleteMatches,

        -- Warnings and errors
        DsWarning, diagnosticDs, errDsCoreExpr,
        failWithDs, failDs, discardWarningsDs,

        -- Data types
        DsMatchContext(..),
        EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,

        -- Trace injection
        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 types for the desugarer
*                                                                      *
************************************************************************
-}

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
forall doc. IsLine doc => doc -> doc -> doc
<+> 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]
              -- ^ The patterns for an equation
              --
              -- NB: We have /already/ applied 'decideBangHood' to
              -- these patterns.  See Note [decideBangHood] in "GHC.HsToCore.Utils"

            , EquationInfo -> Origin
eqn_orig :: Origin
              -- ^ Was this equation present in the user source?
              --
              -- This helps us avoid warnings on patterns that GHC elaborated.
              --
              -- For instance, the pattern @-1 :: Word@ gets desugared into
              -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
              -- literal for /both/ of these cases.

            , EquationInfo -> MatchResult CoreExpr
eqn_rhs  :: MatchResult CoreExpr
              -- ^ What to do after match
            }

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

-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult CoreExpr
--      \fail. wrap (case vs of { pats -> rhs fail })
-- where vs are not bound by wrap

-- | This is a value of type a with potentially a CoreExpr-shaped hole in it.
-- This is used to deal with cases where we are potentially handling pattern
-- match failure, and want to later specify how failure is handled.
data MatchResult a
  -- | We represent the case where there is no hole without a function from
  -- 'CoreExpr', like this, because sometimes we have nothing to put in the
  -- hole and so want to be sure there is in fact no hole.
  = 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)

-- | Product is an "or" on fallibility---the combined match result is infallible
-- only if the left and right argument match results both were.
--
-- This is useful for combining a bunch of alternatives together and then
-- getting the overall fallibility of the entire group. See 'mkDataConCase' for
-- an example.
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

-- Given a fail expression to use, and a MatchResult CoreExpr, compute the filled CoreExpr whether
-- the MatchResult CoreExpr was failable or not.
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

{-
************************************************************************
*                                                                      *
                Monad functions
*                                                                      *
************************************************************************
-}

-- Compatibility functions
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)
        -- Not quite the same as a WarnMsg, we have an SDoc here
        -- and we'll do the name_ppr_ctx stuff later on to turn it
        -- into a Doc.

-- | Run a 'DsM' action inside the 'TcM' monad.
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
$  -- need to tryM so that we don't discard
                             -- DsMessages
                     (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)
       }

-- | Run a 'DsM' action inside the 'IO' monad.
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
       }

-- | Build a set of desugarer environments derived from a 'TcGblEnv'.
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         -- from the home package
                                [CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [CompleteMatch]
tcg_complete_matches TcGblEnv
tcg_env -- from the current module
                                [CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ ExternalPackageState -> [CompleteMatch]
eps_complete_matches ExternalPackageState
eps     -- from imports
             -- re-use existing next_wrapper_num to ensure uniqueness
             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)
       }

-- | Run a 'DsM' action in the context of an existing 'ModGuts'
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
             ptc :: PromotionTickContext
ptc = DynFlags -> PromotionTickContext
initPromotionTickContext (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
             complete_matches :: [CompleteMatch]
complete_matches = HscEnv -> [CompleteMatch]
hptCompleteSigs HscEnv
hsc_env     -- from the home package
                                [CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ [CompleteMatch]
local_complete_matches  -- from the current module
                                [CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ ExternalPackageState -> [CompleteMatch]
eps_complete_matches ExternalPackageState
eps -- from imports

             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
-> 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
-- Spin up a TcM context so that we can run the constraint solver
-- Returns any error messages generated by the constraint solver
-- and (Just res) if no error happened; Nothing if an error happened
--
-- Simon says: I'm not very happy about this.  We spin up a complete TcM monad
--             only to immediately refine it to a TcS monad.
-- Better perhaps to make TcS into its own monad, rather than building on TcS
-- But that may in turn interact with plugins

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
       -- This is *the* use of ds_gbl_rdr_env:
       -- Make sure the solver (used by the pattern-match overlap checker) has
       -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it
       -- knows how to reduce type families, and which newtypes it can unwrap.


             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"
  -- Failing tests here are `ghci` and `T11985` if you get this wrong.
  -- this is very very "at a distance" because the reason for this check is that the type_env in interactive
  -- mode is the smushed together of all the interactive modules.
  -- See Note [Why is KnotVars not a ModuleEnv]
                             , 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
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
                           }
    in (DsGblEnv
gbl_env, DsLclEnv
lcl_env)


{-
************************************************************************
*                                                                      *
                Operations in the monad
*                                                                      *
************************************************************************

And all this mysterious stuff is so we can occasionally reach out and
grab one or more names.  @newLocalDs@ isn't exported---exported
functions are defined with it.  The difference in name-strings makes
it easier to read debugging output.

-}

-- Make a new Id with the same print name, but different type, and new unique
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
ManyTy  -- like newSysLocalDs, but we allow covars

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)

{-
We can also reach out and either set/grab location information from
the @SrcSpan@ being carried around.
-}

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

-- | Get the current pattern match oracle state. See 'dsl_nablas'.
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) }

-- | Set the pattern match oracle state within the scope of the given action.
-- See 'dsl_nablas'.
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 })

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 :: 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)

-- | Emit a diagnostic for the current source location. In case the diagnostic is a warning,
-- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags.
-- See Note [Discarding Messages] in 'GHC.Types.Error'.
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) }

-- | Issue an error, but return the expression for (), so that we can continue
-- reporting errors.
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

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
-- Very like GHC.Tc.Utils.Env.tcLookupGlobal
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
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
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) }

-- | The @COMPLETE@ pragmas that are in scope.
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
-- Ignore warnings inside the thing inside;
-- used to ignore inaccessible cases etc. inside generated code
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

        -- Revert messages to old_msgs
        ; 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 }

-- | Inject a trace message into the compiled program. Whereas
-- pprTrace prints out information *while compiling*, pprRuntimeTrace
-- captures that information and causes it to be printed *at runtime*
-- using Debug.Trace.trace.
--
--   pprRuntimeTrace hdr doc expr
--
-- will produce an expression that looks like
--
--   trace (hdr + doc) expr
--
-- When using this to debug a module that Debug.Trace depends on,
-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
-- but that doesn't seem worth the effort and maintenance cost.
pprRuntimeTrace :: String   -- ^ header
                -> SDoc     -- ^ information to output
                -> CoreExpr -- ^ expression
                -> 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
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 (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]

-- | See 'getCCIndexM'.
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