-- (those who have too heavy dependencies for TcEvidence)
module TcEvTerm
    ( evDelayedError, evCallStack )
where

import GhcPrelude

import FastString
import Type
import CoreSyn
import MkCore
import Literal ( Literal(..) )
import TcEvidence
import HscTypes
import DynFlags
import Name
import Module
import CoreUtils
import PrelNames
import SrcLoc

-- Used with Opt_DeferTypeErrors
-- See Note [Deferring coercion errors to runtime]
-- in TcSimplify
evDelayedError :: Type -> FastString -> EvTerm
evDelayedError :: Type -> FastString -> EvTerm
evDelayedError ty :: Type
ty msg :: FastString
msg
  = EvExpr -> EvTerm
EvExpr (EvExpr -> EvTerm) -> EvExpr -> EvTerm
forall a b. (a -> b) -> a -> b
$
    Id -> EvExpr
forall b. Id -> Expr b
Var Id
errorId EvExpr -> [Type] -> EvExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` [HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty, Type
ty] EvExpr -> [EvExpr] -> EvExpr
forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [EvExpr
forall b. Expr b
litMsg]
  where
    errorId :: Id
errorId = Id
tYPE_ERROR_ID
    litMsg :: Expr b
litMsg  = Literal -> Expr b
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString (FastString -> ByteString
fastStringToByteString FastString
msg))

-- Dictionary for CallStack implicit parameters
evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
    EvCallStack -> m EvExpr
-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
evCallStack :: EvCallStack -> m EvExpr
evCallStack cs :: EvCallStack
cs = do
  DynFlags
df            <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Module
m             <- m Module
forall (m :: * -> *). HasModule m => m Module
getModule
  DataCon
srcLocDataCon <- Name -> m DataCon
forall (m :: * -> *). MonadThings m => Name -> m DataCon
lookupDataCon Name
srcLocDataConName
  let mkSrcLoc :: RealSrcSpan -> f EvExpr
mkSrcLoc l :: RealSrcSpan
l = DataCon -> [EvExpr] -> EvExpr
mkCoreConApps DataCon
srcLocDataCon ([EvExpr] -> EvExpr) -> f [EvExpr] -> f EvExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               [f EvExpr] -> f [EvExpr]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ FastString -> f EvExpr
forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
mkStringExprFS (UnitId -> FastString
unitIdFS (UnitId -> FastString) -> UnitId -> FastString
forall a b. (a -> b) -> a -> b
$ Module -> UnitId
moduleUnitId Module
m)
                        , FastString -> f 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
moduleName Module
m)
                        , FastString -> f EvExpr
forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
mkStringExprFS (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
l)
                        , EvExpr -> f EvExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (EvExpr -> f EvExpr) -> EvExpr -> f EvExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> EvExpr
mkIntExprInt DynFlags
df (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
l)
                        , EvExpr -> f EvExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (EvExpr -> f EvExpr) -> EvExpr -> f EvExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> EvExpr
mkIntExprInt DynFlags
df (RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
l)
                        , EvExpr -> f EvExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (EvExpr -> f EvExpr) -> EvExpr -> f EvExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> EvExpr
mkIntExprInt DynFlags
df (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
l)
                        , EvExpr -> f EvExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (EvExpr -> f EvExpr) -> EvExpr -> f EvExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> EvExpr
mkIntExprInt DynFlags
df (RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
l)
                        ]

  EvExpr
emptyCS <- 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

  Id
pushCSVar <- Name -> m Id
forall (m :: * -> *). MonadThings m => Name -> m Id
lookupId Name
pushCallStackName
  let pushCS :: EvExpr -> EvExpr -> EvExpr -> EvExpr
pushCS name :: EvExpr
name loc :: EvExpr
loc rest :: 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 -> RealSrcSpan -> EvExpr -> m EvExpr
mkPush name :: FastString
name loc :: RealSrcSpan
loc tm :: EvExpr
tm = do
        EvExpr
nameExpr <- FastString -> m EvExpr
forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
mkStringExprFS FastString
name
        EvExpr
locExpr <- RealSrcSpan -> m EvExpr
forall (f :: * -> *). MonadThings f => RealSrcSpan -> f EvExpr
mkSrcLoc RealSrcSpan
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 :: CoercionR
ip_co = Type -> CoercionR
unwrapIP (EvExpr -> Type
exprType EvExpr
tm)
        EvExpr -> m EvExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (EvExpr -> EvExpr -> EvExpr -> EvExpr
pushCS EvExpr
nameExpr EvExpr
locExpr (EvExpr -> CoercionR -> EvExpr
forall b. Expr b -> CoercionR -> Expr b
Cast EvExpr
tm CoercionR
ip_co))

  case EvCallStack
cs of
    EvCsPushCall name :: Name
name loc :: RealSrcSpan
loc tm :: EvExpr
tm -> FastString -> RealSrcSpan -> EvExpr -> m EvExpr
forall (m :: * -> *).
MonadThings m =>
FastString -> RealSrcSpan -> EvExpr -> m EvExpr
mkPush (OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name) RealSrcSpan
loc EvExpr
tm
    EvCsEmpty -> EvExpr -> m EvExpr
forall (m :: * -> *) a. Monad m => a -> m a
return EvExpr
emptyCS