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

import Control.Monad.Reader
import qualified Colog.Core as Logger

import GHC
import GHC.Types.FieldLabel
import GHC.Types.Id.Info
import GHC.Types.Var
import GHC.Runtime.Eval
import GHC.Core.DataCon
import GHC.Core.FamInstEnv (topNormaliseType_maybe, emptyFamInstEnvs)
import GHC.Core.TyCo.Rep
import GHC.Core.Reduction (Reduction(..))
import GHC.Tc.Instance.Family (tcGetFamInstEnvs, FamInstEnvs)
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.Instances
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 :: FamInstEnvs -> TyThing -> Debugger VarInfo
tyThingToVarInfo :: FamInstEnvs -> TyThing -> Debugger VarInfo
tyThingToVarInfo FamInstEnvs
fam_envs TyThing
t = case TyThing
t of
  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 (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m 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 (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m 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 (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m 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
  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 (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m 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 (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m 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 (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m 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
  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 (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m 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 (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m 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 (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m 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
    | DataConWrapId DataCon
data_con <- HasCallStack => Id -> IdDetails
Id -> IdDetails
idDetails Id
i
    -- Newtype cons don't have a runtime representation, so we can't obtain
    -- terms! Simply print the newtype cons like we do data cons.
    -- See Note [Newtype workers]
    , TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
data_con)
    -> 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
<$> DataCon -> Debugger String
forall (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m String
display DataCon
data_con 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 (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m 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 (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m 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 fam_envs key term

-- | Construct the VarInfos of the fields ('VarFields') of the given 'TermKey'/'Term'
--
-- This is used to come up with terms for the fields of an already `seq`ed
-- variable which was expanded.
termVarFields :: FamInstEnvs -> TermKey -> Term -> Debugger VarFields
termVarFields :: FamInstEnvs -> TermKey -> Term -> Debugger VarFields
termVarFields FamInstEnvs
fam_envs TermKey
top_key Term
top_term = do

  vcVarFields <- Term -> Debugger (Maybe [(String, Term)])
debugFieldsTerm Term
top_term

  case vcVarFields of
    -- The custom instance case (top_term should always be a @Term@ if @Just@)
    Just [(String, Term)]
fls -> do

      let keys :: [TermKey]
keys = ((String, Term) -> TermKey) -> [(String, Term)] -> [TermKey]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
f_name, Term
f_term) -> TermKey -> String -> Term -> TermKey
FromCustomTerm TermKey
top_key String
f_name Term
f_term) [(String, Term)]
fls
      [VarInfo] -> VarFields
VarFields ([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
>>= FamInstEnvs -> TermKey -> Term -> Debugger VarInfo
termToVarInfo FamInstEnvs
fam_envs TermKey
k) [TermKey]
keys

    -- The general case
    Maybe [(String, Term)]
_ -> case Term
top_term of
      -- Make 'VarInfo's for the first layer of subTerms only.
      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 'False -> TermKey
FromPath TermKey
top_key (Int -> PathFragment 'False
forall (b :: Bool). Int -> PathFragment b
PositionalIndex Int
ix)) [Int
1..] (DataCon -> [Scaled RttiType]
dataConRepArgTys DataCon
dc)
            [VarInfo] -> VarFields
VarFields ([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
>>= FamInstEnvs -> TermKey -> Term -> Debugger VarInfo
termToVarInfo FamInstEnvs
fam_envs TermKey
k) [TermKey]
keys
          -- Is a record data con,
          -- Use field labels
          [FieldLabel]
dataConFields -> do
            let mkPath :: Int -> Maybe FieldLabel -> TermKey
mkPath Int
ix Maybe FieldLabel
Nothing = TermKey -> PathFragment 'False -> TermKey
FromPath TermKey
top_key (Int -> PathFragment 'False
forall (b :: Bool). Int -> PathFragment b
PositionalIndex Int
ix)
                mkPath Int
ix (Just FieldLabel
fld) = TermKey -> PathFragment 'False -> TermKey
FromPath TermKey
top_key (Int -> Name -> PathFragment 'False
forall (b :: Bool). Int -> Name -> PathFragment b
LabeledField Int
ix (FieldLabel -> Name
flSelector FieldLabel
fld))
                keys :: [TermKey]
keys = (Int -> Maybe FieldLabel -> TermKey)
-> [Int] -> [Maybe FieldLabel] -> [TermKey]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Maybe FieldLabel -> TermKey
mkPath [Int
1..] ((Maybe FieldLabel
forall a. Maybe a
Nothing Maybe FieldLabel -> [RttiType] -> [Maybe FieldLabel]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ DataCon -> [RttiType]
dataConOtherTheta DataCon
dc) [Maybe FieldLabel] -> [Maybe FieldLabel] -> [Maybe FieldLabel]
forall a. [a] -> [a] -> [a]
++ ((FieldLabel -> Maybe FieldLabel)
-> [FieldLabel] -> [Maybe FieldLabel]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Maybe FieldLabel
forall a. a -> Maybe a
Just [FieldLabel]
dataConFields))
            [VarInfo] -> VarFields
VarFields ([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
>>= FamInstEnvs -> TermKey -> Term -> Debugger VarInfo
termToVarInfo FamInstEnvs
fam_envs 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 'False -> TermKey
FromPath TermKey
top_key (Int -> PathFragment 'False
forall (b :: Bool). Int -> PathFragment b
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
>>= FamInstEnvs -> TermKey -> Term -> Debugger VarInfo
termToVarInfo FamInstEnvs
fam_envs TermKey
key
            return (VarFields [wvi])
          [FieldLabel
fld] -> do
            let key :: TermKey
key = TermKey -> PathFragment 'False -> TermKey
FromPath TermKey
top_key (Int -> Name -> PathFragment 'False
forall (b :: Bool). Int -> Name -> PathFragment b
LabeledField Int
1 (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
>>= FamInstEnvs -> TermKey -> Term -> Debugger VarInfo
termToVarInfo FamInstEnvs
fam_envs TermKey
key
            return (VarFields [wvi])
          [FieldLabel]
_ -> String -> Debugger VarFields
forall a. HasCallStack => String -> a
error String
"unexpected number of Newtype fields: larger than 1"
      RefWrap{wrapped_term :: Term -> Term
wrapped_term=Term
_{- don't use directly! go through @obtainTerm@ -}} -> do
        let key :: TermKey
key = TermKey -> PathFragment 'False -> TermKey
FromPath TermKey
top_key (Int -> PathFragment 'False
forall (b :: Bool). Int -> PathFragment b
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
>>= FamInstEnvs -> TermKey -> Term -> Debugger VarInfo
termToVarInfo FamInstEnvs
fam_envs TermKey
key
        return (VarFields [wvi])
      Term
_ -> VarFields -> Debugger VarFields
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return ([VarInfo] -> VarFields
VarFields [])


-- | Construct a 'VarInfo' from the given 'Name' of the variable and the 'Term' it binds
--   The @FamInstEnvs@ is used to look through newtypes and type families when checking if suspensions are of function type.
termToVarInfo :: FamInstEnvs -> TermKey -> Term -> Debugger VarInfo
termToVarInfo :: FamInstEnvs -> TermKey -> Term -> Debugger VarInfo
termToVarInfo FamInstEnvs
fam_envs TermKey
key Term
term0 = do
  -- Make a VarInfo for a term
  let
    ty :: RttiType
ty = Term -> RttiType
GHCI.termType Term
term0

  varName <- TermKey -> Debugger String
forall (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m String
display TermKey
key
  varType <- display ty
  case term0 of
    Term
t | Suspension{} <- Term -> Term
unwrapNewtype Term
t, RttiType -> Bool
isFunctionType RttiType
ty -> do
      VarInfo -> Debugger VarInfo
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return VarInfo
        { String
varName :: String
varName :: String
varName
        , String
varType :: String
varType :: String
varType
        , varValue :: String
varValue = String
"<fn> :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
varType
        , varRef :: VariableReference
varRef = VariableReference
NoVariables
        , isThunk :: Bool
isThunk = Bool
False
        }

    -- The simple case: The term is a a thunk...
    Suspension{} -> do
      VarInfo -> Debugger VarInfo
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return VarInfo
        { String
varName :: String
varName :: String
varName
        , String
varType :: String
varType :: String
varType
        , varValue :: String
varValue = String
"_"
        , varRef :: VariableReference
varRef = TermKey -> VariableReference
SpecificVariable TermKey
key -- allows forcing the thunk
        , isThunk :: Bool
isThunk = Bool
True
        }

    -- Otherwise, try to apply and decode a custom 'DebugView', or default to
    -- the inspecting the original term generically
    Term
_ -> do

      -- Try to apply `DebugView.debugValue`
      mterm <- Term -> Debugger (Maybe VarValueResult)
debugValueTerm Term
term0

      case mterm of
        -- Default to generic representation
        Maybe VarValueResult
Nothing -> do

          let
            -- In the general case, 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 = case Term
t of
               Term{} -> Term
t{subTerms = []}
               Term
_      -> Term
t

          varValue <- SDoc -> Debugger String
forall (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m String
display (SDoc -> Debugger String) -> Debugger SDoc -> Debugger String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> Debugger SDoc
forall (m :: * -> *). GhcMonad m => Term -> m SDoc
GHCD.showTerm (Term -> Term
termHead Term
term0)

          -- 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 hasDirectSubTerms term0
             then do
                return (SpecificVariable key)
             else do
                return NoVariables

          return VarInfo
            { varName, varType
            , isThunk = False
            , varValue, varRef }

        Just VarValueResult{varValueResultExpandable :: VarValueResult -> Bool
varValueResultExpandable=Bool
varExpandable, varValueResult :: VarValueResult -> String
varValueResult=String
value} -> do

          varRef <-
            if Bool
varExpandable
            then do
                VariableReference -> Debugger VariableReference
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermKey -> VariableReference
SpecificVariable TermKey
key)
             else do
                VariableReference -> Debugger VariableReference
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return VariableReference
NoVariables
          return VarInfo
            { varName, varType
            , isThunk = False
            , varValue = value
            , varRef
            }

  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] -> Bool) -> [Term] -> Bool
forall a b. (a -> b) -> a -> b
$ [Term]
subTerms
    -- Check for function types explicitly since they seem to always match Suspension
    -- but should not be shown as thunks in the UI.
    isFunctionType :: RttiType -> Bool
isFunctionType = \case
      (FunTy FunTyFlag
_ RttiType
_ RttiType
_ RttiType
_) -> Bool
True
      (ForAllTy ForAllTyBinder
_ RttiType
t)  -> RttiType -> Bool
isFunctionType RttiType
t
      (FamInstEnvs -> RttiType -> Maybe Reduction
topNormaliseType_maybe FamInstEnvs
fam_envs -> Just Reduction{Coercion
RttiType
reductionCoercion :: Coercion
reductionReducedType :: RttiType
reductionReducedType :: Reduction -> RttiType
reductionCoercion :: Reduction -> Coercion
..})
        -> RttiType -> Bool
isFunctionType RttiType
reductionReducedType
      RttiType
_ -> Bool
False
    -- FIXME: couldn't find test case where this is needed.
    unwrapNewtype :: Term -> Term
unwrapNewtype (NewtypeWrap {Term
wrapped_term :: Term -> Term
wrapped_term :: Term
wrapped_term}) = Term -> Term
unwrapNewtype Term
wrapped_term
    unwrapNewtype Term
x = Term
x

-- | Thin wrapper around @tcGetFamInstEnvs@, using @runTcInteractive@
getFamInstEnvs' :: Debugger FamInstEnvs
getFamInstEnvs' :: Debugger FamInstEnvs
getFamInstEnvs' = do
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  (err_msgs, res) <- liftIO $
    runTcInteractive
#if MIN_VERSION_ghc(10,1,0)
      NoTcMPlugins
#endif
      hsc_env
      tcGetFamInstEnvs
  case res of
    Just FamInstEnvs
fam_envs -> FamInstEnvs -> Debugger FamInstEnvs
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FamInstEnvs
fam_envs
    Maybe FamInstEnvs
Nothing -> do
      Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Debug
        (SDoc -> Debugger ()) -> SDoc -> Debugger ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Couldn't lookup FamInstEnvs to normalise type for VarInfo,"
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"using empty ones."
        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$  Messages TcRnMessage -> SDoc
forall a. Outputable a => a -> SDoc
ppr Messages TcRnMessage
err_msgs
      FamInstEnvs -> Debugger FamInstEnvs
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return FamInstEnvs
emptyFamInstEnvs

pprTerm :: Term -> SDoc
pprTerm :: Term -> SDoc
pprTerm Term
t = case Term
t of
  Term{Either String DataCon
dc :: Term -> Either String DataCon
dc :: Either String DataCon
dc,[Term]
subTerms :: Term -> [Term]
subTerms :: [Term]
subTerms} -> String -> SDoc -> SDoc
annotate String
"T:" (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    (String -> SDoc)
-> (DataCon -> SDoc) -> Either String DataCon -> SDoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> SDoc
forall doc. IsLine doc => String -> doc
text DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr Either String DataCon
dc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((Term -> SDoc) -> [Term] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Term -> SDoc
pprTerm [Term]
subTerms)
  Prim{[Word]
valRaw :: [Word]
valRaw :: Term -> [Word]
valRaw} -> String -> SDoc -> SDoc
annotate String
"P:" (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [Word] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Word]
valRaw
  Suspension{Maybe Name
bound_to :: Maybe Name
bound_to :: Term -> Maybe Name
bound_to,ClosureType
ctype :: ClosureType
ctype :: Term -> ClosureType
ctype} -> String -> SDoc -> SDoc
annotate String
"S:" (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Maybe Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Name
bound_to SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (ClosureType -> String
forall a. Show a => a -> String
show ClosureType
ctype)
  NewtypeWrap{Either String DataCon
dc :: Term -> Either String DataCon
dc :: Either String DataCon
dc,Term
wrapped_term :: Term -> Term
wrapped_term :: Term
wrapped_term} ->
    String -> SDoc -> SDoc
annotate String
"N:" (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ (String -> SDoc)
-> (DataCon -> SDoc) -> Either String DataCon -> SDoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> SDoc
forall doc. IsLine doc => String -> doc
text DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr Either String DataCon
dc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Term -> SDoc
pprTerm Term
wrapped_term
  RefWrap{Term
wrapped_term :: Term -> Term
wrapped_term :: Term
wrapped_term} -> String -> SDoc -> SDoc
annotate String
"R:" (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Term -> SDoc
pprTerm Term
wrapped_term
  where
    annotate :: String -> SDoc -> SDoc
annotate String
tag SDoc
d = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
tag SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Term -> RttiType
ty Term
t) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"∋" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
d

-- | Forces a term to WHNF
--
-- The term is updated in the cache at the given key.
forceTerm :: Term -> Debugger Term
forceTerm :: Term -> Debugger Term
forceTerm Term
term = do
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  liftIO $ seqTerm hsc_env term