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
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 []
evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
EvCallStack -> m EvExpr
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
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