Commit 98e14866 authored by mnislaih's avatar mnislaih
Browse files

Print contents of bindings when stopping at a breakpoint

parent 99794f66
......@@ -10,7 +10,7 @@
--
-----------------------------------------------------------------------------
module Debugger (pprintClosureCommand) where
module Debugger (pprintClosureCommand, showTerm) where
import Linker
import RtClosureInspect
......@@ -54,35 +54,40 @@ pprintClosureCommand session bindThings force str = do
mapM (\w -> GHC.parseName session w >>=
mapM (GHC.lookupName session))
(words str)
substs <- catMaybes `liftM` mapM (go session)
[id | AnId id <- tythings]
modifySession session $ \hsc_env ->
hsc_env{hsc_IC = foldr (flip substInteractiveContext)
(hsc_IC hsc_env)
let ids = [id | AnId id <- tythings]
-- Obtain the terms and the recovered type information
(terms, substs) <- unzip `liftM` mapM (go session) ids
-- Apply the substitutions obtained after recovering the types
modifySession session $ \hsc_env ->
hsc_env{hsc_IC = foldr (flip substInteractiveContext)
(hsc_IC hsc_env)
(map skolemiseSubst substs)}
where
-- Finally, print the Terms
unqual <- GHC.getPrintUnqual session
let showSDocForUserOneLine unqual doc =
showDocWith LeftMode (doc (mkErrStyle unqual))
docterms <- mapM (showTerm session) terms
(putStrLn . showSDocForUserOneLine unqual . vcat)
(zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
ids
docterms)
where
-- Do the obtainTerm--bindSuspensions-computeSubstitution dance
go :: Session -> Id -> IO (Maybe TvSubst)
go cms id = do
term_ <- withSession cms $ \hsc_env -> obtainTerm hsc_env force id
go :: Session -> Id -> IO (Term, TvSubst)
go cms id = do
term_ <- GHC.obtainTerm cms force id
term <- tidyTermTyVars cms term_
term' <- if not bindThings then return term
else bindSuspensions cms term
showterm <- printTerm cms term'
unqual <- GHC.getPrintUnqual cms
let showSDocForUserOneLine unqual doc =
showDocWith LeftMode (doc (mkErrStyle unqual))
(putStrLn . showSDocForUserOneLine unqual)
(ppr id <+> char '=' <+> showterm)
term' <- if not bindThings then return term
else bindSuspensions cms term
-- Before leaving, we compare the type obtained to see if it's more specific
-- Then, we extract a substitution,
-- Then, we extract a substitution,
-- mapping the old tyvars to the reconstructed types.
let Just reconstructed_type = termType term
mb_subst = computeRTTIsubst (idType id) (reconstructed_type)
ASSERT2 (isJust mb_subst, ppr reconstructed_type $$ (ppr$ idType id))
return mb_subst
Just subst = computeRTTIsubst (idType id) (reconstructed_type)
return (term',subst)
tidyTermTyVars :: Session -> Term -> IO Term
tidyTermTyVars (Session ref) t = do
......
......@@ -578,7 +578,8 @@ afterRunStmt pred run_result = do
pred (GHC.resumeSpan $ head resumes) -> do
printForUser $ ptext SLIT("Stopped at") <+>
ppr (GHC.resumeSpan $ head resumes)
printTypeOfNames session names
-- printTypeOfNames session names
printTypeAndContentOfNames session names
maybe (return ()) runBreakCmd mb_info
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
......@@ -595,6 +596,18 @@ afterRunStmt pred run_result = do
return (case run_result of GHC.RunOk _ -> True; _ -> False)
where printTypeAndContentOfNames session names = do
let namesSorted = sortBy compareNames names
tythings <- catMaybes `liftM`
io (mapM (GHC.lookupName session) names)
docs_ty <- mapM showTyThing tythings
terms <- mapM (io . GHC.obtainTerm session False)
[ id | (AnId id, Just _) <- zip tythings docs_ty]
docs_terms <- mapM (io . showTerm session) terms
printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts)
(catMaybes docs_ty)
docs_terms
runBreakCmd :: GHC.BreakInfo -> GHCi ()
runBreakCmd info = do
let mod = GHC.breakInfo_module info
......@@ -1276,11 +1289,18 @@ showBindings = do
compareTyThings :: TyThing -> TyThing -> Ordering
t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
printTyThing :: TyThing -> GHCi ()
printTyThing (AnId id) = do
showTyThing :: TyThing -> GHCi (Maybe SDoc)
showTyThing (AnId id) = do
ty' <- cleanType (GHC.idType id)
printForUser $ ppr id <> text " :: " <> ppr ty'
printTyThing _ = return ()
return $ Just $ ppr id <> text " :: " <> ppr ty'
showTyThing _ = return Nothing
printTyThing :: TyThing -> GHCi ()
printTyThing tyth = do
mb_x <- showTyThing tyth
case mb_x of
Just x -> printForUser x
Nothing -> return ()
-- if -fglasgow-exts is on we show the foralls, otherwise we don't.
cleanType :: Type -> GHCi Type
......
......@@ -94,7 +94,7 @@ module GHC (
isModuleInterpreted,
compileExpr, HValue, dynCompileExpr,
lookupName,
obtainTerm, obtainTerm1,
GHC.obtainTerm, GHC.obtainTerm1, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
......@@ -1987,4 +1987,12 @@ findModule' hsc_env mod_name maybe_pkg =
getHistorySpan :: Session -> History -> IO SrcSpan
getHistorySpan sess h = withSession sess $ \hsc_env ->
return$ InteractiveEval.getHistorySpan hsc_env h
obtainTerm :: Session -> Bool -> Id -> IO Term
obtainTerm sess force id = withSession sess $ \hsc_env ->
InteractiveEval.obtainTerm hsc_env force id
obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
obtainTerm1 sess force mb_ty a = withSession sess $ \hsc_env ->
InteractiveEval.obtainTerm1 hsc_env force mb_ty a
#endif
......@@ -29,7 +29,7 @@ module InteractiveEval (
isModuleInterpreted,
compileExpr, dynCompileExpr,
lookupName,
obtainTerm, obtainTerm1, reconstructType,
Term(..), obtainTerm, obtainTerm1, reconstructType,
skolemiseSubst, skolemiseTy
#endif
) where
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment