{-# LANGUAGE TemplateHaskell, LambdaCase, BlockArguments, OrPatterns #-}
module GHC.Debugger.Runtime.Instances
  ( debugValueTerm
  , debugFieldsTerm
  , VarValueResult(..)
  ) where

import GHC
import GHC.Driver.Env
import GHC.Runtime.Eval
import GHC.Runtime.Heap.Inspect
import GHC.Runtime.Interpreter as Interp
import GHC.Utils.Outputable
import Control.Monad.Reader

import GHC.Debugger.Monad
import Colog.Core as Logger
import GHC.Debugger.Runtime.Instances.Discover
import GHC.Debugger.Runtime.Term.Parser

data VarValueResult = VarValueResult { VarValueResult -> String
varValueResult :: String, VarValueResult -> Bool
varValueResultExpandable :: Bool }

--------------------------------------------------------------------------------
-- * High level interface for 'DebugView' on 'Term's
--------------------------------------------------------------------------------

-- | Get the custom representation of this 'Term' by applying a 'DebugView'
-- instance 'debugValue' method if there is one.
debugValueTerm :: Term -> Debugger (Maybe VarValueResult)
debugValueTerm :: Term -> Debugger (Maybe VarValueResult)
debugValueTerm Term
term = do
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
  let ty = Term -> RttiType
termType Term
term
  mbInst <- getDebugViewInstance ty
  case (,) <$> maybe_hval term <*> mbInst of
    Maybe (ForeignHValue, DebugViewInstance)
Nothing -> Maybe VarValueResult -> Debugger (Maybe VarValueResult)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe VarValueResult
forall a. Maybe a
Nothing
    Just (ForeignHValue
hval, DebugViewInstance
      {ForeignHValue -> IO (Either SomeException ForeignHValue)
instDebugValue :: ForeignHValue -> IO (Either SomeException ForeignHValue)
instDebugValue :: DebugViewInstance
-> ForeignHValue -> IO (Either SomeException ForeignHValue)
instDebugValue, RttiType
varValueIOTy :: RttiType
varValueIOTy :: DebugViewInstance -> RttiType
varValueIOTy}) -> do
        IO (Either SomeException ForeignHValue)
-> Debugger (Either SomeException ForeignHValue)
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ForeignHValue -> IO (Either SomeException ForeignHValue)
instDebugValue ForeignHValue
hval) Debugger (Either SomeException ForeignHValue)
-> (Either SomeException ForeignHValue
    -> Debugger (Maybe VarValueResult))
-> Debugger (Maybe VarValueResult)
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left SomeException
_e ->
            -- exception! ignore.
            Maybe VarValueResult -> Debugger (Maybe VarValueResult)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe VarValueResult
forall a. Maybe a
Nothing
          Right ForeignHValue
transformed_v -> do

            String
-> Int
-> Bool
-> RttiType
-> ForeignHValue
-> TermParser (Term, Bool)
-> Debugger (Either [TermParseError] (Term, Bool))
forall a.
String
-> Int
-> Bool
-> RttiType
-> ForeignHValue
-> TermParser a
-> Debugger (Either [TermParseError] a)
obtainParsedTerm String
"VarValue" Int
forall a. Bounded a => a
maxBound Bool
True RttiType
varValueIOTy ForeignHValue
transformed_v TermParser (Term, Bool)
varValueParser Debugger (Either [TermParseError] (Term, Bool))
-> (Either [TermParseError] (Term, Bool)
    -> Debugger (Maybe VarValueResult))
-> Debugger (Maybe VarValueResult)
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Left [TermParseError]
_ ->
                Maybe VarValueResult -> Debugger (Maybe VarValueResult)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe VarValueResult
forall a. Maybe a
Nothing
              Right (Term
strTerm, Bool
valBool) -> do
                case Term
strTerm of
                  (Suspension{} ; Term{}) -> do
                    valStr <- IO String -> Debugger String
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> Debugger String) -> IO String -> Debugger String
forall a b. (a -> b) -> a -> b
$
                      Interp -> ForeignHValue -> IO String
evalString Interp
interp (Term -> ForeignHValue
val Term
strTerm {- whose type is IO String, from varValueIO -})

                    return $ Just VarValueResult
                      { varValueResult = valStr
                      , varValueResultExpandable = valBool
                      }
                  Term
_ -> do
                    Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Warning (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"debugValueTerm(2): Expecting" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Term -> SDoc
forall a. Outputable a => a -> SDoc
ppr Term
strTerm SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"to be a Term or Suspension.")
                    Maybe VarValueResult -> Debugger (Maybe VarValueResult)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe VarValueResult
forall a. Maybe a
Nothing


-- | Get the custom representation of this 'Term' by applying a 'DebugView'
-- instance 'debugFields' method if there is one.
--
-- Returns the mappings from field labels to terms, where each term records the
-- type and pointer to the foreign heap value returned in the instance for that label.
--
-- Returns @Nothing@ if no instance was found for the type of the given term
debugFieldsTerm :: Term -> Debugger (Maybe [(String, Term)])
debugFieldsTerm :: Term -> Debugger (Maybe [(String, Term)])
debugFieldsTerm Term
term = do
  let ty :: RttiType
ty = Term -> RttiType
termType Term
term
  mbInst <- RttiType -> Debugger (Maybe DebugViewInstance)
getDebugViewInstance RttiType
ty
  case (,) <$> maybe_hval term <*> mbInst of
    Maybe (ForeignHValue, DebugViewInstance)
Nothing -> Maybe [(String, Term)] -> Debugger (Maybe [(String, Term)])
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(String, Term)]
forall a. Maybe a
Nothing
    Just (ForeignHValue
hval, DebugViewInstance
      {ForeignHValue -> IO (Either SomeException ForeignHValue)
instDebugFields :: ForeignHValue -> IO (Either SomeException ForeignHValue)
instDebugFields :: DebugViewInstance
-> ForeignHValue -> IO (Either SomeException ForeignHValue)
instDebugFields, RttiType
varFieldsIOTy :: RttiType
varFieldsIOTy :: DebugViewInstance -> RttiType
varFieldsIOTy}) -> do
        IO (Either SomeException ForeignHValue)
-> Debugger (Either SomeException ForeignHValue)
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ForeignHValue -> IO (Either SomeException ForeignHValue)
instDebugFields ForeignHValue
hval) Debugger (Either SomeException ForeignHValue)
-> (Either SomeException ForeignHValue
    -> Debugger (Maybe [(String, Term)]))
-> Debugger (Maybe [(String, Term)])
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left SomeException
_e ->
            -- exception! ignore.
            Maybe [(String, Term)] -> Debugger (Maybe [(String, Term)])
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(String, Term)]
forall a. Maybe a
Nothing
          Right ForeignHValue
transformed_v -> do

            String
-> Int
-> Bool
-> RttiType
-> ForeignHValue
-> TermParser [(String, Term)]
-> Debugger (Either [TermParseError] [(String, Term)])
forall a.
String
-> Int
-> Bool
-> RttiType
-> ForeignHValue
-> TermParser a
-> Debugger (Either [TermParseError] a)
obtainParsedTerm String
"VarFields" Int
2 Bool
True RttiType
varFieldsIOTy ForeignHValue
transformed_v TermParser [(String, Term)]
varFieldsParser Debugger (Either [TermParseError] [(String, Term)])
-> (Either [TermParseError] [(String, Term)]
    -> Debugger (Maybe [(String, Term)]))
-> Debugger (Maybe [(String, Term)])
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Left [TermParseError]
_ -> Maybe [(String, Term)] -> Debugger (Maybe [(String, Term)])
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(String, Term)]
forall a. Maybe a
Nothing
              Right [(String, Term)]
res -> Maybe [(String, Term)] -> Debugger (Maybe [(String, Term)])
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(String, Term)] -> Maybe [(String, Term)]
forall a. a -> Maybe a
Just [(String, Term)]
res)

-- | The heap value of the Term the debugView instance methods are applied to
-- (looks through newtypes). For Primitive types and primitive References,
-- assume dbgInst methods can't be applied to them.
maybe_hval :: Term -> Maybe ForeignHValue
maybe_hval :: Term -> Maybe ForeignHValue
maybe_hval Term
t = case Term
t of
  Suspension{ForeignHValue
val :: Term -> ForeignHValue
val :: ForeignHValue
val} -> ForeignHValue -> Maybe ForeignHValue
forall a. a -> Maybe a
Just ForeignHValue
val
  Term{ForeignHValue
val :: Term -> ForeignHValue
val :: ForeignHValue
val}       -> ForeignHValue -> Maybe ForeignHValue
forall a. a -> Maybe a
Just ForeignHValue
val
  NewtypeWrap{Term
wrapped_term :: Term
wrapped_term :: Term -> Term
wrapped_term}
                  -> Term -> Maybe ForeignHValue
maybe_hval Term
wrapped_term
  Prim{}          -> Maybe ForeignHValue
forall a. Maybe a
Nothing
  RefWrap{}       -> Maybe ForeignHValue
forall a. Maybe a
Nothing