-----------------------------------------------------------------------------
--
-- 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.Data.List.Infinite (Infinite (..))
import qualified GHC.Data.List.Infinite as Inf

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
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   = ((String -> Bool) -> Infinite String -> Infinite String
forall a. (a -> Bool) -> Infinite a -> Infinite a
Inf.filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
alreadyUsedNames) (Infinite String -> Infinite String)
-> (Infinite Int -> Infinite String)
-> Infinite Int
-> Infinite String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> String) -> Infinite Int -> Infinite String
forall a b. (a -> b) -> Infinite a -> Infinite b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((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 -> Infinite Int
forall a. Enum a => a -> Infinite a
Inf.enumFrom (Int
1::Int))
      availNames_var  <- liftIO $ newIORef availNames
      (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
      let (names, tys, fhvs) = unzip3 stuff
      let ids = [ HasDebugCallStack => Name -> Type -> Id
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 (Infinite String)
                                   -> TermFold (IO (Term, [(Name,Type,ForeignHValue)]))
        nameSuspensionsAndGetInfos :: HscEnv
-> IORef (Infinite String)
-> TermFold (IO (Term, [(Name, Type, ForeignHValue)]))
nameSuspensionsAndGetInfos HscEnv
hsc_env IORef (Infinite String)
freeNames = TermFold
                      {
                        fSuspension :: ClosureType
-> Type
-> ForeignHValue
-> Maybe Name
-> IO (Term, [(Name, Type, ForeignHValue)])
fSuspension = HscEnv
-> IORef (Infinite String)
-> ClosureType
-> Type
-> ForeignHValue
-> Maybe Name
-> IO (Term, [(Name, Type, ForeignHValue)])
forall {p}.
HscEnv
-> IORef (Infinite String)
-> ClosureType
-> Type
-> ForeignHValue
-> p
-> IO (Term, [(Name, Type, ForeignHValue)])
doSuspension HscEnv
hsc_env IORef (Infinite 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 (Infinite String)
-> ClosureType
-> Type
-> ForeignHValue
-> p
-> IO (Term, [(Name, Type, ForeignHValue)])
doSuspension HscEnv
hsc_env IORef (Infinite String)
freeNames ClosureType
ct Type
ty ForeignHValue
hval p
_name = do
          name <- IORef (Infinite String)
-> (Infinite String -> (Infinite String, String)) -> IO String
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Infinite String)
freeNames (\(Inf String
x Infinite String
xs)->(Infinite String
xs, 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       = HasDebugCallStack => Name -> Type -> 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