    -- (those who have too heavy dependencies for GHC.Tc.Types.Evidence)
    module GHC.Tc.Types.EvTerm
        ( evDelayedError, evCallStack )
    where

    import GHC.Prelude

    import GHC.Driver.DynFlags

    import GHC.Tc.Types.Evidence

    import GHC.Unit

    import GHC.Builtin.Names
    import GHC.Builtin.Types ( unitTy )

    import GHC.Core.Type
    import GHC.Core
    import GHC.Core.Make
    import GHC.Core.Utils

    import GHC.Types.SrcLoc
    import GHC.Types.TyThing

    -- Used with Opt_DeferTypeErrors
    -- See Note [Deferring coercion errors to runtime]
    -- in GHC.Tc.Solver
    evDelayedError :: Type -> String -> EvTerm
    evDelayedError :: Type -> String -> EvTerm
    evDelayedError Type
    ty String
    msg
      = EvExpr -> EvTerm
    EvExpr (EvExpr -> EvTerm) -> EvExpr -> EvTerm
    forall a b. (a -> b) -> a -> b
    $
        let fail_expr :: EvExpr
    fail_expr = Id -> Type -> String -> EvExpr
    mkRuntimeErrorApp Id
    tYPE_ERROR_ID Type
    unitTy String
    msg
        in EvExpr -> Scaled Type -> Type -> [CoreAlt] -> EvExpr
    mkWildCase EvExpr
    fail_expr (Type -> Scaled Type
    forall a. a -> Scaled a
    unrestricted Type
    unitTy) Type
    ty []
           -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils
           -- c.f. mkErrorAppDs in GHC.HsToCore.Utils

    -- Dictionary for CallStack implicit parameters
    evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
        EvCallStack -> m EvExpr
    -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
    evCallStack :: forall (m :: * -> *).
    (MonadThings m, HasModule m, HasDynFlags m) =>
    EvCallStack -> m EvExpr
    evCallStack EvCallStack
    EvCsEmpty =
      Id -> EvExpr
    forall b. Id -> Expr b
    Var (Id -> EvExpr) -> m Id -> m EvExpr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Name -> m Id
    forall (m :: * -> *). MonadThings m => Name -> m Id
    lookupId Name
    emptyCallStackName
    evCallStack (EvCsPushCall FastString
    fs RealSrcSpan
    loc EvExpr
    tm) = do
      df            <- m DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
      let platform = DynFlags -> Platform
    targetPlatform DynFlags
    df
      m             <- getModule
      srcLocDataCon <- lookupDataCon srcLocDataConName
      let mkSrcLoc RealSrcSpan
    l = DataCon -> [EvExpr] -> EvExpr
    mkCoreConApps DataCon
    srcLocDataCon ([EvExpr] -> EvExpr) -> m [EvExpr] -> m EvExpr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$>
                   [m EvExpr] -> m [EvExpr]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence [ FastString -> m EvExpr
    forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
    mkStringExprFS (Unit -> FastString
    forall u. IsUnitId u => u -> FastString
    unitFS (Unit -> FastString) -> Unit -> FastString
    forall a b. (a -> b) -> a -> b
    $ Module -> Unit
    forall unit. GenModule unit -> unit
    moduleUnit Module
    m)
                            , FastString -> m EvExpr
    forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
    mkStringExprFS (ModuleName -> FastString
    moduleNameFS (ModuleName -> FastString) -> ModuleName -> FastString
    forall a b. (a -> b) -> a -> b
    $ Module -> ModuleName
    forall unit. GenModule unit -> ModuleName
    moduleName Module
    m)
                            , FastString -> m EvExpr
    forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
    mkStringExprFS (RealSrcSpan -> FastString
    srcSpanFile RealSrcSpan
    l)
                            , EvExpr -> m EvExpr
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (EvExpr -> m EvExpr) -> EvExpr -> m EvExpr
    forall a b. (a -> b) -> a -> b
    $ Platform -> Int -> EvExpr
    mkIntExprInt Platform
    platform (RealSrcSpan -> Int
    srcSpanStartLine RealSrcSpan
    l)
                            , EvExpr -> m EvExpr
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (EvExpr -> m EvExpr) -> EvExpr -> m EvExpr
    forall a b. (a -> b) -> a -> b
    $ Platform -> Int -> EvExpr
    mkIntExprInt Platform
    platform (RealSrcSpan -> Int
    srcSpanStartCol RealSrcSpan
    l)
                            , EvExpr -> m EvExpr
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (EvExpr -> m EvExpr) -> EvExpr -> m EvExpr
    forall a b. (a -> b) -> a -> b
    $ Platform -> Int -> EvExpr
    mkIntExprInt Platform
    platform (RealSrcSpan -> Int
    srcSpanEndLine RealSrcSpan
    l)
                            , EvExpr -> m EvExpr
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (EvExpr -> m EvExpr) -> EvExpr -> m EvExpr
    forall a b. (a -> b) -> a -> b
    $ Platform -> Int -> EvExpr
    mkIntExprInt Platform
    platform (RealSrcSpan -> Int
    srcSpanEndCol RealSrcSpan
    l)
                            ]

      pushCSVar <- lookupId pushCallStackName
      let pushCS EvExpr
    name EvExpr
    loc EvExpr
    rest =
            EvExpr -> [EvExpr] -> EvExpr
    mkCoreApps (Id -> EvExpr
    forall b. Id -> Expr b
    Var Id
    pushCSVar) [[EvExpr] -> EvExpr
    mkCoreTup [EvExpr
    name, EvExpr
    loc], EvExpr
    rest]

      let mkPush FastString
    name RealSrcSpan
    loc EvExpr
    tm = do
            nameExpr <- FastString -> m EvExpr
    forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
    mkStringExprFS FastString
    name
            locExpr <- mkSrcLoc loc
            -- at this point tm :: IP sym CallStack
            -- but we need the actual CallStack to pass to pushCS,
            -- so we use unwrapIP to strip the dictionary wrapper
            -- See Note [Overview of implicit CallStacks]
            let ip_co = Type -> CoercionR
    unwrapIP (HasDebugCallStack => EvExpr -> Type
    EvExpr -> Type
    exprType EvExpr
    tm)
            return (pushCS nameExpr locExpr (Cast tm ip_co))

      mkPush fs loc tm