--
-----------------------------------------------------------------------------
-module Debugger (pprintClosureCommand, showTerm) where
+module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
import Linker
import RtClosureInspect
import DynFlags
import InteractiveEval
import Outputable
-import Pretty ( Mode(..), showDocWith )
import SrcLoc
+import PprTyThing
import Control.Exception
import Control.Monad
(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)
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
#include "HsVersions.h"
import qualified GHC
-import Outputable hiding (printForUser)
+import Outputable hiding (printForUser, printForUserPartWay)
import qualified Outputable
import Panic hiding (showException)
import Util
import SrcLoc
import Module
import ObjLink
+import StaticFlags
import Data.Maybe
import Numeric
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
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
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
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
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
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
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
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,
speakNth, speakNTimes, speakN, speakNOf, plural,
printSDoc, printErrs, hPrintDump, printDump,
- printForC, printForAsm, printForUser,
+ printForC, printForAsm, printForUser, printForUserPartWay,
pprCode, mkCodeStyle,
showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
showSDocUnqual, showsPrecSDoc,
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))