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
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]
(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
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}
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
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
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))
, 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
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
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)])
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
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
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
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)
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
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