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

    Monadery used in desugaring
    -}

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

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

    module GHC.HsToCore.Monad (
            DsM, mapM, mapAndUnzipM,
            initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
            foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
            Applicative(..),(<$>),

            duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,
            newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,
            newFailLocalDs, newPredVarDs,
            getSrcSpanDs, putSrcSpanDs,
            mkPrintUnqualifiedDs,
            newUnique,
            UniqSupply, newUniqueSupply,
            getGhcModeDs, dsGetFamInstEnvs,
            dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
            dsLookupDataCon, dsLookupConLike,

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

            -- Getting and setting pattern match oracle states
            getPmDeltas, updPmDeltas,

            -- Get COMPLETE sets of a TyCon
            dsGetCompleteMatches,

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

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

            -- Levity polymorphism
            dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,

            -- Trace injection
            pprRuntimeTrace
        ) where

    import GHC.Prelude

    import GHC.Tc.Utils.Monad
    import GHC.Core.FamInstEnv
    import GHC.Core
    import GHC.Core.Make  ( unitExpr )
    import GHC.Core.Utils ( exprType, isExprLevPoly )
    import GHC.Hs
    import GHC.IfaceToCore
    import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr )
    import GHC.Builtin.Names
    import GHC.Types.Name.Reader
    import GHC.Driver.Types
    import GHC.Data.Bag
    import GHC.Types.Basic ( Origin )
    import GHC.Core.DataCon
    import GHC.Core.ConLike
    import GHC.Core.TyCon
    import GHC.HsToCore.PmCheck.Types
    import GHC.Types.Id
    import GHC.Unit.Module
    import GHC.Utils.Outputable
    import GHC.Types.SrcLoc
    import GHC.Core.Type
    import GHC.Core.Multiplicity
    import GHC.Types.Unique.Supply
    import GHC.Types.Name
    import GHC.Types.Name.Env
    import GHC.Driver.Session
    import GHC.Utils.Error
    import GHC.Data.FastString
    import GHC.Types.Unique.FM ( lookupWithDefaultUFM_Directly )
    import GHC.Types.Literal ( mkLitString )
    import GHC.Types.CostCentre.State

    import Data.IORef

    {-
    ************************************************************************
    *                                                                      *
                    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
    <+> HsMatchContext GhcRn -> SDoc
    forall p. Outputable (IdP 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
    <$ :: forall a b. a -> MatchResult b -> MatchResult a
    $c<$ :: forall a b. a -> MatchResult b -> MatchResult a
    fmap :: forall a b. (a -> b) -> MatchResult a -> MatchResult b
    $cfmap :: forall a b. (a -> b) -> MatchResult a -> MatchResult b
    Functor)

    -- | Product is an "or" on falliblity---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 falliblity 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 (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 (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 (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 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 :: forall a. DsM a -> TcM a
    initDsTc 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 :: forall a. HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
    initDs HscEnv
    hsc_env TcGblEnv
    tcg_env 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 :: forall (m :: * -> *).
    MonadIO m =>
    HscEnv -> TcRef Messages -> TcGblEnv -> m (DsGblEnv, DsLclEnv)
    mkDsEnvsFromTcGbl HscEnv
    hsc_env TcRef Messages
    msg_var TcGblEnv
    tcg_env
      = do { 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 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 CostCentreState
    cc_st_var [CompleteMatch]
    complete_matches
           }

    runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
    runDs :: forall a.
    HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, 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
    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 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 String
    "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 :: forall a. HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
    initDsWithModGuts HscEnv
    hsc_env ModGuts
    guts DsM a
    thing_inside
      = do { 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 b
    v Expr b
    _)   = [b
    v]
                 bindsToIds (Rec    [(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 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 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 :: forall a. TcM a -> DsM (Messages, Maybe 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 } = 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 (\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 CostCentreState -> [CompleteMatch]
             -> (DsGblEnv, DsLclEnv)
    mkDsEnvs :: DynFlags
    -> Module
    -> GlobalRdrEnv
    -> TypeEnv
    -> FamInstEnv
    -> TcRef Messages
    -> IORef CostCentreState
    -> [CompleteMatch]
    -> (DsGblEnv, DsLclEnv)
    mkDsEnvs DynFlags
    dflags Module
    mod GlobalRdrEnv
    rdr_env TypeEnv
    type_env FamInstEnv
    fam_inst_env TcRef Messages
    msg_var IORef CostCentreState
    cc_st_var
             [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 String
    "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 -> IsBootInterface -> IfLclEnv
    mkIfLclEnv Module
    mod (String -> SDoc
    text String
    "GHC error in desugarer lookup in" SDoc -> SDoc -> SDoc
    <+> 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)
            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 -> Deltas -> DsLclEnv
    DsLclEnv { dsl_meta :: DsMetaEnv
    dsl_meta    = DsMetaEnv
    forall a. NameEnv a
    emptyNameEnv
                               , dsl_loc :: RealSrcSpan
    dsl_loc     = RealSrcSpan
    real_span
                               , dsl_deltas :: Deltas
    dsl_deltas  = Deltas
    initDeltas
                               }
        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 GHC.HsToCore.Monad.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 GHC.HsToCore.Arrows. 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 -> Mult -> Type -> DsM Id
    newUniqueId :: Id -> Type -> Type -> DsM Id
    newUniqueId Id
    id = FastString -> Type -> Type -> DsM Id
    mk_local (OccName -> FastString
    occNameFS (Name -> OccName
    nameOccName (Id -> Name
    idName Id
    id)))

    duplicateLocalDs :: Id -> DsM Id
    duplicateLocalDs :: Id -> DsM Id
    duplicateLocalDs Id
    old_local
      = do  { Unique
    uniq <- 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
     = FastString -> Type -> Type -> DsM Id
    forall (m :: * -> *).
    MonadUnique m =>
    FastString -> Type -> Type -> m Id
    mkSysLocalOrCoVarM (String -> FastString
    fsLit String
    "ds") Type
    Many  -- like newSysLocalDs, but we allow covars

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

    -- 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 GHC.HsToCore.Arrows. See Note [Levity polymorphism checking]
    newSysLocalDs :: Type -> Type -> DsM Id
    newSysLocalDs = FastString -> Type -> Type -> DsM Id
    forall (m :: * -> *).
    MonadUnique m =>
    FastString -> Type -> Type -> m Id
    mkSysLocalM (String -> FastString
    fsLit String
    "ds")
    newFailLocalDs :: Type -> Type -> DsM Id
    newFailLocalDs = FastString -> Type -> Type -> DsM Id
    forall (m :: * -> *).
    MonadUnique m =>
    FastString -> Type -> Type -> m Id
    mkSysLocalM (String -> FastString
    fsLit String
    "fail")
      -- the fail variable is used only in a situation where we can tell that
      -- levity-polymorphism is impossible.

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

    mk_local :: FastString -> Mult -> Type -> DsM Id
    mk_local :: FastString -> Type -> Type -> DsM Id
    mk_local FastString
    fs Type
    w Type
    ty = do { Type -> SDoc -> DsM ()
    dsNoLevPoly Type
    ty (String -> SDoc
    text String
    "When trying to create a variable of type:" SDoc -> SDoc -> SDoc
    <+>
                                            Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty)  -- could improve the msg with another
                                                     -- parameter indicating context
                          ; FastString -> Type -> Type -> DsM Id
    forall (m :: * -> *).
    MonadUnique m =>
    FastString -> Type -> Type -> m Id
    mkSysLocalOrCoVarM FastString
    fs Type
    w 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 the current pattern match oracle state. See 'dsl_deltas'.
    getPmDeltas :: DsM Deltas
    getPmDeltas :: DsM Deltas
    getPmDeltas = do { DsLclEnv
    env <- TcRnIf DsGblEnv DsLclEnv DsLclEnv
    forall gbl lcl. TcRnIf gbl lcl lcl
    getLclEnv; Deltas -> DsM Deltas
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsLclEnv -> Deltas
    dsl_deltas DsLclEnv
    env) }

    -- | Set the pattern match oracle state within the scope of the given action.
    -- See 'dsl_deltas'.
    updPmDeltas :: Deltas -> DsM a -> DsM a
    updPmDeltas :: forall a. Deltas -> DsM a -> DsM a
    updPmDeltas Deltas
    delta = (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_deltas :: Deltas
    dsl_deltas = Deltas
    delta })

    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 -> Maybe BufSpan -> SrcSpan
    RealSrcSpan (DsLclEnv -> RealSrcSpan
    dsl_loc DsLclEnv
    env) Maybe BufSpan
    forall a. Maybe a
    Nothing) }

    putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
    putSrcSpanDs :: forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs (UnhelpfulSpan {}) DsM a
    thing_inside
      = DsM a
    thing_inside
    putSrcSpanDs (RealSrcSpan RealSrcSpan
    real_span Maybe BufSpan
    _) DsM a
    thing_inside
      = (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 :: 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 WarnReason
    reason 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) (\ (WarningMessages
    w,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 WarningFlag
    flag 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 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) (\ (WarningMessages
    w,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 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 :: forall a. SDoc -> DsM a
    failWithDs SDoc
    err
      = do  { SDoc -> DsM ()
    errDs SDoc
    err
            ; 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

    -- (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. GHC.Tc.Utils.Monad.askNoErrs
    askNoErrsDs :: DsM a -> DsM (a, Bool)
    askNoErrsDs :: forall a. DsM a -> DsM (a, Bool)
    askNoErrsDs 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
                              -- (#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@(WarningMessages
    warns, 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) (\ (WarningMessages
    w,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 IOEnvFailure
    _    -> DsM (a, Bool)
    forall env a. IOEnv env a
    failM
               Right 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 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
      = HasDebugCallStack => 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
      = HasDebugCallStack => 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
      = HasDebugCallStack => 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
      = HasDebugCallStack => 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 (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 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
          -- We index into a UniqFM from Name -> elt, for tyCon it holds that
          -- getUnique (tyConName tc) == getUnique tc. So we lookup using the
          -- unique directly instead.
      let lookup_completes :: UniqFM key [a] -> [a]
    lookup_completes UniqFM key [a]
    ufm = UniqFM key [a] -> [a] -> Unique -> [a]
    forall key elt. UniqFM key elt -> elt -> Unique -> elt
    lookupWithDefaultUFM_Directly UniqFM key [a]
    ufm [] (TyCon -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique TyCon
    tc)
          eps_matches_list :: [CompleteMatch]
    eps_matches_list = CompleteMatchMap -> [CompleteMatch]
    forall {key} {a}. UniqFM key [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 {key} {a}. UniqFM key [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 = 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 :: 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 :: 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 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
    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 Type
    ty SDoc
    doc = (SDoc -> DsM ()) -> SDoc -> Type -> DsM ()
    forall (m :: * -> *).
    Monad m =>
    (SDoc -> m ()) -> SDoc -> Type -> m ()
    checkForLevPolyX SDoc -> DsM ()
    forall a. SDoc -> DsM a
    failWithDs 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 CoreExpr
    e SDoc
    doc
      | CoreExpr -> Bool
    isExprLevPoly CoreExpr
    e = SDoc -> DsM ()
    errDs (Type -> SDoc
    formatLevPolyErr (CoreExpr -> Type
    exprType CoreExpr
    e) SDoc -> SDoc -> SDoc
    $$ SDoc
    doc)
      | Bool
    otherwise       = () -> 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 :: forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
    dsWhenNoErrs DsM a
    thing_inside a -> CoreExpr
    mk_expr
      = do { (a
    result, 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 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
    text String
    str) Int
    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]