From 68a8c3bbab3a77a982fcac980e69f47b4ec13dfd Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 15 Aug 2007 16:11:30 +0000 Subject: [PATCH] Teach :history to show the name of the enclosing declaration together with src locs Purely for convenience and user friendliness --- compiler/ghci/InteractiveUI.hs | 11 +++++--- compiler/main/GHC.hs | 9 ++++++- compiler/main/InteractiveEval.hs | 55 +++++++++++++++++++++++++++++--------- 3 files changed, 58 insertions(+), 17 deletions(-) diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 22b8211..aacf8b3 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -464,7 +464,7 @@ mkPrompt = do then return (brackets (ppr (GHC.resumeSpan r)) <> space) else do let hist = GHC.resumeHistory r !! (ix-1) - span <- io $ GHC.getHistorySpan session hist + span <- io$ GHC.getHistorySpan session hist return (brackets (ppr (negate ix) <> char ':' <+> ppr span) <> space) let @@ -1647,8 +1647,13 @@ historyCmd arg let hist = GHC.resumeHistory r (took,rest) = splitAt num hist spans <- mapM (io . GHC.getHistorySpan s) took - let nums = map (printf "-%-3d:") [(1::Int)..] - printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans))) + let nums = map (printf "-%-3d:") [(1::Int)..] + let names = map GHC.historyEnclosingDecl took + printForUser (vcat(zipWith3 + (\x y z -> x <+> y <+> z) + (map text nums) + (map (ftext . occNameFS . nameOccName) names) + (map (parens . ppr) spans))) io $ putStrLn $ if null rest then "" else "..." backCmd :: String -> GHCi () diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index a95c36c..506a839 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -84,7 +84,8 @@ module GHC ( resume, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, resumeHistory, resumeHistoryIx), - History(historyBreakInfo), getHistorySpan, getHistoryModule, + History(historyBreakInfo, historyEnclosingDecl), + GHC.getHistorySpan, getHistoryModule, getResumeContext, abandon, abandonAll, InteractiveEval.back, @@ -1974,3 +1975,9 @@ findModule' hsc_env mod_name maybe_pkg = text "is not loaded")) err -> let msg = cannotFindModule dflags mod_name err in throwDyn (CmdLineError (showSDoc msg)) + +#ifdef GHCI +getHistorySpan :: Session -> History -> IO SrcSpan +getHistorySpan sess h = withSession sess $ \hsc_env -> + return$ InteractiveEval.getHistorySpan hsc_env h +#endif \ No newline at end of file diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 069a829..901dd63 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -70,6 +70,7 @@ import BasicTypes import Outputable import Data.Dynamic +import Data.List (find) import Control.Monad import Foreign import Foreign.C @@ -129,20 +130,47 @@ isStep _ = True data History = History { historyApStack :: HValue, - historyBreakInfo :: BreakInfo + historyBreakInfo :: BreakInfo, + historyEnclosingDecl :: Name + -- ^^ A cache of the enclosing declaration, for convenience } -getHistoryModule :: History -> Module +mkHistory :: HscEnv -> HValue -> BreakInfo -> History +mkHistory hsc_env hval bi = let + h = History hval bi decl + decl = findEnclosingDecl hsc_env (getHistoryModule h) + (getHistorySpan hsc_env h) + in h + +getHistoryModule :: History -> Module getHistoryModule = breakInfo_module . historyBreakInfo -getHistorySpan :: Session -> History -> IO SrcSpan -getHistorySpan s hist = withSession s $ \hsc_env -> do - let inf = historyBreakInfo hist +getHistorySpan :: HscEnv -> History -> SrcSpan +getHistorySpan hsc_env hist = + let inf = historyBreakInfo hist num = breakInfo_number inf - case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of - Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num) + in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of + Just hmi -> modBreaks_locs (md_modBreaks (hm_details hmi)) ! num _ -> panic "getHistorySpan" +findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Name +findEnclosingDecl hsc_env mod span = + case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of + Nothing -> panic "findEnclosingDecl" + Just hmi -> let + globals = typeEnvIds (md_types (hm_details hmi)) + Just decl = find (\n -> nameSrcSpan n < span) + (reverse $ map idName globals) + -- ^^ assumes md_types is sorted + in decl + +-- | Find the Module corresponding to a FilePath +findModuleFromFile :: HscEnv -> FilePath -> Maybe Module +findModuleFromFile hsc_env fp = + listToMaybe $ [ms_mod ms | ms <- hsc_mod_graph hsc_env + , ml_hs_file(ms_location ms) == Just (read fp)] + + -- | Run a statement in the current interactive context. Statement -- may bind multple values. runStmt :: Session -> String -> SingleStep -> IO RunResult @@ -227,7 +255,7 @@ traceRunStatus expr ref bindings final_ids if b then handle_normally else do - let history' = consBL (History apStack info) history + let history' = mkHistory hsc_env apStack info `consBL` history -- probably better make history strict here, otherwise -- our BoundedList will be pointless. evaluate history' @@ -371,10 +399,11 @@ resume (Session ref) step return tid) (takeMVar statusMVar) -- and wait for the result - let hist' = case info of - Nothing -> fromListBL 50 hist - Just i -> History apStack i `consBL` - fromListBL 50 hist + let hist' = + case info of + Nothing -> fromListBL 50 hist + Just i -> mkHistory hsc_env apStack i `consBL` + fromListBL 50 hist case step of RunAndLogSteps -> traceRunStatus expr ref bindings final_ids @@ -425,7 +454,7 @@ moveHist fn (Session ref) = do resumeBreakInfo = mb_info } -> update_ic apStack mb_info else case history !! (new_ix - 1) of - History apStack info -> + History apStack info _ -> update_ic apStack (Just info) -- ----------------------------------------------------------------------------- -- 1.7.10.4