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

import Control.Monad

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.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
term = do
  -- Make a VarInfo for a term
  let
    isThunk :: Bool
isThunk
     | Suspension{} <- Term
term = Bool
True
     | Bool
otherwise = Bool
False
    ty :: RttiType
ty = Term -> RttiType
GHCI.termType Term
term

    -- 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 -> Term
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 <- TermKey -> Debugger String
forall a. Outputable a => a -> Debugger String
display TermKey
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)
       && (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