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

import Data.IORef
import Control.Monad.Reader
import Control.Monad.IO.Class
import qualified Data.List as L

import GHC
import GHC.Types.Id
import GHC.Types.FieldLabel
import GHC.Tc.Utils.TcType
import GHC.Runtime.Eval
import GHC.Types.Unique.Supply (uniqFromTag)
import GHC.Types.Name.Env

import GHC.Debugger.Runtime.Term.Key
import GHC.Debugger.Runtime.Term.Cache
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
  tc_ref <- (DebuggerState -> IORef TermCache) -> Debugger (IORef TermCache)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState -> IORef TermCache
termCache
  tc     <- liftIO $ readIORef tc_ref
  case lookupTermCache key tc of
    -- cache miss: reconstruct, then store.
    Maybe Term
Nothing ->
      let
        -- For boring types we want to get the value as it is (by traversing it to
        -- the end), rather than stopping short and returning a suspension (e.g.
        -- for the string tail), because boring types are printed whole rather than
        -- being represented by an expandable structure.
        depth :: Id -> Int
depth Id
i = if Type -> Bool
isBoringTy (Id -> Type
GHC.idType Id
i) then Int
forall a. Bounded a => a
maxBound else Int
defaultDepth

        -- Recursively get terms until we hit the desired key.
        getTerm :: TermKey -> Debugger Term
getTerm = \case
          FromId Id
i -> Int -> Bool -> Id -> Debugger Term
forall (m :: * -> *). GhcMonad m => Int -> Bool -> Id -> m Term
GHC.obtainTermFromId (Id -> Int
depth Id
i) Bool
False{-don't force-} Id
i
          FromPath TermKey
k PathFragment
pf -> do
            term <- TermKey -> Debugger Term
getTerm TermKey
k Debugger Term -> (Term -> Debugger Term) -> Debugger 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
              -- When the key points to a Suspension, the real thing should
              -- already be forced. It's just that the shallow depth meant we
              -- returned a Suspension nonetheless while recursing in `getTerm`.
              t :: Term
t@Suspension{} -> do
                t' <- Term -> Debugger Term
seqTerm Term
t
                -- update term cache with intermediate values?
                -- insertTermCache k t'
                return t'
              Term
t -> Term -> Debugger Term
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
            return $ case term of
              Term{dc :: Term -> Either String DataCon
dc=Right DataCon
dc, [Term]
subTerms :: [Term]
subTerms :: Term -> [Term]
subTerms} -> case PathFragment
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 Name
fl    ->
                  case (Name -> Bool) -> [Name] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
fl) ((FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector ([FieldLabel] -> [Name]) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> a -> b
$ DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc) of
                    Just Int
ix -> [Term]
subTerms [Term] -> Int -> Term
forall a. HasCallStack => [a] -> Int -> a
!! Int
ix
                    Maybe Int
Nothing -> String -> Term
forall a. HasCallStack => String -> a
error String
"Couldn't find labeled field in dataConFieldLabels"
              NewtypeWrap{Term
wrapped_term :: Term
wrapped_term :: 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"
       in do
        term <- TermKey -> Debugger Term
getTerm TermKey
key
        liftIO $ writeIORef tc_ref (insertTermCache key term tc)
        return term

    -- cache hit
    Just Term
hit -> Term -> Debugger Term
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
hit

-- | A boring type is one for which we don't care about the structure and would
-- rather see "whole" when being inspected. Strings and literals are a good
-- example, because it's more useful to see the string value than it is to see
-- a linked list of characters where each has to be forced individually.
isBoringTy :: Type -> Bool
isBoringTy :: Type -> Bool
isBoringTy Type
t = Type -> Bool
isDoubleTy Type
t Bool -> Bool -> Bool
|| Type -> Bool
isFloatTy Type
t Bool -> Bool -> Bool
|| Type -> Bool
isIntTy Type
t Bool -> Bool -> Bool
|| Type -> Bool
isWordTy Type
t Bool -> Bool -> Bool
|| Type -> Bool
isStringTy Type
t
                Bool -> Bool -> Bool
|| Type -> Bool
isIntegerTy Type
t Bool -> Bool -> Bool
|| Type -> Bool
isNaturalTy Type
t Bool -> Bool -> Bool
|| Type -> Bool
isCharTy Type
t