Try to manage the size of the text rendered for ':show bindings'

5 files changed, 43 insertions, 28 deletions

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 9fbee36b94..5ae7db8caa 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -10,7 +10,7 @@
 -- 
 -----------------------------------------------------------------------------
 
-module Debugger (pprintClosureCommand, showTerm) where
+module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
 
 import Linker
 import RtClosureInspect
@@ -28,8 +28,8 @@ import GHC
 import DynFlags
 import InteractiveEval
 import Outputable
-import Pretty                    ( Mode(..), showDocWith )
 import SrcLoc
+import PprTyThing
 
 import Control.Exception
 import Control.Monad
@@ -61,10 +61,8 @@ pprintClosureCommand session bindThings force str = do
                                 (map skolemiseSubst substs)}
   -- 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)
+  (printForUser stdout unqual . vcat)
         (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
                  ids
                  docterms)
@@ -199,3 +197,18 @@ newGrimName userName  = do
         occname = mkOccName varName userName
         name    = mkInternalName unique occname noSrcSpan
     return name
+
+pprTypeAndContents :: Session -> [Id] -> IO SDoc
+pprTypeAndContents session ids = do
+  dflags  <- GHC.getSessionDynFlags session
+  let pefas     = dopt Opt_PrintExplicitForalls dflags
+      pcontents = dopt Opt_PrintBindContents dflags
+  if pcontents 
+    then do
+      let depthBound = 100
+      terms      <- mapM (GHC.obtainTermB session depthBound False) ids
+      docs_terms <- mapM (showTerm session) terms
+      return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
+                             (map (pprTyThing pefas . AnId) ids)
+                             docs_terms
+    else return $  vcat $ map (pprTyThing pefas . AnId) ids
diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs
index 5043d983ac..30096ab3be 100644
--- a/compiler/ghci/GhciMonad.hs
+++ b/compiler/ghci/GhciMonad.hs
@@ -18,7 +18,7 @@ module GhciMonad where
 #include "HsVersions.h"
 
 import qualified GHC
-import Outputable       hiding (printForUser)
+import Outputable       hiding (printForUser, printForUserPartWay)
 import qualified Outputable
 import Panic            hiding (showException)
 import Util
@@ -27,6 +27,7 @@ import HscTypes
 import SrcLoc
 import Module
 import ObjLink
+import StaticFlags
 
 import Data.Maybe
 import Numeric
@@ -169,6 +170,12 @@ printForUser doc = do
   unqual <- io (GHC.getPrintUnqual session)
   io $ Outputable.printForUser stdout unqual doc
 
+printForUserPartWay :: SDoc -> GHCi ()
+printForUserPartWay doc = do
+  session <- getSession
+  unqual <- io (GHC.getPrintUnqual session)
+  io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
+
 -- --------------------------------------------------------------------------
 -- timing & statistics
 
diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index a18deb8c9f..65e210cde8 100644
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -19,7 +19,7 @@ import Debugger
 import qualified GHC
 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
                           Module, ModuleName, TyThing(..), Phase,
-                          BreakIndex, SrcSpan, Resume, SingleStep, Id )
+                          BreakIndex, SrcSpan, Resume, SingleStep )
 import PprTyThing
 import DynFlags
 
@@ -31,7 +31,7 @@ import UniqFM
 
 import HscTypes		( implicitTyThings )
 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
-import Outputable       hiding (printForUser)
+import Outputable       hiding (printForUser, printForUserPartWay)
 import Module           -- for ModuleEnv
 import Name
 import SrcLoc
@@ -657,8 +657,8 @@ afterRunStmt step_here run_result = do
                let namesSorted = sortBy compareNames names
                tythings <- catMaybes `liftM` 
                               io (mapM (GHC.lookupName session) namesSorted)
-
-               printTypeAndContents session [id | AnId id <- tythings]
+               docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
+               printForUserPartWay docs
                maybe (return ()) runBreakCmd mb_info
                -- run the command set with ":set stop <cmd>"
                st <- getGHCiState
@@ -702,20 +702,7 @@ printTypeOfName session n
             Nothing    -> return ()
             Just thing -> printTyThing thing
 
-printTypeAndContents :: Session -> [Id] -> GHCi ()
-printTypeAndContents session ids = do
-  dflags <- getDynFlags
-  let pefas     = dopt Opt_PrintExplicitForalls dflags
-      pcontents = dopt Opt_PrintBindContents dflags
-  if pcontents 
-    then do
-      let depthBound = 100
-      terms      <- mapM (io . GHC.obtainTermB session depthBound False) ids
-      docs_terms <- mapM (io . showTerm session) terms
-      printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
-                                    (map (pprTyThing pefas . AnId) ids)
-                                    docs_terms
-    else printForUser $ vcat $ map (pprTyThing pefas . AnId) ids
+
 
 
 specialCommand :: String -> GHCi Bool
@@ -1483,7 +1470,9 @@ showBindings :: GHCi ()
 showBindings = do
   s <- getSession
   bindings <- io (GHC.getBindings s)
-  printTypeAndContents s [ id | AnId id <- sortBy compareTyThings bindings]
+  docs     <- io$ pprTypeAndContents s 
+                  [ id | AnId id <- sortBy compareTyThings bindings]
+  printForUserPartWay docs
 
 compareTyThings :: TyThing -> TyThing -> Ordering
 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 9b49b5c69c..9c2d225d41 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -440,7 +440,7 @@ cPprTermBase y =
 
            coerceShow f _p = return . text . show . f . unsafeCoerce# . val
 
-           --TODO pprinting of list terms is not lazy
+           --NOTE pprinting of list terms is not lazy
            doList p h t = do
                let elems      = h : getListTerms t
                    isConsLast = termType(last elems) /= termType h
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 85b32e46c3..d6016b0a72 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -12,12 +12,14 @@ module Outputable (
 
 	BindingSite(..),
 
-	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, QualifyName(..),
+	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
+        QualifyName(..),
 	getPprStyle, withPprStyle, withPprStyleDoc, 
 	pprDeeper, pprDeeperList, pprSetDepth,
 	codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
 	ifPprDebug, qualName, qualModule,
 	mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
+        mkUserStyle,
 
 	SDoc, 		-- Abstract
 	docToSDoc,
@@ -36,7 +38,7 @@ module Outputable (
 	speakNth, speakNTimes, speakN, speakNOf, plural,
 
 	printSDoc, printErrs, hPrintDump, printDump,
-	printForC, printForAsm, printForUser,
+	printForC, printForAsm, printForUser, printForUserPartWay,
 	pprCode, mkCodeStyle,
 	showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
 	showSDocUnqual, showsPrecSDoc,
@@ -286,6 +288,10 @@ printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 printForUser handle unqual doc 
   = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
 
+printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
+printForUserPartWay handle d unqual doc
+  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
+
 -- printForC, printForAsm do what they sound like
 printForC :: Handle -> SDoc -> IO ()
 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))