-----------------------------------------------------------------------------
--
-- GHCi Interactive debugging commands
--
-- Pepe Iborra (supported by Google SoC) 2006
--
-- ToDo: lots of violation of layering here.  This module should
-- decide whether it is above the GHC API (import GHC and nothing
-- else) or below it.
--
-----------------------------------------------------------------------------

module GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where

import GHC.Prelude

import GHC

import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Monad
import GHC.Driver.Env

import GHC.Linker.Loader

import GHC.Runtime.Heap.Inspect
import GHC.Runtime.Interpreter
import GHC.Runtime.Context

import GHC.Iface.Syntax ( showToHeader )
import GHC.Iface.Env    ( newInteractiveBinder )
import GHC.Core.Type

import GHC.Utils.Outputable
import GHC.Utils.Error
import GHC.Utils.Monad
import GHC.Utils.Exception
import GHC.Utils.Logger

import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Var hiding ( varName )
import GHC.Types.Var.Set
import GHC.Types.Unique.Set
import GHC.Types.TyThing.Ppr
import GHC.Types.TyThing

import Control.Monad
import Control.Monad.Catch as MC
import Data.List ( (\\) )
import Data.Maybe
import Data.IORef

-------------------------------------
-- | The :print & friends commands
-------------------------------------
pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
pprintClosureCommand :: forall (m :: * -> *). GhcMonad m => Bool -> Bool -> String -> m ()
pprintClosureCommand Bool
bindThings Bool
force String
str = do
  [TyThing]
tythings <- (forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`
                 forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
w -> forall (m :: * -> *). GhcMonad m => String -> m [Name]
GHC.parseName String
w forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupName)
                      (String -> [String]
words String
str)
  let ids :: [Id]
ids = [Id
id | AnId Id
id <- [TyThing]
tythings]

  -- Obtain the terms and the recovered type information
  (TCvSubst
subst, [Term]
terms) <- forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM forall (m :: * -> *).
GhcMonad m =>
TCvSubst -> Id -> m (TCvSubst, Term)
go TCvSubst
emptyTCvSubst [Id]
ids

  -- Apply the substitutions obtained after recovering the types
  forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
    HscEnv
hsc_env{hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext -> TCvSubst -> InteractiveContext
substInteractiveContext (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) TCvSubst
subst}

  -- Finally, print the Terms
  PrintUnqualified
unqual  <- forall (m :: * -> *). GhcMonad m => m PrintUnqualified
GHC.getPrintUnqual
  [SDoc]
docterms <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). GhcMonad m => Term -> m SDoc
showTerm [Term]
terms
  DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
printOutputForUser Logger
logger DynFlags
dflags PrintUnqualified
unqual forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
vcat)
           (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Id
id SDoc
docterm -> forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'=' SDoc -> SDoc -> SDoc
<+> SDoc
docterm)
                    [Id]
ids
                    [SDoc]
docterms)
 where
   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
   go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term)
   go :: forall (m :: * -> *).
GhcMonad m =>
TCvSubst -> Id -> m (TCvSubst, Term)
go TCvSubst
subst Id
id = do
       let id' :: Id
id' = (Type -> Type) -> Id -> Id
updateIdTypeAndMult (HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
subst) Id
id
           id_ty' :: Type
id_ty' = Id -> Type
idType Id
id'
       Term
term_    <- forall (m :: * -> *). GhcMonad m => Int -> Bool -> Id -> m Term
GHC.obtainTermFromId forall a. Bounded a => a
maxBound Bool
force Id
id'
       Term
term     <- forall (m :: * -> *). GhcMonad m => Term -> m Term
tidyTermTyVars Term
term_
       Term
term'    <- if Bool
bindThings
                     then forall (m :: * -> *). GhcMonad m => Term -> m Term
bindSuspensions Term
term
                     else forall (m :: * -> *) a. Monad m => a -> m a
return Term
term
     -- Before leaving, we compare the type obtained to see if it's more specific
     --  Then, we extract a substitution,
     --  mapping the old tyvars to the reconstructed types.
       let reconstructed_type :: Type
reconstructed_type = Term -> Type
termType Term
term
       HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
       case (HscEnv -> Type -> Type -> Maybe TCvSubst
improveRTTIType HscEnv
hsc_env Type
id_ty' Type
reconstructed_type) of
         Maybe TCvSubst
Nothing     -> forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst, Term
term')
         Just TCvSubst
subst' -> do { DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
                           ; Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
                           ; forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                               Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_rtti String
"RTTI"
                                 DumpFormat
FormatText
                                 ([SDoc] -> SDoc
fsep forall a b. (a -> b) -> a -> b
$ [String -> SDoc
text String
"RTTI Improvement for", forall a. Outputable a => a -> SDoc
ppr Id
id,
                                  String -> SDoc
text String
"old substitution:" , forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst,
                                  String -> SDoc
text String
"new substitution:" , forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst'])
                           ; forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst TCvSubst -> TCvSubst -> TCvSubst
`unionTCvSubst` TCvSubst
subst', Term
term')}

   tidyTermTyVars :: GhcMonad m => Term -> m Term
   tidyTermTyVars :: forall (m :: * -> *). GhcMonad m => Term -> m Term
tidyTermTyVars Term
t =
     forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
     let env_tvs :: TyCoVarSet
env_tvs      = [TyThing] -> TyCoVarSet
tyThingsTyCoVars forall a b. (a -> b) -> a -> b
$ InteractiveContext -> [TyThing]
ic_tythings forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
         my_tvs :: TyCoVarSet
my_tvs       = Term -> TyCoVarSet
termTyCoVars Term
t
         tvs :: TyCoVarSet
tvs          = TyCoVarSet
env_tvs TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`minusVarSet` TyCoVarSet
my_tvs
         tyvarOccName :: Id -> OccName
tyvarOccName = Name -> OccName
nameOccName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
tyVarName
         tidyEnv :: (TidyOccEnv, UniqFM Id Id)
tidyEnv      = ([OccName] -> TidyOccEnv
initTidyOccEnv (forall a b. (a -> b) -> [a] -> [b]
map Id -> OccName
tyvarOccName (forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet TyCoVarSet
tvs))
           -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv
           -- forgets the ordering immediately by creating an env
                        , forall a. UniqSet a -> UniqFM a a
getUniqSet forall a b. (a -> b) -> a -> b
$ TyCoVarSet
env_tvs TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`intersectVarSet` TyCoVarSet
my_tvs)
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> Term -> Term
mapTermType (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TidyOccEnv, UniqFM Id Id)
-> Type -> ((TidyOccEnv, UniqFM Id Id), Type)
tidyOpenType (TidyOccEnv, UniqFM Id Id)
tidyEnv) Term
t

-- | Give names, and bind in the interactive environment, to all the suspensions
--   included (inductively) in a term
bindSuspensions :: GhcMonad m => Term -> m Term
bindSuspensions :: forall (m :: * -> *). GhcMonad m => Term -> m Term
bindSuspensions Term
t = do
      HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
      [TyThing]
inScope <- forall (m :: * -> *). GhcMonad m => m [TyThing]
GHC.getBindings
      let ictxt :: InteractiveContext
ictxt        = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
          prefix :: String
prefix       = String
"_t"
          alreadyUsedNames :: [String]
alreadyUsedNames = forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedThing a => a -> Name
getName) [TyThing]
inScope
          availNames :: [String]
availNames   = forall a b. (a -> b) -> [a] -> [b]
map ((String
prefixforall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [(Int
1::Int)..] forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
alreadyUsedNames
      IORef [String]
availNames_var  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef [String]
availNames
      (Term
t', [(Name, Type, ForeignHValue)]
stuff)     <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TermFold a -> Term -> a
foldTerm (HscEnv
-> IORef [String]
-> TermFold (IO (Term, [(Name, Type, ForeignHValue)]))
nameSuspensionsAndGetInfos HscEnv
hsc_env IORef [String]
availNames_var) Term
t
      let ([Name]
names, [Type]
tys, [ForeignHValue]
fhvs) = forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(Name, Type, ForeignHValue)]
stuff
      let ids :: [Id]
ids = [ Name -> Type -> Id
mkVanillaGlobal Name
name Type
ty
                | (Name
name,Type
ty) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
names [Type]
tys]
          new_ic :: InteractiveContext
new_ic = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds InteractiveContext
ictxt [Id]
ids
          interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> [(Name, ForeignHValue)] -> IO ()
extendLoadedEnv Interp
interp (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
names [ForeignHValue]
fhvs)
      forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env {hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
new_ic }
      forall (m :: * -> *) a. Monad m => a -> m a
return Term
t'
     where

--    Processing suspensions. Give names and recopilate info
        nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]
                                   -> TermFold (IO (Term, [(Name,Type,ForeignHValue)]))
        nameSuspensionsAndGetInfos :: HscEnv
-> IORef [String]
-> TermFold (IO (Term, [(Name, Type, ForeignHValue)]))
nameSuspensionsAndGetInfos HscEnv
hsc_env IORef [String]
freeNames = TermFold
                      {
                        fSuspension :: ClosureType
-> Type
-> ForeignHValue
-> Maybe Name
-> IO (Term, [(Name, Type, ForeignHValue)])
fSuspension = forall {p}.
HscEnv
-> IORef [String]
-> ClosureType
-> Type
-> ForeignHValue
-> p
-> IO (Term, [(Name, Type, ForeignHValue)])
doSuspension HscEnv
hsc_env IORef [String]
freeNames
                      , fTerm :: TermProcessor
  (IO (Term, [(Name, Type, ForeignHValue)]))
  (IO (Term, [(Name, Type, ForeignHValue)]))
fTerm = \Type
ty Either String DataCon
dc ForeignHValue
v [IO (Term, [(Name, Type, ForeignHValue)])]
tt -> do
                                    [(Term, [(Name, Type, ForeignHValue)])]
tt' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [IO (Term, [(Name, Type, ForeignHValue)])]
tt
                                    let ([Term]
terms,[[(Name, Type, ForeignHValue)]]
names) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Term, [(Name, Type, ForeignHValue)])]
tt'
                                    forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Either String DataCon -> ForeignHValue -> [Term] -> Term
Term Type
ty Either String DataCon
dc ForeignHValue
v [Term]
terms, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Name, Type, ForeignHValue)]]
names)
                      , fPrim :: Type -> [Word] -> IO (Term, [(Name, Type, ForeignHValue)])
fPrim    = \Type
ty [Word]
n ->forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> [Word] -> Term
Prim Type
ty [Word]
n,[])
                      , fNewtypeWrap :: Type
-> Either String DataCon
-> IO (Term, [(Name, Type, ForeignHValue)])
-> IO (Term, [(Name, Type, ForeignHValue)])
fNewtypeWrap  =
                                \Type
ty Either String DataCon
dc IO (Term, [(Name, Type, ForeignHValue)])
t -> do
                                    (Term
term, [(Name, Type, ForeignHValue)]
names) <- IO (Term, [(Name, Type, ForeignHValue)])
t
                                    forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Either String DataCon -> Term -> Term
NewtypeWrap Type
ty Either String DataCon
dc Term
term, [(Name, Type, ForeignHValue)]
names)
                      , fRefWrap :: Type
-> IO (Term, [(Name, Type, ForeignHValue)])
-> IO (Term, [(Name, Type, ForeignHValue)])
fRefWrap = \Type
ty IO (Term, [(Name, Type, ForeignHValue)])
t -> do
                                    (Term
term, [(Name, Type, ForeignHValue)]
names) <- IO (Term, [(Name, Type, ForeignHValue)])
t
                                    forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term -> Term
RefWrap Type
ty Term
term, [(Name, Type, ForeignHValue)]
names)
                      }
        doSuspension :: HscEnv
-> IORef [String]
-> ClosureType
-> Type
-> ForeignHValue
-> p
-> IO (Term, [(Name, Type, ForeignHValue)])
doSuspension HscEnv
hsc_env IORef [String]
freeNames ClosureType
ct Type
ty ForeignHValue
hval p
_name = do
          String
name <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [String]
freeNames (\[String]
x->(forall a. [a] -> [a]
tail [String]
x, forall a. [a] -> a
head [String]
x))
          Name
n <- forall (m :: * -> *). MonadIO m => HscEnv -> String -> m Name
newGrimName HscEnv
hsc_env String
name
          forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct Type
ty ForeignHValue
hval (forall a. a -> Maybe a
Just Name
n), [(Name
n,Type
ty,ForeignHValue
hval)])


--  A custom Term printer to enable the use of Show instances
showTerm :: GhcMonad m => Term -> m SDoc
showTerm :: forall (m :: * -> *). GhcMonad m => Term -> m SDoc
showTerm Term
term = do
    DynFlags
dflags       <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
    if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintEvldWithShow DynFlags
dflags
       then forall (m :: * -> *).
Monad m =>
CustomTermPrinter m -> Term -> m SDoc
cPprTerm (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. [a] -> [a] -> [a]
(++) (\TermPrinterM m
_y->[forall {m :: * -> *} {t}.
(GhcMonad m, Ord t, Num t) =>
t -> Term -> m (Maybe SDoc)
cPprShowable]) forall (m :: * -> *). Monad m => CustomTermPrinter m
cPprTermBase) Term
term
       else forall (m :: * -> *).
Monad m =>
CustomTermPrinter m -> Term -> m SDoc
cPprTerm forall (m :: * -> *). Monad m => CustomTermPrinter m
cPprTermBase Term
term
 where
  cPprShowable :: t -> Term -> m (Maybe SDoc)
cPprShowable t
prec t :: Term
t@Term{ty :: Term -> Type
ty=Type
ty, val :: Term -> ForeignHValue
val=ForeignHValue
fhv} =
    if Bool -> Bool
not (Term -> Bool
isFullyEvaluatedTerm Term
t)
     then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
     else do
        let set_session :: m (HscEnv, Name)
set_session = do
                HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
                (HscEnv
new_env, Name
bname) <- forall {m :: * -> *}.
MonadIO m =>
HscEnv -> Type -> String -> m (HscEnv, Name)
bindToFreshName HscEnv
hsc_env Type
ty String
"showme"
                forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
new_env

                -- this disables logging of errors
                let noop_log :: p -> p -> p -> p -> p -> m ()
noop_log p
_ p
_ p
_ p
_ p
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
                forall (m :: * -> *).
GhcMonad m =>
(LogAction -> LogAction) -> m ()
pushLogHookM (forall a b. a -> b -> a
const forall {m :: * -> *} {p} {p} {p} {p} {p}.
Monad m =>
p -> p -> p -> p -> p -> m ()
noop_log)

                forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env, Name
bname)

            reset_session :: (HscEnv, b) -> m ()
reset_session (HscEnv
old_env,b
_) = forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
old_env

        forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket m (HscEnv, Name)
set_session forall {m :: * -> *} {b}. GhcMonad m => (HscEnv, b) -> m ()
reset_session forall a b. (a -> b) -> a -> b
$ \(HscEnv
_,Name
bname) -> do
           HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
           DynFlags
dflags  <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
           let expr :: String
expr = String
"Prelude.return (Prelude.show " forall a. [a] -> [a] -> [a]
++
                         forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags Name
bname forall a. [a] -> [a] -> [a]
++
                      String
") :: Prelude.IO Prelude.String"
               interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
           ForeignHValue
txt_ <- forall (m :: * -> *) a.
ExceptionMonad m =>
Interp -> [(Name, ForeignHValue)] -> m a -> m a
withExtendedLoadedEnv Interp
interp
                                       [(Name
bname, ForeignHValue
fhv)]
                                       (forall (m :: * -> *). GhcMonad m => String -> m ForeignHValue
GHC.compileExprRemote String
expr)
           let myprec :: t
myprec = t
10 -- application precedence. TODO Infix constructors
           String
txt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> ForeignHValue -> IO String
evalString Interp
interp ForeignHValue
txt_
           if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
txt) then
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (t
prec forall a. Ord a => a -> a -> Bool
>= t
myprec Bool -> Bool -> Bool
&& String -> Bool
needsParens String
txt)
                                    (String -> SDoc
text String
txt)
            else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

  cPprShowable t
prec NewtypeWrap{ty :: Term -> Type
ty=Type
new_ty,wrapped_term :: Term -> Term
wrapped_term=Term
t} =
      t -> Term -> m (Maybe SDoc)
cPprShowable t
prec Term
t{ty :: Type
ty=Type
new_ty}
  cPprShowable t
_ Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

  needsParens :: String -> Bool
needsParens (Char
'"':String
_) = Bool
False   -- some simple heuristics to see whether parens
                                -- are redundant in an arbitrary Show output
  needsParens (Char
'(':String
_) = Bool
False
  needsParens String
txt = Char
' ' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
txt


  bindToFreshName :: HscEnv -> Type -> String -> m (HscEnv, Name)
bindToFreshName HscEnv
hsc_env Type
ty String
userName = do
    Name
name <- forall (m :: * -> *). MonadIO m => HscEnv -> String -> m Name
newGrimName HscEnv
hsc_env String
userName
    let id :: Id
id       = Name -> Type -> Id
mkVanillaGlobal Name
name Type
ty
        new_ic :: InteractiveContext
new_ic   = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) [Id
id]
    forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env {hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
new_ic }, Name
name)

--    Create new uniques and give them sequentially numbered names
newGrimName :: MonadIO m => HscEnv -> String -> m Name
newGrimName :: forall (m :: * -> *). MonadIO m => HscEnv -> String -> m Name
newGrimName HscEnv
hsc_env String
userName
  = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env OccName
occ SrcSpan
noSrcSpan)
  where
    occ :: OccName
occ = NameSpace -> String -> OccName
mkOccName NameSpace
varName String
userName

pprTypeAndContents :: GhcMonad m => Id -> m SDoc
pprTypeAndContents :: forall (m :: * -> *). GhcMonad m => Id -> m SDoc
pprTypeAndContents Id
id = do
  DynFlags
dflags  <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  let pcontents :: Bool
pcontents = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintBindContents DynFlags
dflags
      pprdId :: SDoc
pprdId    = (ShowSub -> TyThing -> SDoc
pprTyThing ShowSub
showToHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> TyThing
AnId) Id
id
  if Bool
pcontents
    then do
      let depthBound :: Int
depthBound = Int
100
      -- If the value is an exception, make sure we catch it and
      -- show the exception, rather than propagating the exception out.
      Either SomeException Term
e_term <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => Int -> Bool -> Id -> m Term
GHC.obtainTermFromId Int
depthBound Bool
False Id
id
      SDoc
docs_term <- case Either SomeException Term
e_term of
                      Right Term
term -> forall (m :: * -> *). GhcMonad m => Term -> m SDoc
showTerm Term
term
                      Left  SomeException
exn  -> forall (m :: * -> *) a. Monad m => a -> m a
return (String -> SDoc
text String
"*** Exception:" SDoc -> SDoc -> SDoc
<+>
                                            String -> SDoc
text (forall a. Show a => a -> String
show (SomeException
exn :: SomeException)))
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SDoc
pprdId SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> SDoc
docs_term
    else forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
pprdId