module GHC.Debugger.Runtime.Instances.Discover
  (
  -- * Runtime 'DebugView' instance
    DebugViewInstance(..)

  -- * Cache for runtime instances
  , RuntimeInstancesCache
  , getDebugViewInstance
  , emptyRuntimeInstancesCache

  -- * Finding runtime instances utils
  , compileAndLoadMthd
  ) where

import Data.IORef
import Data.Function ((&))
import Control.Exception
import Control.Monad.Reader

import GHC
#if MIN_VERSION_ghc(10,1,0)
import GHC.Builtin.KnownKeys (ioTyConKey)
#else
import GHC.Builtin.Names
#endif
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Map.Type
import GHC.Driver.Config
import GHC.Driver.Env
import GHC.Driver.Main
import GHC.HsToCore.Expr
import GHC.HsToCore.Monad
import GHC.Plugins
import GHC.Rename.Env
import GHC.Rename.Expr
import GHC.Runtime.Interpreter as Interp
import GHC.Tc.Gen.Expr
import GHC.Tc.Solver
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Tc.Zonk.Type
import GHCi.Message

import GHC.Debugger.Monad
import GHC.Debugger.Session.Builtin
import Colog.Core as Logger

--------------------------------------------------------------------------------
-- * The Cache-level interface for runtime 'DebugView' instances
--------------------------------------------------------------------------------

-- | Cache 'DebugView' instances found at runtime to avoid trying to find them again.
-- If we found that a particular type doesn't have an instance, we record that as well.
type RuntimeInstancesCache = TypeMap (Maybe DebugViewInstance)

-- | Get a 'DebugViewInstance' for the given type, if one exists.
-- Looks up in the cache and otherwise tries to find the instance.
-- Returns @Nothing@ if no instance could be found.
getDebugViewInstance :: Type -> Debugger (Maybe DebugViewInstance)
getDebugViewInstance :: Type -> Debugger (Maybe DebugViewInstance)
getDebugViewInstance Type
ty = do
  rtinMapRef <- (DebuggerState -> IORef RuntimeInstancesCache)
-> Debugger (IORef RuntimeInstancesCache)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState -> IORef RuntimeInstancesCache
rtinstancesCache
  rtinMap    <- readIORef rtinMapRef & liftIO
  case lookupTypeMap rtinMap ty of
    Maybe (Maybe DebugViewInstance)
Nothing -> do
      res <- Type -> Debugger (Maybe DebugViewInstance)
findDebugViewInstance Type
ty
      writeIORef rtinMapRef
        (extendTypeMap rtinMap ty res) & liftIO
      return res
    Just Maybe DebugViewInstance
res ->
      Maybe DebugViewInstance -> Debugger (Maybe DebugViewInstance)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DebugViewInstance
res

-- | An empty 'RuntimeInstancesCache'
emptyRuntimeInstancesCache :: RuntimeInstancesCache
emptyRuntimeInstancesCache :: RuntimeInstancesCache
emptyRuntimeInstancesCache = RuntimeInstancesCache
forall a. TypeMap a
emptyTypeMap

--------------------------------------------------------------------------------
-- * Medium level interface for 'DebugView' on 'ForeignHValue's
-- This is cached by GHC.Debugger.Runtime.Instances.Cache
--------------------------------------------------------------------------------

-- | A 'DebugView' instance wrapper to call on values on the (potentially
-- foreign) interpreter heap
data DebugViewInstance = DebugViewInstance
  { -- | 'debugValueIOWrapper' for a specific instance
    DebugViewInstance
-> ForeignHValue -> IO (Either SomeException ForeignHValue)
instDebugValue  :: ForeignHValue -> IO (Either SomeException ForeignHValue)

    -- | 'debugFieldsIOWrapper' for a specific instance
  , DebugViewInstance
-> ForeignHValue -> IO (Either SomeException ForeignHValue)
instDebugFields :: ForeignHValue -> IO (Either SomeException ForeignHValue)

    -- | 'VarValueIO' type
    -- todo: pointless to compute this every time... (both of them)
  , DebugViewInstance -> Type
varValueIOTy  :: Type
    -- | 'VarFieldsIO' type
  , DebugViewInstance -> Type
varFieldsIOTy :: Type
  }

--------------------------------------------------------------------------------
-- * Impl. to find instance and load instance methods applied to right dictionary
--------------------------------------------------------------------------------

-- | Try to find the 'DebugView' instance for a given type using the
-- @haskell-debugger-view@ unit found at session set-up time (see
-- @'hsDbgViewUnitId'@)
findDebugViewInstance :: Type -> Debugger (Maybe DebugViewInstance)
findDebugViewInstance :: Type -> Debugger (Maybe DebugViewInstance)
findDebugViewInstance Type
needle_ty = do
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

  mhdv_uid <- getHsDebuggerViewUid
  case mhdv_uid of
    Just UnitId
hdv_uid -> do
      let modl :: GenModule (GenUnit UnitId)
modl = GenUnit UnitId -> ModuleName -> GenModule (GenUnit UnitId)
forall u. u -> ModuleName -> GenModule u
mkModule (Definite UnitId -> GenUnit UnitId
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
hdv_uid)) ModuleName
debuggerViewClassModName
      let mthdRdrName :: String -> RdrName
mthdRdrName String
mthStr = GenModule (GenUnit UnitId) -> OccName -> RdrName
mkOrig GenModule (GenUnit UnitId)
modl (String -> OccName
mkVarOcc String
mthStr) :: RdrName

      (err_msgs, res) <- IO (Messages TcRnMessage, Maybe DebugViewInstance)
-> Debugger (Messages TcRnMessage, Maybe DebugViewInstance)
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages TcRnMessage, Maybe DebugViewInstance)
 -> Debugger (Messages TcRnMessage, Maybe DebugViewInstance))
-> IO (Messages TcRnMessage, Maybe DebugViewInstance)
-> Debugger (Messages TcRnMessage, Maybe DebugViewInstance)
forall a b. (a -> b) -> a -> b
$
        HscEnv
-> TcRn DebugViewInstance
-> IO (Messages TcRnMessage, Maybe DebugViewInstance)
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive
#if MIN_VERSION_ghc(10,1,0)
          StartAndStopTcMPlugins
#endif
          HscEnv
hsc_env (TcRn DebugViewInstance
 -> IO (Messages TcRnMessage, Maybe DebugViewInstance))
-> TcRn DebugViewInstance
-> IO (Messages TcRnMessage, Maybe DebugViewInstance)
forall a b. (a -> b) -> a -> b
$ do

        -- Types used by DebugView.
#if MIN_VERSION_ghc(10,1,0)
        let lookupTyConName occ = greName <$> lookupTypeOccRn occ
#else
        let lookupTyConName :: RdrName -> RnM Name
lookupTyConName RdrName
occ = RdrName -> RnM Name
lookupTypeOccRn RdrName
occ
#endif
        varValueIOTy    <-  (TyCon -> Type)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
-> IOEnv (Env TcGblEnv TcLclEnv) Type
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyCon -> Type
mkTyConTy (IOEnv (Env TcGblEnv TcLclEnv) TyCon
 -> IOEnv (Env TcGblEnv TcLclEnv) Type)
-> (Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon
                        (Name -> IOEnv (Env TcGblEnv TcLclEnv) Type)
-> RnM Name -> IOEnv (Env TcGblEnv TcLclEnv) Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RdrName -> RnM Name
lookupTyConName (GenModule (GenUnit UnitId) -> OccName -> RdrName
mkOrig GenModule (GenUnit UnitId)
modl (String -> OccName
mkTcOcc String
"VarValueIO"))
        varFieldsIOTy   <-  fmap mkTyConTy . tcLookupTyCon
                        =<< lookupTyConName (mkOrig modl (mkTcOcc "VarFieldsIO"))

#if MIN_VERSION_ghc(10,1,0)
        ioTyCon <- tcLookupKnownKeyTyCon ioTyConKey
#else
        ioTyCon <- tcLookupTyCon ioTyConName
#endif

        -- Try to compile and load an expression for all methods of `DebugView`
        -- applied to the dictionary for the given Type (`needle_ty`)
        let debugValueME  = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ String -> RdrName
mthdRdrName String
"debugValueIOWrapper"
            debugFieldsME = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ String -> RdrName
mthdRdrName String
"debugFieldsIOWrapper"
            debugValueWrapperMT =
              HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
needle_ty (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                TyCon -> [Type] -> Type
mkTyConApp TyCon
ioTyCon [Type -> Type
mkListTy Type
varValueIOTy]
            debugFieldsWrapperMT =
              HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
needle_ty (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                TyCon -> [Type] -> Type
mkTyConApp TyCon
ioTyCon [Type -> Type
mkListTy Type
varFieldsIOTy]
        !debugValue_fval  <- compileAndLoadMthd debugValueME  debugValueWrapperMT
        !debugFields_fval <- compileAndLoadMthd debugFieldsME debugFieldsWrapperMT

        let eval_opts = DynFlags -> EvalStep -> EvalOpts
initEvalOpts (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) EvalStep
EvalStepNone
            interp    = HscEnv -> Interp
hscInterp HscEnv
hsc_env

            -- If we hit a breakpoint while evaluating this, just keep going.
            handleStatus (EvalBreak HValueRef
_ Maybe EvalBreakpoint
_ RemoteRef (ResumeContext [HValueRef])
resume_ctxt RemotePtr CostCentreStack
_) = do
              resume_ctxt_fhv <- Interp
-> RemoteRef (ResumeContext [HValueRef])
-> IO (ForeignRef (ResumeContext [HValueRef]))
forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp RemoteRef (ResumeContext [HValueRef])
resume_ctxt
              handleStatus =<< Interp.resumeStmt interp eval_opts resume_ctxt_fhv
            -- When completed, return value
            handleStatus (EvalComplete Word64
_ (EvalException SerializableException
e)) =
              Either SomeException ForeignHValue
-> IO (Either SomeException ForeignHValue)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> Either SomeException ForeignHValue
forall a b. a -> Either a b
Left (SerializableException -> SomeException
fromSerializableException SerializableException
e))
            handleStatus (EvalComplete Word64
_ (EvalSuccess [ForeignHValue
hval])) =
              Either SomeException ForeignHValue
-> IO (Either SomeException ForeignHValue)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignHValue -> Either SomeException ForeignHValue
forall a b. b -> Either a b
Right ForeignHValue
hval)
            handleStatus (EvalComplete Word64
_ (EvalSuccess [ForeignHValue]
_)) =
              Either SomeException ForeignHValue
-> IO (Either SomeException ForeignHValue)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> Either SomeException ForeignHValue
forall a b. a -> Either a b
Left (IOError -> SomeException
forall e. (Exception e, HasExceptionContext) => e -> SomeException
SomeException (String -> IOError
userError String
"unexpected more than one value bound for evaluation of DebugView method")))

        return DebugViewInstance
          { instDebugValue = \ForeignHValue
x_fval -> do
              HasExceptionContext =>
EvalStatus_ [ForeignHValue] [HValueRef]
-> IO (Either SomeException ForeignHValue)
EvalStatus_ [ForeignHValue] [HValueRef]
-> IO (Either SomeException ForeignHValue)
handleStatus (EvalStatus_ [ForeignHValue] [HValueRef]
 -> IO (Either SomeException ForeignHValue))
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> IO (Either SomeException ForeignHValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Interp
-> EvalOpts
-> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt Interp
interp EvalOpts
eval_opts
                (ForeignHValue -> EvalExpr ForeignHValue
forall a. a -> EvalExpr a
EvalThis ForeignHValue
debugValue_fval EvalExpr ForeignHValue
-> EvalExpr ForeignHValue -> EvalExpr ForeignHValue
forall a. EvalExpr a -> EvalExpr a -> EvalExpr a
`EvalApp` ForeignHValue -> EvalExpr ForeignHValue
forall a. a -> EvalExpr a
EvalThis ForeignHValue
x_fval)
          , instDebugFields = \ForeignHValue
x_fval -> do
              HasExceptionContext =>
EvalStatus_ [ForeignHValue] [HValueRef]
-> IO (Either SomeException ForeignHValue)
EvalStatus_ [ForeignHValue] [HValueRef]
-> IO (Either SomeException ForeignHValue)
handleStatus (EvalStatus_ [ForeignHValue] [HValueRef]
 -> IO (Either SomeException ForeignHValue))
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
-> IO (Either SomeException ForeignHValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Interp
-> EvalOpts
-> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt Interp
interp EvalOpts
eval_opts
                (ForeignHValue -> EvalExpr ForeignHValue
forall a. a -> EvalExpr a
EvalThis ForeignHValue
debugFields_fval EvalExpr ForeignHValue
-> EvalExpr ForeignHValue -> EvalExpr ForeignHValue
forall a. EvalExpr a -> EvalExpr a -> EvalExpr a
`EvalApp` ForeignHValue -> EvalExpr ForeignHValue
forall a. a -> EvalExpr a
EvalThis ForeignHValue
x_fval)
          , varValueIOTy
          , varFieldsIOTy
          }

      case res of
        Maybe DebugViewInstance
Nothing -> do
          Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Debug (SDoc -> Debugger ()) -> SDoc -> Debugger ()
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Couldn't compile DebugView instance for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
needle_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Messages TcRnMessage -> SDoc
forall a. Outputable a => a -> SDoc
ppr Messages TcRnMessage
err_msgs
          -- The error is for debug purposes. We simply won't use a custom instance:
          Maybe DebugViewInstance -> Debugger (Maybe DebugViewInstance)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DebugViewInstance
forall a. Maybe a
Nothing
        Just DebugViewInstance
is ->
          Maybe DebugViewInstance -> Debugger (Maybe DebugViewInstance)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DebugViewInstance -> Debugger (Maybe DebugViewInstance))
-> Maybe DebugViewInstance -> Debugger (Maybe DebugViewInstance)
forall a b. (a -> b) -> a -> b
$ DebugViewInstance -> Maybe DebugViewInstance
forall a. a -> Maybe a
Just DebugViewInstance
is
    Maybe UnitId
Nothing ->
      -- Custom view is disabled
      Maybe DebugViewInstance -> Debugger (Maybe DebugViewInstance)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DebugViewInstance
forall a. Maybe a
Nothing

-- | Try to compile and load a class method for the given type.
--
-- E.g. @compileAndLoadMthd (nlHsVar "foo") <ty>@ returns the
-- foreign value for an expression @foo@ applied to the dictionary required to
-- produce the final requested type
compileAndLoadMthd :: LHsExpr GhcPs -- ^ Expr of method/expr that takes dictionary
                   -> Type         -- ^ The final type of expr when funct is alredy applied to dict
                   -> TcM ForeignHValue
compileAndLoadMthd :: LHsExpr (GhcPass 'Parsed) -> Type -> TcM ForeignHValue
compileAndLoadMthd LHsExpr (GhcPass 'Parsed)
expr Type
mthTy = do
  hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv

  -- Rn, Tc, desugar applied to dictionary
  (expr', _)    <- rnExpr (unLoc expr)
  (expr'', wcs) <- captureConstraints $ tcExpr expr' (Check mthTy)
  ev            <- simplifyTop wcs
  failIfErrsM -- Before Zonking! If solving the constraint failed, `ev == []`.
  let final_exp = TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet (Bag EvBind -> TcEvBinds
EvBinds Bag EvBind
ev) (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsExpr GhcTc
expr'')
  tc_expr_final <- zonkTopLExpr final_exp
  (_, Just ds_expr) <- initDsTc $ dsLExpr tc_expr_final

  -- Compile to a BCO and load it
  (mthd_fval, _, _) <- liftIO $ hscCompileCoreExpr hsc_env noSrcSpan ds_expr

  return mthd_fval