{-# LANGUAGE OrPatterns, GADTs, LambdaCase, NamedFieldPuns, TemplateHaskellQuotes #-}
module GHC.Debugger.Runtime where

import Control.Monad.Reader

import GHC
import GHC.Utils.Outputable
import GHC.Runtime.Eval
import GHC.Runtime.Heap.Inspect

import GHC.Debugger.Runtime.Term.Key
import GHC.Debugger.Monad

-- | Obtain the runtime 'Term' from a 'TermKey'.
--
-- The 'TermKey' will be looked up in the 'TermCache' to avoid recomputing the
-- 'Term' if possible. On a cache miss the Term will be reconstructed from
-- scratch and stored in the cache.
obtainTerm :: TermKey -> Debugger Term
obtainTerm :: TermKey -> Debugger Term
obtainTerm TermKey
key = do
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
   -- Recursively get terms until we hit the desired key.
  case key of
     FromId Id
i -> Int -> Bool -> Id -> Debugger Term
forall (m :: * -> *). GhcMonad m => Int -> Bool -> Id -> m Term
GHC.obtainTermFromId Int
defaultDepth Bool
False{-don't force-} Id
i
     FromPath TermKey
k PathFragment 'False
pf -> do
       term <- TermKey -> Debugger Term
obtainTerm TermKey
k
       liftIO $ expandTerm hsc_env $ case term of
         Term{dc :: Term -> Either String DataCon
dc=Right DataCon
_, [Term]
subTerms :: [Term]
subTerms :: Term -> [Term]
subTerms} -> case PathFragment 'False
pf of
           PositionalIndex Int
ix -> [Term]
subTerms [Term] -> Int -> Term
forall a. HasCallStack => [a] -> Int -> a
!! (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
           LabeledField Int
n Name
_ -> [Term]
subTerms [Term] -> Int -> Term
forall a. HasCallStack => [a] -> Int -> a
!! (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
         NewtypeWrap{Term
wrapped_term :: Term
wrapped_term :: Term -> Term
wrapped_term} ->
           Term
wrapped_term -- regardless of PathFragment
         RefWrap{Term
wrapped_term :: Term -> Term
wrapped_term :: Term
wrapped_term} ->
           Term
wrapped_term -- regardless of PathFragment
         Term
_ -> String -> Term
forall a. HasCallStack => String -> a
error (String
"Unexpected term for the given TermKey because <term> should have been expanded before and we're getting a path fragment!\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SDoc -> String
forall a. Outputable a => a -> String
showPprUnsafe (TermKey -> SDoc
forall a. Outputable a => a -> SDoc
ppr TermKey
key SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TermKey -> SDoc
forall a. Outputable a => a -> SDoc
ppr TermKey
k SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PathFragment 'False -> SDoc
forall a. Outputable a => a -> SDoc
ppr PathFragment 'False
pf))
     FromCustomTerm TermKey
_key String
_name Term
ctm -> do
       -- For custom terms return them straightaway.
       IO Term -> Debugger Term
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Term -> Debugger Term) -> IO Term -> Debugger Term
forall a b. (a -> b) -> a -> b
$ HscEnv -> Term -> IO Term
expandTerm HscEnv
hsc_env Term
ctm


-- | Before returning a 'Term' we want to expand its heap representation up to the 'defaultDepth'
--
-- For 'Id's, this is done by 'GHC.obtainTermFromId'. For other 'TermKey's this
-- function should be used
expandTerm :: HscEnv -> Term -> IO Term
expandTerm :: HscEnv -> Term -> IO Term
expandTerm HscEnv
hsc_env Term
term = case Term
term of
  Term{ForeignHValue
val :: ForeignHValue
val :: Term -> ForeignHValue
val, RttiType
ty :: RttiType
ty :: Term -> RttiType
ty} -> HscEnv -> Int -> Bool -> RttiType -> ForeignHValue -> IO Term
cvObtainTerm HscEnv
hsc_env Int
defaultDepth Bool
False RttiType
ty ForeignHValue
val
  RefWrap{Term
wrapped_term :: Term -> Term
wrapped_term :: Term
wrapped_term} -> do
    wt' <- HscEnv -> Term -> IO Term
expandTerm HscEnv
hsc_env Term
wrapped_term
    return term{wrapped_term=wt'}
  NewtypeWrap{Term
wrapped_term :: Term -> Term
wrapped_term :: Term
wrapped_term} -> do
    wt' <- HscEnv -> Term -> IO Term
expandTerm HscEnv
hsc_env Term
wrapped_term
    return term{wrapped_term=wt'}
  Suspension{ForeignHValue
val :: Term -> ForeignHValue
val :: ForeignHValue
val, RttiType
ty :: Term -> RttiType
ty :: RttiType
ty} -> HscEnv -> Int -> Bool -> RttiType -> ForeignHValue -> IO Term
cvObtainTerm HscEnv
hsc_env Int
defaultDepth Bool
False RttiType
ty ForeignHValue
val
  Prim{} -> Term -> IO Term
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
term