{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,
   DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,
   TypeApplications, ScopedTypeVariables, BangPatterns #-}
module GHC.Debugger.Stopped.Variables where

import Data.IORef
import Control.Monad
import Control.Monad.Reader
import Control.Monad.IO.Class

import GHC
import GHC.Types.FieldLabel
import GHC.Runtime.Eval
import GHC.Core.DataCon
import GHC.Types.Id as GHC
import qualified GHC.Runtime.Debugger as GHCD
import qualified GHC.Runtime.Heap.Inspect as GHCI

import GHC.Debugger.Monad
import GHC.Debugger.Interface.Messages
import GHC.Debugger.Runtime
import GHC.Debugger.Runtime.Term.Key
import GHC.Debugger.Runtime.Term.Cache
import GHC.Debugger.Utils

-- | 'TyThing' to 'VarInfo'. The 'Bool' argument indicates whether to force the
-- value of the thing (as in @True = :force@, @False = :print@)
tyThingToVarInfo :: TyThing -> Debugger VarInfo
tyThingToVarInfo :: TyThing -> Debugger VarInfo
tyThingToVarInfo = \case
  t :: TyThing
t@(AConLike ConLike
c) -> String -> String -> String -> Bool -> VariableReference -> VarInfo
VarInfo (String
 -> String -> String -> Bool -> VariableReference -> VarInfo)
-> Debugger String
-> Debugger
     (String -> String -> Bool -> VariableReference -> VarInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConLike -> Debugger String
forall a. Outputable a => a -> Debugger String
display ConLike
c Debugger (String -> String -> Bool -> VariableReference -> VarInfo)
-> Debugger String
-> Debugger (String -> Bool -> VariableReference -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyThing -> Debugger String
forall a. Outputable a => a -> Debugger String
display TyThing
t Debugger (String -> Bool -> VariableReference -> VarInfo)
-> Debugger String
-> Debugger (Bool -> VariableReference -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyThing -> Debugger String
forall a. Outputable a => a -> Debugger String
display TyThing
t Debugger (Bool -> VariableReference -> VarInfo)
-> Debugger Bool -> Debugger (VariableReference -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Debugger Bool
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False Debugger (VariableReference -> VarInfo)
-> Debugger VariableReference -> Debugger VarInfo
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VariableReference -> Debugger VariableReference
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VariableReference
NoVariables
  t :: TyThing
t@(ATyCon TyCon
c)   -> String -> String -> String -> Bool -> VariableReference -> VarInfo
VarInfo (String
 -> String -> String -> Bool -> VariableReference -> VarInfo)
-> Debugger String
-> Debugger
     (String -> String -> Bool -> VariableReference -> VarInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon -> Debugger String
forall a. Outputable a => a -> Debugger String
display TyCon
c Debugger (String -> String -> Bool -> VariableReference -> VarInfo)
-> Debugger String
-> Debugger (String -> Bool -> VariableReference -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyThing -> Debugger String
forall a. Outputable a => a -> Debugger String
display TyThing
t Debugger (String -> Bool -> VariableReference -> VarInfo)
-> Debugger String
-> Debugger (Bool -> VariableReference -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyThing -> Debugger String
forall a. Outputable a => a -> Debugger String
display TyThing
t Debugger (Bool -> VariableReference -> VarInfo)
-> Debugger Bool -> Debugger (VariableReference -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Debugger Bool
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False Debugger (VariableReference -> VarInfo)
-> Debugger VariableReference -> Debugger VarInfo
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VariableReference -> Debugger VariableReference
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VariableReference
NoVariables
  t :: TyThing
t@(ACoAxiom CoAxiom Branched
c) -> String -> String -> String -> Bool -> VariableReference -> VarInfo
VarInfo (String
 -> String -> String -> Bool -> VariableReference -> VarInfo)
-> Debugger String
-> Debugger
     (String -> String -> Bool -> VariableReference -> VarInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoAxiom Branched -> Debugger String
forall a. Outputable a => a -> Debugger String
display CoAxiom Branched
c Debugger (String -> String -> Bool -> VariableReference -> VarInfo)
-> Debugger String
-> Debugger (String -> Bool -> VariableReference -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyThing -> Debugger String
forall a. Outputable a => a -> Debugger String
display TyThing
t Debugger (String -> Bool -> VariableReference -> VarInfo)
-> Debugger String
-> Debugger (Bool -> VariableReference -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyThing -> Debugger String
forall a. Outputable a => a -> Debugger String
display TyThing
t Debugger (Bool -> VariableReference -> VarInfo)
-> Debugger Bool -> Debugger (VariableReference -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Debugger Bool
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False Debugger (VariableReference -> VarInfo)
-> Debugger VariableReference -> Debugger VarInfo
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VariableReference -> Debugger VariableReference
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VariableReference
NoVariables
  AnId Id
i -> do
    let key :: TermKey
key = Id -> TermKey
FromId Id
i
    term <- TermKey -> Debugger Term
obtainTerm TermKey
key
    termToVarInfo key term

-- | Construct the VarInfos of the fields ('VarFields') of the given 'TermKey'/'Term'
termVarFields :: TermKey -> Term -> Debugger VarFields
termVarFields :: TermKey -> Term -> Debugger VarFields
termVarFields TermKey
top_key Term
top_term =

  -- Make 'VarInfo's for the first layer of subTerms only.
  case Term
top_term of
      -- Boring types don't get subfields
      Term
_ | RttiType -> Bool
isBoringTy (Term -> RttiType
GHCI.termType Term
top_term) ->
        VarFields -> Debugger VarFields
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return VarFields
NoFields

      Term{dc :: Term -> Either String DataCon
dc=Right DataCon
dc, subTerms :: Term -> [Term]
subTerms=[Term]
_{- don't use directly! go through @obtainTerm@ -}} -> do
        case DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc of
          -- Not a record type,
          -- Use indexed fields
          [] -> do
            let keys :: [TermKey]
keys = (Int -> Scaled RttiType -> TermKey)
-> [Int] -> [Scaled RttiType] -> [TermKey]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
ix Scaled RttiType
_ -> TermKey -> PathFragment -> TermKey
FromPath TermKey
top_key (Int -> PathFragment
PositionalIndex Int
ix)) [Int
1..] (DataCon -> [Scaled RttiType]
dataConOrigArgTys DataCon
dc)
            [VarInfo] -> VarFields
IndexedFields ([VarInfo] -> VarFields)
-> Debugger [VarInfo] -> Debugger VarFields
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TermKey -> Debugger VarInfo) -> [TermKey] -> Debugger [VarInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\TermKey
k -> TermKey -> Debugger Term
obtainTerm TermKey
k Debugger Term -> (Term -> Debugger VarInfo) -> Debugger VarInfo
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermKey -> Term -> Debugger VarInfo
termToVarInfo TermKey
k) [TermKey]
keys
          -- Is a record data con,
          -- Use field labels
          [FieldLabel]
dataConFields -> do
            let keys :: [TermKey]
keys = (FieldLabel -> TermKey) -> [FieldLabel] -> [TermKey]
forall a b. (a -> b) -> [a] -> [b]
map (TermKey -> PathFragment -> TermKey
FromPath TermKey
top_key (PathFragment -> TermKey)
-> (FieldLabel -> PathFragment) -> FieldLabel -> TermKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> PathFragment
LabeledField (Name -> PathFragment)
-> (FieldLabel -> Name) -> FieldLabel -> PathFragment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> Name
flSelector) [FieldLabel]
dataConFields
            [VarInfo] -> VarFields
LabeledFields ([VarInfo] -> VarFields)
-> Debugger [VarInfo] -> Debugger VarFields
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TermKey -> Debugger VarInfo) -> [TermKey] -> Debugger [VarInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\TermKey
k -> TermKey -> Debugger Term
obtainTerm TermKey
k Debugger Term -> (Term -> Debugger VarInfo) -> Debugger VarInfo
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermKey -> Term -> Debugger VarInfo
termToVarInfo TermKey
k) [TermKey]
keys
      NewtypeWrap{dc :: Term -> Either String DataCon
dc=Right DataCon
dc, wrapped_term :: Term -> Term
wrapped_term=Term
_{- don't use directly! go through @obtainTerm@ -}} -> do
        case DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc of
          [] -> do
            let key :: TermKey
key = TermKey -> PathFragment -> TermKey
FromPath TermKey
top_key (Int -> PathFragment
PositionalIndex Int
1)
            wvi <- TermKey -> Debugger Term
obtainTerm TermKey
key Debugger Term -> (Term -> Debugger VarInfo) -> Debugger VarInfo
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermKey -> Term -> Debugger VarInfo
termToVarInfo TermKey
key
            return (IndexedFields [wvi])
          [FieldLabel
fld] -> do
            let key :: TermKey
key = TermKey -> PathFragment -> TermKey
FromPath TermKey
top_key (Name -> PathFragment
LabeledField (FieldLabel -> Name
flSelector FieldLabel
fld))
            wvi <- TermKey -> Debugger Term
obtainTerm TermKey
key Debugger Term -> (Term -> Debugger VarInfo) -> Debugger VarInfo
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermKey -> Term -> Debugger VarInfo
termToVarInfo TermKey
key
            return (LabeledFields [wvi])
          [FieldLabel]
_ -> String -> Debugger VarFields
forall a. HasCallStack => String -> a
error String
"unexpected number of Newtype fields: larger than 1"
      Term
_ -> VarFields -> Debugger VarFields
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return VarFields
NoFields


-- | Construct a 'VarInfo' from the given 'Name' of the variable and the 'Term' it binds
termToVarInfo :: TermKey -> Term -> Debugger VarInfo
termToVarInfo :: TermKey -> Term -> Debugger VarInfo
termToVarInfo TermKey
key Term
term0 = do
  -- Make a VarInfo for a term
  let
    isThunk :: Bool
isThunk
     | Suspension{} <- Term
term0 = Bool
True
     | Bool
otherwise = Bool
False
    ty :: RttiType
ty = Term -> RttiType
GHCI.termType Term
term0

  term <- if Bool -> Bool
not Bool
isThunk Bool -> Bool -> Bool
&& RttiType -> Bool
isBoringTy RttiType
ty
            then TermKey -> Term -> Debugger Term
forceTerm TermKey
key Term
term0 -- make sure that if it's an evaluated boring term then it is /fully/ evaluated.
            else Term -> Debugger Term
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
term0

  let
    -- We scrape the subterms to display as the var's value. The structure is
    -- displayed in the editor itself by expanding the variable sub-fields
    termHead Term
t
      -- But show strings and lits in full
      | RttiType -> Bool
isBoringTy RttiType
ty = Term
t
      | Bool
otherwise     = case Term
t of
         Term{}                    -> Term
t{subTerms = []}
         NewtypeWrap{Term
wrapped_term :: Term -> Term
wrapped_term :: Term
wrapped_term} -> Term
t{wrapped_term = termHead wrapped_term}
         Term
_                         -> Term
t
  varName <- display key
  varType <- display ty
  varValue <- display =<< GHCD.showTerm (termHead term)
  -- liftIO $ print (varName, varType, varValue, GHCI.isFullyEvaluatedTerm term)

  -- The VarReference allows user to expand variable structure and inspect its value.
  -- Here, we do not want to allow expanding a term that is fully evaluated.
  -- We only want to return @SpecificVariable@ (which allows expansion) for
  -- values with sub-fields or thunks.
  varRef <- do
    if GHCI.isFullyEvaluatedTerm term ||
       -- Even if it is already evaluated, we do want to display a
       -- structure as long if it is not a "boring type" (one that does not
       -- provide useful information from being expanded)
       -- (e.g. consider how awkward it is to expand Char# 10 and I# 20)
       (not isThunk && (isBoringTy ty || not (hasDirectSubTerms term)))
     then do
        return NoVariables
     else do
        ir <- getVarReference key
        return (SpecificVariable ir)

  return VarInfo{..}
  where
    hasDirectSubTerms :: Term -> Bool
hasDirectSubTerms = \case
      Suspension{}   -> Bool
False
      Prim{}         -> Bool
False
      NewtypeWrap{}  -> Bool
True
      RefWrap{}      -> Bool
True
      Term{[Term]
subTerms :: Term -> [Term]
subTerms :: [Term]
subTerms} -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Term] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Term]
subTerms

-- | Forces a term to WHNF in the general case, or to NF in the case of 'isBoringTy'.
-- The term is updated at the given key.
forceTerm :: TermKey -> Term -> Debugger Term
forceTerm :: TermKey -> Term -> Debugger Term
forceTerm TermKey
key Term
term = do
  let ty :: RttiType
ty = Term -> RttiType
GHCI.termType Term
term
  term' <- if RttiType -> Bool
isBoringTy RttiType
ty
              -- deepseq boring types like String, because it is more helpful
              -- to print them whole than their structure.
              then Term -> Debugger Term
deepseqTerm Term
term
              else Term -> Debugger Term
seqTerm Term
term
  -- update cache with the forced term right away instead of invalidating it.
  asks termCache >>= \IORef TermCache
r -> IO () -> Debugger ()
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Debugger ()) -> IO () -> Debugger ()
forall a b. (a -> b) -> a -> b
$ IORef TermCache -> (TermCache -> TermCache) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef TermCache
r (TermKey -> Term -> TermCache -> TermCache
insertTermCache TermKey
key Term
term')
  return term'