module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
import GhcPrelude
import Linker
import RtClosureInspect
import GHCi
import GHCi.RemoteTypes
import GhcMonad
import HscTypes
import Id
import IfaceSyn ( showToHeader )
import IfaceEnv( newInteractiveBinder )
import Name
import Var hiding ( varName )
import VarSet
import UniqSet
import Type
import GHC
import Outputable
import PprTyThing
import ErrUtils
import MonadUtils
import DynFlags
import Exception
import Control.Monad
import Data.List
import Data.Maybe
import Data.IORef
import GHC.Exts
pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
pprintClosureCommand bindThings force str = do
tythings <- (catMaybes . concat) `liftM`
mapM (\w -> GHC.parseName w >>=
mapM GHC.lookupName)
(words str)
let ids = [id | AnId id <- tythings]
(subst, terms) <- mapAccumLM go emptyTCvSubst ids
modifySession $ \hsc_env ->
hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
unqual <- GHC.getPrintUnqual
docterms <- mapM showTerm terms
dflags <- getDynFlags
liftIO $ (printOutputForUser dflags unqual . vcat)
(zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
ids
docterms)
where
go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term)
go subst id = do
let id' = id `setIdType` substTy subst (idType id)
term_ <- GHC.obtainTermFromId maxBound force id'
term <- tidyTermTyVars term_
term' <- if bindThings &&
(not (isUnliftedType (termType term)))
then bindSuspensions term
else return term
let reconstructed_type = termType term
hsc_env <- getSession
case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of
Nothing -> return (subst, term')
Just subst' -> do { traceOptIf Opt_D_dump_rtti
(fsep $ [text "RTTI Improvement for", ppr id,
text "is the substitution:" , ppr subst'])
; return (subst `unionTCvSubst` subst', term')}
tidyTermTyVars :: GhcMonad m => Term -> m Term
tidyTermTyVars t =
withSession $ \hsc_env -> do
let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env
my_tvs = termTyCoVars t
tvs = env_tvs `minusVarSet` my_tvs
tyvarOccName = nameOccName . tyVarName
tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs))
, getUniqSet $ env_tvs `intersectVarSet` my_tvs)
return $ mapTermType (snd . tidyOpenType tidyEnv) t
bindSuspensions :: GhcMonad m => Term -> m Term
bindSuspensions t = do
hsc_env <- getSession
inScope <- GHC.getBindings
let ictxt = hsc_IC hsc_env
prefix = "_t"
alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
availNames_var <- liftIO $ newIORef availNames
(t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
let (names, tys, hvals) = unzip3 stuff
let ids = [ mkVanillaGlobal name ty
| (name,ty) <- zip names tys]
new_ic = extendInteractiveContextWithIds ictxt ids
fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) hvals
liftIO $ extendLinkEnv (zip names fhvs)
setSession hsc_env {hsc_IC = new_ic }
return t'
where
nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]
-> TermFold (IO (Term, [(Name,Type,HValue)]))
nameSuspensionsAndGetInfos hsc_env freeNames = TermFold
{
fSuspension = doSuspension hsc_env freeNames
, fTerm = \ty dc v tt -> do
tt' <- sequence tt
let (terms,names) = unzip tt'
return (Term ty dc v terms, concat names)
, fPrim = \ty n ->return (Prim ty n,[])
, fNewtypeWrap =
\ty dc t -> do
(term, names) <- t
return (NewtypeWrap ty dc term, names)
, fRefWrap = \ty t -> do
(term, names) <- t
return (RefWrap ty term, names)
}
doSuspension hsc_env freeNames ct ty hval _name = do
name <- atomicModifyIORef' freeNames (\x->(tail x, head x))
n <- newGrimName hsc_env name
return (Suspension ct ty hval (Just n), [(n,ty,hval)])
showTerm :: GhcMonad m => Term -> m SDoc
showTerm term = do
dflags <- GHC.getSessionDynFlags
if gopt Opt_PrintEvldWithShow dflags
then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
else cPprTerm cPprTermBase term
where
cPprShowable prec t@Term{ty=ty, val=val} =
if not (isFullyEvaluatedTerm t)
then return Nothing
else do
hsc_env <- getSession
dflags <- GHC.getSessionDynFlags
do
(new_env, bname) <- bindToFreshName hsc_env ty "showme"
setSession new_env
let noop_log _ _ _ _ _ _ = return ()
expr = "show " ++ showPpr dflags bname
_ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val
txt_ <- withExtendedLinkEnv [(bname, fhv)]
(GHC.compileExpr expr)
let myprec = 10
let txt = unsafeCoerce# txt_ :: [a]
if not (null txt) then
return $ Just $ cparen (prec >= myprec && needsParens txt)
(text txt)
else return Nothing
`gfinally` do
setSession hsc_env
GHC.setSessionDynFlags dflags
cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
cPprShowable prec t{ty=new_ty}
cPprShowable _ _ = return Nothing
needsParens ('"':_) = False
needsParens ('(':_) = False
needsParens txt = ' ' `elem` txt
bindToFreshName hsc_env ty userName = do
name <- newGrimName hsc_env userName
let id = mkVanillaGlobal name ty
new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]
return (hsc_env {hsc_IC = new_ic }, name)
newGrimName :: MonadIO m => HscEnv -> String -> m Name
newGrimName hsc_env userName
= liftIO (newInteractiveBinder hsc_env occ noSrcSpan)
where
occ = mkOccName varName userName
pprTypeAndContents :: GhcMonad m => Id -> m SDoc
pprTypeAndContents id = do
dflags <- GHC.getSessionDynFlags
let pcontents = gopt Opt_PrintBindContents dflags
pprdId = (pprTyThing showToHeader . AnId) id
if pcontents
then do
let depthBound = 100
e_term <- gtry $ GHC.obtainTermFromId depthBound False id
docs_term <- case e_term of
Right term -> showTerm term
Left exn -> return (text "*** Exception:" <+>
text (show (exn :: SomeException)))
return $ pprdId <+> equals <+> docs_term
else return pprdId
traceOptIf :: GhcMonad m => DumpFlag -> SDoc -> m ()
traceOptIf flag doc = do
dflags <- GHC.getSessionDynFlags
when (dopt flag dflags) $ liftIO $ printInfoForUser dflags alwaysQualify doc