-----------------------------------------------------------------------------
--
-- 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.DynFlags
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.Id.Make (ghcPrimIds)
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 ( (\\), partition )
import qualified Data.List.NonEmpty as NE
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
  tythings <- ([Maybe TyThing] -> [TyThing]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TyThing] -> [TyThing])
-> ([NonEmpty (Maybe TyThing)] -> [Maybe TyThing])
-> [NonEmpty (Maybe TyThing)]
-> [TyThing]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (Maybe TyThing) -> [Maybe TyThing])
-> [NonEmpty (Maybe TyThing)] -> [Maybe TyThing]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty (Maybe TyThing) -> [Maybe TyThing]
forall a. NonEmpty a -> [a]
NE.toList) ([NonEmpty (Maybe TyThing)] -> [TyThing])
-> m [NonEmpty (Maybe TyThing)] -> m [TyThing]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`
                 (String -> m (NonEmpty (Maybe TyThing)))
-> [String] -> m [NonEmpty (Maybe TyThing)]
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 (\String
w -> String -> m (NonEmpty Name)
forall (m :: * -> *). GhcMonad m => String -> m (NonEmpty Name)
GHC.parseName String
w m (NonEmpty Name)
-> (NonEmpty Name -> m (NonEmpty (Maybe TyThing)))
-> m (NonEmpty (Maybe TyThing))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                (Name -> m (Maybe TyThing))
-> NonEmpty Name -> m (NonEmpty (Maybe TyThing))
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) -> NonEmpty a -> m (NonEmpty b)
mapM Name -> m (Maybe TyThing)
forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupName)
                      (String -> [String]
words String
str)

  -- Sort out good and bad tythings for :print and friends
  let (pprintables, unpprintables) = partition can_pprint tythings

  -- Obtain the terms and the recovered type information
  let ids = [Id
id | AnId Id
id <- [TyThing]
pprintables]
  (subst, terms) <- mapAccumLM go emptySubst ids

  -- Apply the substitutions obtained after recovering the types
  modifySession $ \HscEnv
hsc_env ->
    HscEnv
hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}

  -- Finally, print the Results
  docterms <- mapM showTerm terms
  let sdocTerms = (Id -> SDoc -> SDoc) -> [Id] -> [SDoc] -> [SDoc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Id
id SDoc
docterm -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'=' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
docterm)
                          [Id]
ids
                          [SDoc]
docterms
  printSDocs $ (no_pprint <$> unpprintables) ++ sdocTerms
 where
   -- Check whether a TyThing can be processed by :print and friends.
   -- Take only Ids, exclude pseudoops, they don't have any HValues.
   can_pprint :: TyThing -> Bool                              -- #19394
   can_pprint :: TyThing -> Bool
can_pprint (AnId Id
x)
       | Id
x Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Id]
ghcPrimIds = Bool
True
       | Bool
otherwise              = Bool
False
   can_pprint TyThing
_                 = Bool
False

   -- Create a short message for a TyThing, that cannot processed by :print
   no_pprint :: TyThing -> SDoc
   no_pprint :: TyThing -> SDoc
no_pprint TyThing
tything = TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
tything SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is not eligible for the :print, :sprint or :force commands."

   -- Helper to print out the results of :print and friends
   printSDocs :: GhcMonad m => [SDoc] -> m ()
   printSDocs :: forall (m :: * -> *). GhcMonad m => [SDoc] -> m ()
printSDocs [SDoc]
sdocs = do
      logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
      name_ppr_ctx <- GHC.getNamePprCtx
      liftIO $ printOutputForUser logger name_ppr_ctx $ vcat sdocs

   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
   go :: GhcMonad m => Subst -> Id -> m (Subst, Term)
   go :: forall (m :: * -> *). GhcMonad m => Subst -> Id -> m (Subst, Term)
go Subst
subst Id
id = do
       let id' :: Id
id' = (Type -> Type) -> Id -> Id
updateIdTypeAndMult (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst) Id
id
           id_ty' :: Type
id_ty' = Id -> Type
idType Id
id'
       term_    <- Int -> Bool -> Id -> m Term
forall (m :: * -> *). GhcMonad m => Int -> Bool -> Id -> m Term
GHC.obtainTermFromId Int
forall a. Bounded a => a
maxBound Bool
force Id
id'
       term     <- tidyTermTyVars term_
       term'    <- if bindThings
                     then bindSuspensions term
                     else return 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 = Term -> Type
termType Term
term
       hsc_env <- getSession
       case (improveRTTIType hsc_env id_ty' reconstructed_type) of
         Maybe Subst
Nothing     -> (Subst, Term) -> m (Subst, Term)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Subst
subst, Term
term')
         Just Subst
subst' -> do { logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
                           ; liftIO $
                               putDumpFileMaybe logger Opt_D_dump_rtti "RTTI"
                                 FormatText
                                 (fsep $ [text "RTTI Improvement for", ppr id,
                                  text "old substitution:" , ppr subst,
                                  text "new substitution:" , ppr subst'])
                           ; return (subst `unionSubst` subst', term')}

   tidyTermTyVars :: GhcMonad m => Term -> m Term
   tidyTermTyVars :: forall (m :: * -> *). GhcMonad m => Term -> m Term
tidyTermTyVars Term
t =
     (HscEnv -> m Term) -> m Term
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Term) -> m Term) -> (HscEnv -> m Term) -> m Term
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
     let env_tvs :: TyCoVarSet
env_tvs      = [TyThing] -> TyCoVarSet
tyThingsTyCoVars ([TyThing] -> TyCoVarSet) -> [TyThing] -> TyCoVarSet
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> [TyThing]
ic_tythings (InteractiveContext -> [TyThing])
-> InteractiveContext -> [TyThing]
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 (Name -> OccName) -> (Id -> Name) -> Id -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
tyVarName
         tidyEnv :: (TidyOccEnv, UniqFM Id Id)
tidyEnv      = ([OccName] -> TidyOccEnv
initTidyOccEnv ((Id -> OccName) -> [Id] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map Id -> OccName
tyvarOccName (TyCoVarSet -> [Id]
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
                        , TyCoVarSet -> UniqFM Id Id
forall a. UniqSet a -> UniqFM a a
getUniqSet (TyCoVarSet -> UniqFM Id Id) -> TyCoVarSet -> UniqFM Id Id
forall a b. (a -> b) -> a -> b
$ TyCoVarSet
env_tvs TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`intersectVarSet` TyCoVarSet
my_tvs)
     Term -> m Term
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> m Term) -> Term -> m Term
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> Term -> Term
mapTermType (((TidyOccEnv, UniqFM Id Id), Type) -> Type
forall a b. (a, b) -> b
snd (((TidyOccEnv, UniqFM Id Id), Type) -> Type)
-> (Type -> ((TidyOccEnv, UniqFM Id Id), Type)) -> Type -> Type
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
      hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
      inScope <- GHC.getBindings
      let ictxt        = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
          prefix       = String
"_t"
          alreadyUsedNames = (TyThing -> String) -> [TyThing] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString (OccName -> String) -> (TyThing -> OccName) -> TyThing -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (TyThing -> Name) -> TyThing -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyThing -> Name
forall a. NamedThing a => a -> Name
getName) [TyThing]
inScope
          availNames   = (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
prefixString -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Int
1::Int)..] [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
alreadyUsedNames
      availNames_var  <- liftIO $ newIORef availNames
      (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
      let (names, tys, fhvs) = unzip3 stuff
      let ids = [ Name -> Type -> Id
mkVanillaGlobal Name
name Type
ty
                | (Name
name,Type
ty) <- [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
names [Type]
tys]
          new_ic = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds InteractiveContext
ictxt [Id]
ids
          interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
      liftIO $ extendLoadedEnv interp (zip names fhvs)
      setSession hsc_env {hsc_IC = new_ic }
      return t'
     where

--    Processing suspensions. Give names and collect 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 = HscEnv
-> IORef [String]
-> ClosureType
-> Type
-> ForeignHValue
-> Maybe Name
-> IO (Term, [(Name, Type, ForeignHValue)])
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
                                    tt' <- [IO (Term, [(Name, Type, ForeignHValue)])]
-> IO [(Term, [(Name, Type, ForeignHValue)])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [IO (Term, [(Name, Type, ForeignHValue)])]
tt
                                    let (terms,names) = unzip tt'
                                    return (Term ty dc v terms, concat names)
                      , fPrim :: Type -> [Word] -> IO (Term, [(Name, Type, ForeignHValue)])
fPrim    = \Type
ty [Word]
n ->(Term, [(Name, Type, ForeignHValue)])
-> IO (Term, [(Name, Type, ForeignHValue)])
forall a. a -> IO a
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, names) <- IO (Term, [(Name, Type, ForeignHValue)])
t
                                    return (NewtypeWrap ty dc term, names)
                      , fRefWrap :: Type
-> IO (Term, [(Name, Type, ForeignHValue)])
-> IO (Term, [(Name, Type, ForeignHValue)])
fRefWrap = \Type
ty IO (Term, [(Name, Type, ForeignHValue)])
t -> do
                                    (term, names) <- IO (Term, [(Name, Type, ForeignHValue)])
t
                                    return (RefWrap ty term, 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
          name <- IORef [String] -> ([String] -> ([String], String)) -> IO String
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [String]
freeNames (\[String]
x->([String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail [String]
x, [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
x))
          n <- newGrimName hsc_env name
          return (Suspension ct ty hval (Just n), [(n,ty,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
    dflags       <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
    if gopt Opt_PrintEvldWithShow dflags
       then cPprTerm (liftM2 (++) (\TermPrinterM m
_y->[Int -> Term -> m (Maybe SDoc)
forall {m :: * -> *} {t}.
(GhcMonad m, Ord t, Num t) =>
t -> Term -> m (Maybe SDoc)
cPprShowable]) cPprTermBase) term
       else cPprTerm cPprTermBase 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 Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
forall a. Maybe a
Nothing
     else do
        let set_session :: m (HscEnv, Name)
set_session = do
                hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
                (new_env, bname) <- bindToFreshName hsc_env ty "showme"
                setSession new_env

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

                return (hsc_env, bname)

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

        m (HscEnv, Name)
-> ((HscEnv, Name) -> m ())
-> ((HscEnv, Name) -> m (Maybe SDoc))
-> m (Maybe SDoc)
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket m (HscEnv, Name)
set_session (HscEnv, Name) -> m ()
forall {m :: * -> *} {b}. GhcMonad m => (HscEnv, b) -> m ()
reset_session (((HscEnv, Name) -> m (Maybe SDoc)) -> m (Maybe SDoc))
-> ((HscEnv, Name) -> m (Maybe SDoc)) -> m (Maybe SDoc)
forall a b. (a -> b) -> a -> b
$ \(HscEnv
_,Name
bname) -> do
           hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
           dflags  <- GHC.getSessionDynFlags
           let expr = String
"Prelude.return (Prelude.show " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         DynFlags -> Name -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags Name
bname String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      String
") :: Prelude.IO Prelude.String"
               interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
           txt_ <- withExtendedLoadedEnv interp
                                       [(bname, fhv)]
                                       (GHC.compileExprRemote expr)
           let myprec = t
10 -- application precedence. TODO Infix constructors
           txt <- liftIO $ evalString interp txt_
           if not (null txt) then
             return $ Just $ cparen (prec >= myprec && needsParens txt)
                                    (text txt)
            else return 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=new_ty}
  cPprShowable t
_ Term
_ = Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
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
' ' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
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 <- HscEnv -> String -> m Name
forall (m :: * -> *). MonadIO m => HscEnv -> String -> m Name
newGrimName HscEnv
hsc_env String
userName
    let id       = Name -> Type -> Id
mkVanillaGlobal Name
name Type
ty
        new_ic   = InteractiveContext -> [Id] -> InteractiveContext
extendInteractiveContextWithIds (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) [Id
id]
    return (hsc_env {hsc_IC = new_ic }, 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
  = IO Name -> m Name
forall a. IO a -> m a
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
  dflags  <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  let pcontents = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintBindContents DynFlags
dflags
      pprdId    = (ShowSub -> TyThing -> SDoc
pprTyThing ShowSub
showToHeader (TyThing -> SDoc) -> (Id -> TyThing) -> Id -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> TyThing
AnId) Id
id
  if pcontents
    then do
      let depthBound = Int
100
      -- If the value is an exception, make sure we catch it and
      -- show the exception, rather than propagating the exception out.
      e_term <- MC.try $ GHC.obtainTermFromId depthBound False id
      docs_term <- case e_term of
                      Right Term
term -> Term -> m SDoc
forall (m :: * -> *). GhcMonad m => Term -> m SDoc
showTerm Term
term
                      Left  SomeException
exn  -> SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"*** Exception:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                                            String -> SDoc
forall doc. IsLine doc => String -> doc
text (SomeException -> String
forall a. Show a => a -> String
show (SomeException
exn :: SomeException)))
      return $ pprdId <+> equals <+> docs_term
    else return pprdId