Print contents of bindings when stopping at a breakpoint

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 20bdbf6..0b75dd0 100644 (file)
--- 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 (file)
--- 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 <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

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 1fc3605..8df066c 100644 (file)
--- 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 (file)
--- 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