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


@DsMonad@: monadery used in desugaring
-}

{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan
{-# LANGUAGE ViewPatterns #-}

module DsMonad (
        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,
        mkPrintUnqualifiedDs,
        newUnique,
        UniqSupply, newUniqueSupply,
        getGhcModeDs, dsGetFamInstEnvs,
        dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
        dsLookupDataCon, dsLookupConLike,

        DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,

        -- Getting and setting EvVars and term constraints in local environment
        getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,

        -- Iterations for pm checking
        incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,

        -- Warnings and errors
        DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
        failWithDs, failDs, discardWarningsDs,
        askNoErrsDs,

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

        -- Levity polymorphism
        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,

        -- Trace injection
        pprRuntimeTrace
    ) where

import GhcPrelude

import TcRnMonad
import FamInstEnv
import CoreSyn
import MkCore    ( unitExpr )
import CoreUtils ( exprType, isExprLevPoly )
import HsSyn
import TcIface
import TcMType ( checkForLevPolyX, formatLevPolyErr )
import PrelNames
import RdrName
import HscTypes
import Bag
import BasicTypes ( Origin )
import DataCon
import ConLike
import TyCon
import PmExpr
import Id
import Module
import Outputable
import SrcLoc
import Type
import UniqSupply
import Name
import NameEnv
import DynFlags
import ErrUtils
import FastString
import Var (EvVar)
import UniqFM ( lookupWithDefaultUFM )
import Literal ( mkLitString )
import CostCentreState

import Data.IORef

{-
************************************************************************
*                                                                      *
                Data types for the desugarer
*                                                                      *
************************************************************************
-}

data DsMatchContext
  = DsMatchContext (HsMatchContext Name) SrcSpan
  deriving ()

instance Outputable DsMatchContext where
  ppr :: DsMatchContext -> SDoc
ppr (DsMatchContext hs_match :: HsMatchContext Name
hs_match ss :: SrcSpan
ss) = SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
ss SDoc -> SDoc -> SDoc
<+> HsMatchContext Name -> SDoc
forall id.
(Outputable (NameOrRdrName id), Outputable id) =>
HsMatchContext id -> SDoc
pprMatchContext HsMatchContext Name
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 "DsUtils"

            , 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
eqn_rhs  :: MatchResult
              -- ^ What to do after match
            }

instance Outputable EquationInfo where
    ppr :: EquationInfo -> SDoc
ppr (EqnInfo pats :: [Pat GhcTc]
pats _ _) = [Pat GhcTc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Pat GhcTc]
pats

type DsWrapper = CoreExpr -> CoreExpr
idDsWrapper :: DsWrapper
idDsWrapper :: DsWrapper
idDsWrapper e :: CoreExpr
e = CoreExpr
e

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


-- A MatchResult is an expression with a hole in it
data MatchResult
  = MatchResult
        CanItFail       -- Tells whether the failure expression is used
        (CoreExpr -> DsM CoreExpr)
                        -- Takes a expression to plug in at the
                        -- failure point(s). The expression should
                        -- be duplicatable!

data CanItFail = CanFail | CantFail

orFail :: CanItFail -> CanItFail -> CanItFail
orFail :: CanItFail -> CanItFail -> CanItFail
orFail CantFail CantFail = CanItFail
CantFail
orFail _        _        = CanItFail
CanFail

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

-- Compatibility functions
fixDs :: (a -> DsM a) -> DsM a
fixDs :: (a -> DsM a) -> DsM a
fixDs    = (a -> DsM a) -> DsM 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 print_unqual stuff later on to turn it
        -- into a Doc.

-- | Run a 'DsM' action inside the 'TcM' monad.
initDsTc :: DsM a -> TcM a
initDsTc :: DsM a -> TcM a
initDsTc thing_inside :: DsM a
thing_inside
  = do { TcGblEnv
tcg_env  <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; TcRef Messages
msg_var  <- TcRn (TcRef Messages)
getErrsVar
       ; HscEnv
hsc_env  <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
       ; (DsGblEnv, DsLclEnv)
envs     <- HscEnv
-> TcRef Messages
-> TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (DsGblEnv, DsLclEnv)
forall (m :: * -> *).
MonadIO m =>
HscEnv -> TcRef Messages -> TcGblEnv -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env TcRef Messages
msg_var TcGblEnv
tcg_env
       ; (DsGblEnv, DsLclEnv) -> DsM a -> TcM 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
       }

-- | Run a 'DsM' action inside the 'IO' monad.
initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
initDs hsc_env :: HscEnv
hsc_env tcg_env :: TcGblEnv
tcg_env thing_inside :: DsM a
thing_inside
  = do { TcRef Messages
msg_var <- Messages -> IO (TcRef Messages)
forall a. a -> IO (IORef a)
newIORef Messages
emptyMessages
       ; (DsGblEnv, DsLclEnv)
envs <- HscEnv -> TcRef Messages -> TcGblEnv -> IO (DsGblEnv, DsLclEnv)
forall (m :: * -> *).
MonadIO m =>
HscEnv -> TcRef Messages -> TcGblEnv -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl HscEnv
hsc_env TcRef Messages
msg_var TcGblEnv
tcg_env
       ; HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
forall a.
HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, 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 -> TcGblEnv
                  -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl :: HscEnv -> TcRef Messages -> TcGblEnv -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl hsc_env :: HscEnv
hsc_env msg_var :: TcRef Messages
msg_var tcg_env :: TcGblEnv
tcg_env
  = do { IORef Int
pm_iter_var <- IO (IORef Int) -> m (IORef Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> m (IORef Int))
-> IO (IORef Int) -> m (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 0
       ; IORef CostCentreState
cc_st_var   <- IO (IORef CostCentreState) -> m (IORef CostCentreState)
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
       ; let dflags :: DynFlags
dflags   = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
             this_mod :: Module
this_mod = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
             type_env :: TypeEnv
type_env = TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
tcg_env
             rdr_env :: GlobalRdrEnv
rdr_env  = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
tcg_env
             fam_inst_env :: FamInstEnv
fam_inst_env = TcGblEnv -> FamInstEnv
tcg_fam_inst_env TcGblEnv
tcg_env
             complete_matches :: [CompleteMatch]
complete_matches = HscEnv -> [CompleteMatch]
hptCompleteSigs HscEnv
hsc_env
                                [CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [CompleteMatch]
tcg_complete_matches TcGblEnv
tcg_env
       ; (DsGblEnv, DsLclEnv) -> m (DsGblEnv, DsLclEnv)
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
$ DynFlags
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> TcRef Messages
-> IORef Int
-> IORef CostCentreState
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs DynFlags
dflags Module
this_mod GlobalRdrEnv
rdr_env TypeEnv
type_env FamInstEnv
fam_inst_env
                           TcRef Messages
msg_var IORef Int
pm_iter_var IORef CostCentreState
cc_st_var [CompleteMatch]
complete_matches
       }

runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
runDs hsc_env :: HscEnv
hsc_env (ds_gbl :: DsGblEnv
ds_gbl, ds_lcl :: DsLclEnv
ds_lcl) thing_inside :: 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 '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
msgs   <- TcRef Messages -> IO Messages
forall a. IORef a -> IO a
readIORef (DsGblEnv -> TcRef Messages
ds_msgs DsGblEnv
ds_gbl)
       ; let final_res :: Maybe a
final_res
               | DynFlags -> Messages -> Bool
errorsFound DynFlags
dflags Messages
msgs = Maybe a
forall a. Maybe a
Nothing
               | Right r :: a
r <- Either IOEnvFailure a
res          = a -> Maybe a
forall a. a -> Maybe a
Just a
r
               | Bool
otherwise               = String -> Maybe a
forall a. String -> a
panic "initDs"
       ; (Messages, Maybe a) -> IO (Messages, Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages
msgs, Maybe a
final_res)
       }
  where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

-- | Run a 'DsM' action in the context of an existing 'ModGuts'
initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
initDsWithModGuts hsc_env :: HscEnv
hsc_env guts :: ModGuts
guts thing_inside :: DsM a
thing_inside
  = do { IORef Int
pm_iter_var <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 0
       ; IORef CostCentreState
cc_st_var   <- CostCentreState -> IO (IORef CostCentreState)
forall a. a -> IO (IORef a)
newIORef CostCentreState
newCostCentreState
       ; TcRef Messages
msg_var <- Messages -> IO (TcRef Messages)
forall a. a -> IO (IORef a)
newIORef Messages
emptyMessages
       ; let dflags :: DynFlags
dflags   = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
             type_env :: TypeEnv
type_env = [Id] -> [TyCon] -> [FamInst] -> TypeEnv
typeEnvFromEntities [Id]
ids (ModGuts -> [TyCon]
mg_tcs ModGuts
guts) (ModGuts -> [FamInst]
mg_fam_insts ModGuts
guts)
             rdr_env :: GlobalRdrEnv
rdr_env  = ModGuts -> GlobalRdrEnv
mg_rdr_env ModGuts
guts
             fam_inst_env :: FamInstEnv
fam_inst_env = ModGuts -> FamInstEnv
mg_fam_inst_env ModGuts
guts
             this_mod :: Module
this_mod = ModGuts -> Module
mg_module ModGuts
guts
             complete_matches :: [CompleteMatch]
complete_matches = HscEnv -> [CompleteMatch]
hptCompleteSigs HscEnv
hsc_env
                                [CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ ModGuts -> [CompleteMatch]
mg_complete_sigs ModGuts
guts

             bindsToIds :: Bind b -> [b]
bindsToIds (NonRec v :: b
v _)   = [b
v]
             bindsToIds (Rec    binds :: [(b, Expr b)]
binds) = ((b, Expr b) -> b) -> [(b, Expr b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, Expr b) -> b
forall a b. (a, b) -> a
fst [(b, Expr b)]
binds
             ids :: [Id]
ids = (Bind Id -> [Id]) -> [Bind Id] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind Id -> [Id]
forall b. Bind b -> [b]
bindsToIds (ModGuts -> [Bind Id]
mg_binds ModGuts
guts)

             envs :: (DsGblEnv, DsLclEnv)
envs  = DynFlags
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> TcRef Messages
-> IORef Int
-> IORef CostCentreState
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs DynFlags
dflags Module
this_mod GlobalRdrEnv
rdr_env TypeEnv
type_env
                              FamInstEnv
fam_inst_env TcRef Messages
msg_var IORef Int
pm_iter_var
                              IORef CostCentreState
cc_st_var [CompleteMatch]
complete_matches
       ; HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
forall a.
HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
runDs HscEnv
hsc_env (DsGblEnv, DsLclEnv)
envs DsM a
thing_inside
       }

initTcDsForSolver :: TcM a -> DsM (Messages, Maybe 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 :: TcM a -> DsM (Messages, Maybe a)
initTcDsForSolver thing_inside :: TcM a
thing_inside
  = do { (gbl :: DsGblEnv
gbl, lcl :: 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 } = DsGblEnv
gbl

             DsLclEnv { dsl_loc :: DsLclEnv -> RealSrcSpan
dsl_loc = RealSrcSpan
loc }                  = DsLclEnv
lcl

       ; IO (Messages, Maybe a) -> DsM (Messages, Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages, Maybe a) -> DsM (Messages, Maybe a))
-> IO (Messages, Maybe a) -> DsM (Messages, Maybe a)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM a
-> IO (Messages, Maybe a)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages, Maybe r)
initTc HscEnv
hsc_env HscSource
HsSrcFile Bool
False Module
mod RealSrcSpan
loc (TcM a -> IO (Messages, Maybe a))
-> TcM a -> IO (Messages, 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 (\tc_gbl :: TcGblEnv
tc_gbl -> TcGblEnv
tc_gbl { tcg_fam_inst_env :: FamInstEnv
tcg_fam_inst_env = FamInstEnv
fam_inst_env }) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
         TcM a
thing_inside }

mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
         -> IORef Messages -> IORef Int -> IORef CostCentreState
         -> [CompleteMatch] -> (DsGblEnv, DsLclEnv)
mkDsEnvs :: DynFlags
-> Module
-> GlobalRdrEnv
-> TypeEnv
-> FamInstEnv
-> TcRef Messages
-> IORef Int
-> IORef CostCentreState
-> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags :: DynFlags
dflags mod :: Module
mod rdr_env :: GlobalRdrEnv
rdr_env type_env :: TypeEnv
type_env fam_inst_env :: FamInstEnv
fam_inst_env msg_var :: TcRef Messages
msg_var pmvar :: IORef Int
pmvar cc_st_var :: IORef CostCentreState
cc_st_var
         complete_matches :: [CompleteMatch]
complete_matches
  = let if_genv :: IfGblEnv
if_genv = IfGblEnv :: SDoc -> Maybe (Module, IfG TypeEnv) -> IfGblEnv
IfGblEnv { if_doc :: SDoc
if_doc       = String -> SDoc
text "mkDsEnvs",
                             if_rec_types :: Maybe (Module, IfG TypeEnv)
if_rec_types = (Module, IfG TypeEnv) -> Maybe (Module, IfG TypeEnv)
forall a. a -> Maybe a
Just (Module
mod, TypeEnv -> IfG TypeEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TypeEnv
type_env) }
        if_lenv :: IfLclEnv
if_lenv = Module -> SDoc -> Bool -> IfLclEnv
mkIfLclEnv Module
mod (String -> SDoc
text "GHC error in desugarer lookup in" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
                             Bool
False -- not boot!
        real_span :: RealSrcSpan
real_span = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (ModuleName -> FastString
moduleNameFS (Module -> ModuleName
moduleName Module
mod)) 1 1)
        completeMatchMap :: CompleteMatchMap
completeMatchMap = [CompleteMatch] -> CompleteMatchMap
mkCompleteMatchMap [CompleteMatch]
complete_matches
        gbl_env :: DsGblEnv
gbl_env = DsGblEnv :: Module
-> FamInstEnv
-> PrintUnqualified
-> TcRef Messages
-> (IfGblEnv, IfLclEnv)
-> CompleteMatchMap
-> IORef CostCentreState
-> DsGblEnv
DsGblEnv { ds_mod :: Module
ds_mod     = Module
mod
                           , ds_fam_inst_env :: FamInstEnv
ds_fam_inst_env = FamInstEnv
fam_inst_env
                           , ds_if_env :: (IfGblEnv, IfLclEnv)
ds_if_env  = (IfGblEnv
if_genv, IfLclEnv
if_lenv)
                           , ds_unqual :: PrintUnqualified
ds_unqual  = DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified DynFlags
dflags GlobalRdrEnv
rdr_env
                           , ds_msgs :: TcRef Messages
ds_msgs    = TcRef Messages
msg_var
                           , ds_complete_matches :: CompleteMatchMap
ds_complete_matches = CompleteMatchMap
completeMatchMap
                           , ds_cc_st :: IORef CostCentreState
ds_cc_st   = IORef CostCentreState
cc_st_var
                           }
        lcl_env :: DsLclEnv
lcl_env = DsLclEnv :: DsMetaEnv
-> RealSrcSpan -> Bag Id -> Bag SimpleEq -> IORef Int -> DsLclEnv
DsLclEnv { dsl_meta :: DsMetaEnv
dsl_meta    = DsMetaEnv
forall a. NameEnv a
emptyNameEnv
                           , dsl_loc :: RealSrcSpan
dsl_loc     = RealSrcSpan
real_span
                           , dsl_dicts :: Bag Id
dsl_dicts   = Bag Id
forall a. Bag a
emptyBag
                           , dsl_tm_cs :: Bag SimpleEq
dsl_tm_cs   = Bag SimpleEq
forall a. Bag a
emptyBag
                           , dsl_pm_iter :: IORef Int
dsl_pm_iter = IORef Int
pmvar
                           }
    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.

Note [Levity polymorphism checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
According to the "Levity Polymorphism" paper (PLDI '17), levity
polymorphism is forbidden in precisely two places: in the type of a bound
term-level argument and in the type of an argument to a function. The paper
explains it more fully, but briefly: expressions in these contexts need to be
stored in registers, and it's hard (read, impossible) to store something
that's levity polymorphic.

We cannot check for bad levity polymorphism conveniently in the type checker,
because we can't tell, a priori, which levity metavariables will be solved.
At one point, I (Richard) thought we could check in the zonker, but it's hard
to know where precisely are the abstracted variables and the arguments. So
we check in the desugarer, the only place where we can see the Core code and
still report respectable syntax to the user. This covers the vast majority
of cases; see calls to DsMonad.dsNoLevPoly and friends.

Levity polymorphism is also prohibited in the types of binders, and the
desugarer checks for this in GHC-generated Ids. (The zonker handles
the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.
The newSysLocalDs variant is used in the vast majority of cases where
the binder is obviously not levity polymorphic, omitting the check.
It would be nice to ASSERT that there is no levity polymorphism here,
but we can't, because of the fixM in DsArrows. It's all OK, though:
Core Lint will catch an error here.

However, the desugarer is the wrong place for certain checks. In particular,
the desugarer can't report a sensible error message if an HsWrapper is malformed.
After all, GHC itself produced the HsWrapper. So we store some message text
in the appropriate HsWrappers (e.g. WpFun) that we can print out in the
desugarer.

There are a few more checks in places where Core is generated outside the
desugarer. For example, in datatype and class declarations, where levity
polymorphism is checked for during validity checking. It would be nice to
have one central place for all this, but that doesn't seem possible while
still reporting nice error messages.

-}

-- Make a new Id with the same print name, but different type, and new unique
newUniqueId :: Id -> Type -> DsM Id
newUniqueId :: Id -> Type -> DsM Id
newUniqueId id :: Id
id = FastString -> 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 old_local :: Id
old_local
  = do  { Unique
uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
        ; Id -> DsM Id
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 pred :: Type
pred
 = Type -> DsM Id
newSysLocalDs Type
pred

newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
newSysLocalDsNoLP :: Type -> DsM Id
newSysLocalDsNoLP  = FastString -> Type -> DsM Id
mk_local (String -> FastString
fsLit "ds")

-- this variant should be used when the caller can be sure that the variable type
-- is not levity-polymorphic. It is necessary when the type is knot-tied because
-- of the fixM used in DsArrows. See Note [Levity polymorphism checking]
newSysLocalDs :: Type -> DsM Id
newSysLocalDs = FastString -> Type -> DsM Id
forall (m :: * -> *). MonadUnique m => FastString -> Type -> m Id
mkSysLocalOrCoVarM (String -> FastString
fsLit "ds")
newFailLocalDs :: Type -> DsM Id
newFailLocalDs = FastString -> Type -> DsM Id
forall (m :: * -> *). MonadUnique m => FastString -> Type -> m Id
mkSysLocalOrCoVarM (String -> FastString
fsLit "fail")
  -- the fail variable is used only in a situation where we can tell that
  -- levity-polymorphism is impossible.

newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]
newSysLocalsDsNoLP :: [Type] -> DsM [Id]
newSysLocalsDsNoLP = (Type -> DsM Id) -> [Type] -> DsM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM Id
newSysLocalDsNoLP
newSysLocalsDs :: [Type] -> DsM [Id]
newSysLocalsDs = (Type -> DsM Id) -> [Type] -> DsM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM Id
newSysLocalDs

mk_local :: FastString -> Type -> DsM Id
mk_local :: FastString -> Type -> DsM Id
mk_local fs :: FastString
fs ty :: Type
ty = do { Type -> SDoc -> DsM ()
dsNoLevPoly Type
ty (String -> SDoc
text "When trying to create a variable of type:" SDoc -> SDoc -> SDoc
<+>
                                      Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)  -- could improve the msg with another
                                               -- parameter indicating context
                    ; FastString -> Type -> DsM Id
forall (m :: * -> *). MonadUnique m => FastString -> Type -> m Id
mkSysLocalOrCoVarM FastString
fs Type
ty }

{-
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GhcMode -> DsM GhcMode
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 in-scope type constraints (pm check)
getDictsDs :: DsM (Bag EvVar)
getDictsDs :: DsM (Bag Id)
getDictsDs = do { DsLclEnv
env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; Bag Id -> DsM (Bag Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (DsLclEnv -> Bag Id
dsl_dicts DsLclEnv
env) }

-- | Add in-scope type constraints (pm check)
addDictsDs :: Bag EvVar -> DsM a -> DsM a
addDictsDs :: Bag Id -> DsM a -> DsM a
addDictsDs ev_vars :: Bag Id
ev_vars
  = (DsLclEnv -> DsLclEnv) -> DsM a -> DsM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\env :: DsLclEnv
env -> DsLclEnv
env { dsl_dicts :: Bag Id
dsl_dicts = Bag Id -> Bag Id -> Bag Id
forall a. Bag a -> Bag a -> Bag a
unionBags Bag Id
ev_vars (DsLclEnv -> Bag Id
dsl_dicts DsLclEnv
env) })

-- | Get in-scope term constraints (pm check)
getTmCsDs :: DsM (Bag SimpleEq)
getTmCsDs :: DsM (Bag SimpleEq)
getTmCsDs = do { DsLclEnv
env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; Bag SimpleEq -> DsM (Bag SimpleEq)
forall (m :: * -> *) a. Monad m => a -> m a
return (DsLclEnv -> Bag SimpleEq
dsl_tm_cs DsLclEnv
env) }

-- | Add in-scope term constraints (pm check)
addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
addTmCsDs tm_cs :: Bag SimpleEq
tm_cs
  = (DsLclEnv -> DsLclEnv) -> DsM a -> DsM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\env :: DsLclEnv
env -> DsLclEnv
env { dsl_tm_cs :: Bag SimpleEq
dsl_tm_cs = Bag SimpleEq -> Bag SimpleEq -> Bag SimpleEq
forall a. Bag a -> Bag a -> Bag a
unionBags Bag SimpleEq
tm_cs (DsLclEnv -> Bag SimpleEq
dsl_tm_cs DsLclEnv
env) })

-- | Increase the counter for elapsed pattern match check iterations.
-- If the current counter is already over the limit, fail
incrCheckPmIterDs :: DsM Int
incrCheckPmIterDs :: DsM Int
incrCheckPmIterDs = do
  DsLclEnv
env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
  Int
cnt <- IORef Int -> DsM Int
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef (DsLclEnv -> IORef Int
dsl_pm_iter DsLclEnv
env)
  Int
max_iters <- DynFlags -> Int
maxPmCheckIterations (DynFlags -> Int)
-> IOEnv (Env DsGblEnv DsLclEnv) DynFlags -> DsM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  if Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
max_iters
    then DsM ()
forall env a. IOEnv env a
failM
    else IORef Int -> (Int -> Int) -> DsM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef (DsLclEnv -> IORef Int
dsl_pm_iter DsLclEnv
env) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+1)
  Int -> DsM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
cnt

-- | Reset the counter for pattern match check iterations to zero
resetPmIterDs :: DsM ()
resetPmIterDs :: DsM ()
resetPmIterDs = do { DsLclEnv
env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; IORef Int -> Int -> DsM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (DsLclEnv -> IORef Int
dsl_pm_iter DsLclEnv
env) 0 }

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 (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> SrcSpan
RealSrcSpan (DsLclEnv -> RealSrcSpan
dsl_loc DsLclEnv
env)) }

putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs (UnhelpfulSpan {}) thing_inside :: DsM a
thing_inside
  = DsM a
thing_inside
putSrcSpanDs (RealSrcSpan real_span :: RealSrcSpan
real_span) thing_inside :: 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 (\ env :: DsLclEnv
env -> DsLclEnv
env {dsl_loc :: RealSrcSpan
dsl_loc = RealSrcSpan
real_span}) DsM a
thing_inside

-- | Emit a warning for the current source location
-- NB: Warns whether or not -Wxyz is set
warnDs :: WarnReason -> SDoc -> DsM ()
warnDs :: WarnReason -> SDoc -> DsM ()
warnDs reason :: WarnReason
reason warn :: SDoc
warn
  = do { DsGblEnv
env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; SrcSpan
loc <- DsM SrcSpan
getSrcSpanDs
       ; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; let msg :: ErrMsg
msg = WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning WarnReason
reason (ErrMsg -> ErrMsg) -> ErrMsg -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                   DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkWarnMsg DynFlags
dflags SrcSpan
loc (DsGblEnv -> PrintUnqualified
ds_unqual DsGblEnv
env) SDoc
warn
       ; TcRef Messages -> (Messages -> Messages) -> DsM ()
forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> TcRef Messages
ds_msgs DsGblEnv
env) (\ (w :: WarningMessages
w,e :: WarningMessages
e) -> (WarningMessages
w WarningMessages -> ErrMsg -> WarningMessages
forall a. Bag a -> a -> Bag a
`snocBag` ErrMsg
msg, WarningMessages
e)) }

-- | Emit a warning only if the correct WarnReason is set in the DynFlags
warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
warnIfSetDs flag :: WarningFlag
flag warn :: SDoc
warn
  = WarningFlag -> DsM () -> DsM ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
flag (DsM () -> DsM ()) -> DsM () -> DsM ()
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 err :: SDoc
err
  = do  { DsGblEnv
env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; SrcSpan
loc <- DsM SrcSpan
getSrcSpanDs
        ; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; let msg :: ErrMsg
msg = DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkErrMsg DynFlags
dflags SrcSpan
loc (DsGblEnv -> PrintUnqualified
ds_unqual DsGblEnv
env) SDoc
err
        ; TcRef Messages -> (Messages -> Messages) -> DsM ()
forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> TcRef Messages
ds_msgs DsGblEnv
env) (\ (w :: WarningMessages
w,e :: WarningMessages
e) -> (WarningMessages
w, WarningMessages
e WarningMessages -> ErrMsg -> WarningMessages
forall a. Bag a -> a -> Bag a
`snocBag` ErrMsg
msg)) }

-- | Issue an error, but return the expression for (), so that we can continue
-- reporting errors.
errDsCoreExpr :: SDoc -> DsM CoreExpr
errDsCoreExpr :: SDoc -> DsM CoreExpr
errDsCoreExpr err :: SDoc
err
  = do { SDoc -> DsM ()
errDs SDoc
err
       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
unitExpr }

failWithDs :: SDoc -> DsM a
failWithDs :: SDoc -> DsM a
failWithDs err :: SDoc
err
  = do  { SDoc -> DsM ()
errDs SDoc
err
        ; DsM a
forall env a. IOEnv env a
failM }

failDs :: DsM a
failDs :: DsM a
failDs = DsM a
forall env a. IOEnv env a
failM

-- (askNoErrsDs m) runs m
-- If m fails,
--    then (askNoErrsDs m) fails
-- If m succeeds with result r,
--    then (askNoErrsDs m) succeeds with result (r, b),
--         where b is True iff m generated no errors
-- Regardless of success or failure,
--   propagate any errors/warnings generated by m
--
-- c.f. TcRnMonad.askNoErrs
askNoErrsDs :: DsM a -> DsM (a, Bool)
askNoErrsDs :: DsM a -> DsM (a, Bool)
askNoErrsDs thing_inside :: DsM a
thing_inside
 = do { TcRef Messages
errs_var <- Messages -> IOEnv (Env DsGblEnv DsLclEnv) (TcRef Messages)
forall a env. a -> IOEnv env (IORef a)
newMutVar Messages
emptyMessages
      ; DsGblEnv
env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
      ; Either IOEnvFailure a
mb_res <- DsM a -> IOEnv (Env DsGblEnv DsLclEnv) (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM (DsM a -> IOEnv (Env DsGblEnv DsLclEnv) (Either IOEnvFailure a))
-> DsM a -> IOEnv (Env DsGblEnv DsLclEnv) (Either IOEnvFailure a)
forall a b. (a -> b) -> a -> b
$  -- Be careful to catch exceptions
                          -- so that we propagate errors correctly
                          -- (Trac #13642)
                  DsGblEnv -> DsM a -> DsM a
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv (DsGblEnv
env { ds_msgs :: TcRef Messages
ds_msgs = TcRef Messages
errs_var }) (DsM a -> DsM a) -> DsM a -> DsM a
forall a b. (a -> b) -> a -> b
$
                  DsM a
thing_inside

      -- Propagate errors
      ; msgs :: Messages
msgs@(warns :: WarningMessages
warns, errs :: WarningMessages
errs) <- TcRef Messages -> IOEnv (Env DsGblEnv DsLclEnv) Messages
forall a env. IORef a -> IOEnv env a
readMutVar TcRef Messages
errs_var
      ; TcRef Messages -> (Messages -> Messages) -> DsM ()
forall a env. IORef a -> (a -> a) -> IOEnv env ()
updMutVar (DsGblEnv -> TcRef Messages
ds_msgs DsGblEnv
env) (\ (w :: WarningMessages
w,e :: WarningMessages
e) -> (WarningMessages
w WarningMessages -> WarningMessages -> WarningMessages
forall a. Bag a -> Bag a -> Bag a
`unionBags` WarningMessages
warns, WarningMessages
e WarningMessages -> WarningMessages -> WarningMessages
forall a. Bag a -> Bag a -> Bag a
`unionBags` WarningMessages
errs))

      -- And return
      ; case Either IOEnvFailure a
mb_res of
           Left _    -> DsM (a, Bool)
forall env a. IOEnv env a
failM
           Right res :: a
res -> do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                           ; let errs_found :: Bool
errs_found = DynFlags -> Messages -> Bool
errorsFound DynFlags
dflags Messages
msgs
                           ; (a, Bool) -> DsM (a, Bool)
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 (DsGblEnv -> PrintUnqualified)
-> TcRnIf DsGblEnv DsLclEnv DsGblEnv -> DsM PrintUnqualified
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv

instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
    lookupThing :: Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
lookupThing = Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal

dsLookupGlobal :: Name -> DsM TyThing
-- Very like TcEnv.tcLookupGlobal
dsLookupGlobal :: Name -> IOEnv (Env DsGblEnv DsLclEnv) TyThing
dsLookupGlobal name :: 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
name
  = 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
name
  = 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
name
  = 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
name
  = 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (DsLclEnv -> DsMetaEnv
dsl_meta DsLclEnv
env) }

-- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`.
dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
dsGetCompleteMatches tc :: TyCon
tc = 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
  let lookup_completes :: UniqFM [a] -> [a]
lookup_completes ufm :: UniqFM [a]
ufm = UniqFM [a] -> [a] -> TyCon -> [a]
forall key elt. Uniquable key => UniqFM elt -> elt -> key -> elt
lookupWithDefaultUFM UniqFM [a]
ufm [] TyCon
tc
      eps_matches_list :: [CompleteMatch]
eps_matches_list = CompleteMatchMap -> [CompleteMatch]
forall a. UniqFM [a] -> [a]
lookup_completes (CompleteMatchMap -> [CompleteMatch])
-> CompleteMatchMap -> [CompleteMatch]
forall a b. (a -> b) -> a -> b
$ ExternalPackageState -> CompleteMatchMap
eps_complete_matches ExternalPackageState
eps
      env_matches_list :: [CompleteMatch]
env_matches_list = CompleteMatchMap -> [CompleteMatch]
forall a. UniqFM [a] -> [a]
lookup_completes (CompleteMatchMap -> [CompleteMatch])
-> CompleteMatchMap -> [CompleteMatch]
forall a b. (a -> b) -> a -> b
$ DsGblEnv -> CompleteMatchMap
ds_complete_matches DsGblEnv
env
  [CompleteMatch] -> DsM [CompleteMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CompleteMatch] -> DsM [CompleteMatch])
-> [CompleteMatch] -> DsM [CompleteMatch]
forall a b. (a -> b) -> a -> b
$ [CompleteMatch]
eps_matches_list [CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ [CompleteMatch]
env_matches_list

dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv name :: Name
name = do { DsLclEnv
env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; Maybe DsMetaVal -> DsM (Maybe DsMetaVal)
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 :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv menv :: DsMetaEnv
menv thing_inside :: 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 (\env :: DsLclEnv
env -> DsLclEnv
env { dsl_meta :: DsMetaEnv
dsl_meta = DsLclEnv -> DsMetaEnv
dsl_meta DsLclEnv
env DsMetaEnv -> DsMetaEnv -> DsMetaEnv
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` DsMetaEnv
menv }) DsM a
thing_inside

discardWarningsDs :: DsM a -> DsM a
-- Ignore warnings inside the thing inside;
-- used to ignore inaccessable cases etc. inside generated code
discardWarningsDs :: DsM a -> DsM a
discardWarningsDs thing_inside :: DsM a
thing_inside
  = do  { DsGblEnv
env <- TcRnIf DsGblEnv DsLclEnv DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; Messages
old_msgs <- TcRef Messages -> IOEnv (Env DsGblEnv DsLclEnv) Messages
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef (DsGblEnv -> TcRef Messages
ds_msgs DsGblEnv
env)

        ; a
result <- DsM a
thing_inside

        -- Revert messages to old_msgs
        ; TcRef Messages -> Messages -> DsM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (DsGblEnv -> TcRef Messages
ds_msgs DsGblEnv
env) Messages
old_msgs

        ; a -> DsM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result }

-- | Fail with an error message if the type is levity polymorphic.
dsNoLevPoly :: Type -> SDoc -> DsM ()
-- See Note [Levity polymorphism checking]
dsNoLevPoly :: Type -> SDoc -> DsM ()
dsNoLevPoly ty :: Type
ty doc :: SDoc
doc = (SDoc -> DsM ()) -> SDoc -> Type -> DsM ()
forall (m :: * -> *).
Monad m =>
(SDoc -> m ()) -> SDoc -> Type -> m ()
checkForLevPolyX SDoc -> DsM ()
errDs SDoc
doc Type
ty

-- | Check an expression for levity polymorphism, failing if it is
-- levity polymorphic.
dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
-- See Note [Levity polymorphism checking]
dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
dsNoLevPolyExpr e :: CoreExpr
e doc :: 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       = () -> DsM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Runs the thing_inside. If there are no errors, then returns the expr
-- given. Otherwise, returns unitExpr. This is useful for doing a bunch
-- of levity polymorphism checks and then avoiding making a core App.
-- (If we make a core App on a levity polymorphic argument, detecting how
-- to handle the let/app invariant might call isUnliftedType, which panics
-- on a levity polymorphic type.)
-- See #12709 for an example of why this machinery is necessary.
dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs thing_inside :: DsM a
thing_inside mk_expr :: a -> CoreExpr
mk_expr
  = do { (result :: a
result, no_errs :: Bool
no_errs) <- DsM a -> DsM (a, Bool)
forall a. DsM a -> DsM (a, Bool)
askNoErrsDs DsM a
thing_inside
       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ if Bool
no_errs
                  then a -> CoreExpr
mk_expr a
result
                  else CoreExpr
unitExpr }

-- | 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 str :: String
str doc :: SDoc
doc expr :: CoreExpr
expr = do
  Id
traceId <- Name -> DsM Id
dsLookupGlobalId Name
traceName
  Id
unpackCStringId <- Name -> DsM Id
dsLookupGlobalId Name
unpackCStringName
  DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let message :: CoreExpr
      message :: CoreExpr
message = CoreExpr -> DsWrapper
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
unpackCStringId) DsWrapper -> DsWrapper
forall a b. (a -> b) -> a -> b
$
                Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr) -> Literal -> CoreExpr
forall a b. (a -> b) -> a -> b
$ String -> Literal
mkLitString (String -> Literal) -> String -> Literal
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
str) 4 SDoc
doc)
  CoreExpr -> DsM CoreExpr
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) [Type -> CoreExpr
forall b. Type -> Expr b
Type (CoreExpr -> Type
exprType CoreExpr
expr), CoreExpr
message, CoreExpr
expr]