From: Pepe Iborra Date: Wed, 14 Nov 2007 23:16:01 +0000 (+0000) Subject: Try to manage the size of the text rendered for ':show bindings' X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=8bbebfe661bdc976965718a2a489515c4929a03f Try to manage the size of the text rendered for ':show bindings' --- diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 9fbee36..5ae7db8 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 5043d98..30096ab 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 a18deb8..65e210c 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 " 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 9b49b5c..9c2d225 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 85b32e4..d6016b0 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))