-- (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
mkCoreConWrapApps 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