From 98e1486635c889e023097d63da0c9b68393de1fd Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 26 Aug 2007 21:33:39 +0000 Subject: [PATCH] Print contents of bindings when stopping at a breakpoint --- compiler/ghci/Debugger.hs | 51 +++++++++++++++++++++----------------- compiler/ghci/InteractiveUI.hs | 30 ++++++++++++++++++---- compiler/main/GHC.hs | 10 +++++++- compiler/main/InteractiveEval.hs | 2 +- 4 files changed, 63 insertions(+), 30 deletions(-) diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 20bdbf6..0b75dd0 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -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 diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index d7de940..dffae16 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -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 " 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 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 1fc3605..8df066c 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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 diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 3173278..56dfbbd 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -29,7 +29,7 @@ module InteractiveEval ( isModuleInterpreted, compileExpr, dynCompileExpr, lookupName, - obtainTerm, obtainTerm1, reconstructType, + Term(..), obtainTerm, obtainTerm1, reconstructType, skolemiseSubst, skolemiseTy #endif ) where -- 1.7.10.4