-----------------------------------------------------------------------------
--
-- 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.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
  [TyThing]
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 ([TyThing]
pprintables, [TyThing]
unpprintables) = (TyThing -> Bool) -> [TyThing] -> ([TyThing], [TyThing])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyThing -> Bool
can_pprint [TyThing]
tythings

  -- Obtain the terms and the recovered type information
  let ids :: [Id]
ids = [Id
id | AnId Id
id <- [TyThing]
pprintables]
  (Subst
subst, [Term]
terms) <- (Subst -> Id -> m (Subst, Term))
-> Subst -> [Id] -> m (Subst, [Term])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM Subst -> Id -> m (Subst, Term)
forall (m :: * -> *). GhcMonad m => Subst -> Id -> m (Subst, Term)
go Subst
emptySubst [Id]
ids

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

  -- Finally, print the Results
  [SDoc]
docterms <- (Term -> m SDoc) -> [Term] -> m [SDoc]
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 Term -> m SDoc
forall (m :: * -> *). GhcMonad m => Term -> m SDoc
showTerm [Term]
terms
  let sdocTerms :: [SDoc]
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
  [SDoc] -> m ()
forall (m :: * -> *). GhcMonad m => [SDoc] -> m ()
printSDocs ([SDoc] -> m ()) -> [SDoc] -> m ()
forall a b. (a -> b) -> a -> b
$ (TyThing -> SDoc
no_pprint (TyThing -> SDoc) -> [TyThing] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyThing]
unpprintables) [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
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
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
      NamePprCtx
name_ppr_ctx <- m NamePprCtx
forall (m :: * -> *). GhcMonad m => m NamePprCtx
GHC.getNamePprCtx
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> NamePprCtx -> SDoc -> IO ()
printOutputForUser Logger
logger NamePprCtx
name_ppr_ctx (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc]
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 ((() :: Constraint) => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst) Id
id
           id_ty' :: Type
id_ty' = Id -> Type
idType Id
id'
       Term
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
term     <- Term -> m Term
forall (m :: * -> *). GhcMonad m => Term -> m Term
tidyTermTyVars Term
term_
       Term
term'    <- if Bool
bindThings
                     then Term -> m Term
forall (m :: * -> *). GhcMonad m => Term -> m Term
bindSuspensions Term
term
                     else Term -> m Term
forall a. a -> m a
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 <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
       case (HscEnv -> Type -> Type -> Maybe Subst
improveRTTIType HscEnv
hsc_env Type
id_ty' Type
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
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
                           ; IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
                               Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_rtti String
"RTTI"
                                 DumpFormat
FormatText
                                 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RTTI Improvement for", Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id,
                                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"old substitution:" , Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Subst
subst,
                                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"new substitution:" , Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Subst
subst'])
                           ; (Subst, Term) -> m (Subst, Term)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Subst
subst Subst -> Subst -> Subst
`unionSubst` Subst
subst', Term
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
      HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
      [TyThing]
inScope <- m [TyThing]
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 = (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]
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
      IORef [String]
availNames_var  <- IO (IORef [String]) -> m (IORef [String])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [String]) -> m (IORef [String]))
-> IO (IORef [String]) -> m (IORef [String])
forall a b. (a -> b) -> a -> b
$ [String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
newIORef [String]
availNames
      (Term
t', [(Name, Type, ForeignHValue)]
stuff)     <- IO (Term, [(Name, Type, ForeignHValue)])
-> m (Term, [(Name, Type, ForeignHValue)])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Term, [(Name, Type, ForeignHValue)])
 -> m (Term, [(Name, Type, ForeignHValue)]))
-> IO (Term, [(Name, Type, ForeignHValue)])
-> m (Term, [(Name, Type, ForeignHValue)])
forall a b. (a -> b) -> a -> b
$ TermFold (IO (Term, [(Name, Type, ForeignHValue)]))
-> Term -> IO (Term, [(Name, Type, ForeignHValue)])
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) = [(Name, Type, ForeignHValue)] -> ([Name], [Type], [ForeignHValue])
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) <- [Name] -> [Type] -> [(Name, Type)]
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
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Interp -> [(Name, ForeignHValue)] -> IO ()
extendLoadedEnv Interp
interp ([Name] -> [ForeignHValue] -> [(Name, ForeignHValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
names [ForeignHValue]
fhvs)
      HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env {hsc_IC = new_ic }
      Term -> m Term
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
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
                                    [(Term, [(Name, Type, ForeignHValue)])]
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 ([Term]
terms,[[(Name, Type, ForeignHValue)]]
names) = [(Term, [(Name, Type, ForeignHValue)])]
-> ([Term], [[(Name, Type, ForeignHValue)]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Term, [(Name, Type, ForeignHValue)])]
tt'
                                    (Term, [(Name, Type, ForeignHValue)])
-> IO (Term, [(Name, Type, ForeignHValue)])
forall a. a -> IO a
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, [[(Name, Type, ForeignHValue)]] -> [(Name, Type, ForeignHValue)]
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 ->(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
term, [(Name, Type, ForeignHValue)]
names) <- IO (Term, [(Name, Type, ForeignHValue)])
t
                                    (Term, [(Name, Type, ForeignHValue)])
-> IO (Term, [(Name, Type, ForeignHValue)])
forall a. a -> IO a
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
                                    (Term, [(Name, Type, ForeignHValue)])
-> IO (Term, [(Name, Type, ForeignHValue)])
forall a. a -> IO a
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 <- 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))
          Name
n <- HscEnv -> String -> IO Name
forall (m :: * -> *). MonadIO m => HscEnv -> String -> m Name
newGrimName HscEnv
hsc_env String
name
          (Term, [(Name, Type, ForeignHValue)])
-> IO (Term, [(Name, Type, ForeignHValue)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct Type
ty ForeignHValue
hval (Name -> Maybe Name
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       <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
    if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintEvldWithShow DynFlags
dflags
       then CustomTermPrinter m -> Term -> m SDoc
forall (m :: * -> *).
Monad m =>
CustomTermPrinter m -> Term -> m SDoc
cPprTerm (([Int -> Term -> m (Maybe SDoc)]
 -> [Int -> Term -> m (Maybe SDoc)]
 -> [Int -> Term -> m (Maybe SDoc)])
-> CustomTermPrinter m
-> CustomTermPrinter m
-> CustomTermPrinter m
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [Int -> Term -> m (Maybe SDoc)]
-> [Int -> Term -> m (Maybe SDoc)]
-> [Int -> Term -> m (Maybe SDoc)]
forall a. [a] -> [a] -> [a]
(++) (\TermPrinterM m
_y->[Int -> Term -> m (Maybe SDoc)
forall {m :: * -> *} {t}.
(GhcMonad m, Ord t, Num t) =>
t -> Term -> m (Maybe SDoc)
cPprShowable]) CustomTermPrinter m
forall (m :: * -> *). Monad m => CustomTermPrinter m
cPprTermBase) Term
term
       else CustomTermPrinter m -> Term -> m SDoc
forall (m :: * -> *).
Monad m =>
CustomTermPrinter m -> Term -> m SDoc
cPprTerm CustomTermPrinter m
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 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
                HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
                (HscEnv
new_env, Name
bname) <- HscEnv -> Type -> String -> m (HscEnv, Name)
forall {m :: * -> *}.
MonadIO m =>
HscEnv -> Type -> String -> m (HscEnv, Name)
bindToFreshName HscEnv
hsc_env Type
ty String
"showme"
                HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
new_env

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

                (HscEnv, Name) -> m (HscEnv, Name)
forall a. a -> m a
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
_) = 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
           HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
           DynFlags
dflags  <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
           let expr :: String
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 :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
           ForeignHValue
txt_ <- Interp
-> [(Name, ForeignHValue)] -> m ForeignHValue -> m ForeignHValue
forall (m :: * -> *) a.
ExceptionMonad m =>
Interp -> [(Name, ForeignHValue)] -> m a -> m a
withExtendedLoadedEnv Interp
interp
                                       [(Name
bname, ForeignHValue
fhv)]
                                       (String -> m ForeignHValue
forall (m :: * -> *). GhcMonad m => String -> m ForeignHValue
GHC.compileExprRemote String
expr)
           let myprec :: t
myprec = t
10 -- application precedence. TODO Infix constructors
           String
txt <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ Interp -> ForeignHValue -> IO String
evalString Interp
interp ForeignHValue
txt_
           if Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
txt) then
             Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SDoc -> m (Maybe SDoc)) -> Maybe SDoc -> m (Maybe SDoc)
forall a b. (a -> b) -> a -> b
$ SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (t
prec t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= t
myprec Bool -> Bool -> Bool
&& String -> Bool
needsParens String
txt)
                                    (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
txt)
            else 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

  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
name <- HscEnv -> String -> m 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]
    (HscEnv, Name) -> m (HscEnv, Name)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env {hsc_IC = 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
  = 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
  DynFlags
dflags  <- m DynFlags
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 (TyThing -> SDoc) -> (Id -> TyThing) -> Id -> SDoc
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 <- m Term -> m (Either SomeException Term)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try (m Term -> m (Either SomeException Term))
-> m Term -> m (Either SomeException Term)
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> Id -> m Term
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 -> 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)))
      SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc
pprdId SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
docs_term
    else SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
pprdId