-- (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
cs = do
  DynFlags
df            <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
df
  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 -> m EvExpr
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)
                        ]

  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 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 -> RealSrcSpan -> EvExpr -> m EvExpr
mkPush FastString
name RealSrcSpan
loc EvExpr
tm = do
        EvExpr
nameExpr <- FastString -> m EvExpr
forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
mkStringExprFS FastString
name
        EvExpr
locExpr <- RealSrcSpan -> m 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 (HasDebugCallStack => EvExpr -> Type
EvExpr -> Type
exprType EvExpr
tm)
        EvExpr -> m EvExpr
forall a. a -> m a
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 FastString
fs RealSrcSpan
loc EvExpr
tm -> FastString -> RealSrcSpan -> EvExpr -> m EvExpr
mkPush FastString
fs RealSrcSpan
loc EvExpr
tm
    EvCallStack
EvCsEmpty              -> EvExpr -> m EvExpr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return EvExpr
emptyCS