summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/CmmToAsm.hs7
-rw-r--r--compiler/GHC/CmmToLlvm/Base.hs4
-rw-r--r--compiler/GHC/Driver/Session.hs11
-rw-r--r--compiler/GHC/Driver/Session.hs-boot1
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs3
-rw-r--r--compiler/main/ErrUtils.hs25
-rw-r--r--compiler/utils/Outputable.hs40
7 files changed, 49 insertions, 42 deletions
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
index 4ccdad826d..558d422ba1 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -387,7 +387,8 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)
-- write out the imports
- printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle)
+ let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)
+ printSDocLn ctx Pretty.LeftMode h
$ makeImportsDoc dflags (concat (ngs_imports ngs))
return us'
where
@@ -516,8 +517,8 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()
emitNativeCode dflags h sdoc = do
- {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h
- (mkCodeStyle AsmStyle) sdoc
+ let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)
+ {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc
-- dump native code
dumpIfSet_dyn dflags
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index 981535e993..b36b4814f1 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -447,8 +447,8 @@ renderLlvm sdoc = do
-- Write to output
dflags <- getDynFlags
out <- getEnv envOutput
- liftIO $ Outp.bufLeftRenderSDoc dflags out
- (Outp.mkCodeStyle Outp.CStyle) sdoc
+ let ctx = initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle)
+ liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc
-- Dump, if requested
dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 5ed6e093d7..8f64966131 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -230,7 +230,7 @@ module GHC.Driver.Session (
IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,
-- * SDoc
- initSDocContext,
+ initSDocContext, initDefaultSDocContext,
-- * Make use of the Cmm CFG
CfgWeights(..)
@@ -1588,7 +1588,8 @@ defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
defaultLogActionHPutStrDoc dflags h d sty
-- Don't add a newline at the end, so that successive
-- calls to this log-action can output all on the same line
- = printSDoc Pretty.PageMode dflags h sty d
+ = printSDoc ctx Pretty.PageMode h d
+ where ctx = initSDocContext dflags sty
newtype FlushOut = FlushOut (IO ())
@@ -5184,7 +5185,7 @@ emptyFilesToClean :: FilesToClean
emptyFilesToClean = FilesToClean Set.empty Set.empty
-
+-- | Initialize the pretty-printing options
initSDocContext :: DynFlags -> PprStyle -> SDocContext
initSDocContext dflags style = SDC
{ sdocStyle = style
@@ -5220,3 +5221,7 @@ initSDocContext dflags style = SDC
, sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags
, sdocDynFlags = dflags
}
+
+-- | Initialize the pretty-printing options using the default user style
+initDefaultSDocContext :: DynFlags -> SDocContext
+initDefaultSDocContext dflags = initSDocContext dflags (defaultUserStyle dflags)
diff --git a/compiler/GHC/Driver/Session.hs-boot b/compiler/GHC/Driver/Session.hs-boot
index 23458ee1eb..2bc44dc3c6 100644
--- a/compiler/GHC/Driver/Session.hs-boot
+++ b/compiler/GHC/Driver/Session.hs-boot
@@ -8,7 +8,6 @@ data DynFlags
targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
-pprCols :: DynFlags -> Int
unsafeGlobalDynFlags :: DynFlags
hasPprDebug :: DynFlags -> Bool
hasNoDebugOutput :: DynFlags -> Bool
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 4f00de2427..5156bb0aa1 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1342,8 +1342,9 @@ gen_data dflags data_type_name constr_names loc rep_tc
L loc (TypeSig noExtField [L loc data_type_name] sig_ty))
sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
+ ctx = initDefaultSDocContext dflags
rhs = nlHsVar mkDataType_RDR
- `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
+ `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr rep_tc)))
`nlHsApp` nlList (map nlHsVar constr_names)
genDataDataCon :: DataCon -> RdrName -> DerivStuff
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 0096891e54..2a4168302b 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -729,12 +729,13 @@ withTiming' dflags what force_result prtimings action
then do whenPrintTimings $
logInfo dflags (defaultUserStyle dflags) $
text "***" <+> what <> colon
- eventBegins dflags what
+ let ctx = initDefaultSDocContext dflags
+ eventBegins ctx what
alloc0 <- liftIO getAllocationCounter
start <- liftIO getCPUTime
!r <- action
() <- pure $ force_result r
- eventEnds dflags what
+ eventEnds ctx what
end <- liftIO getCPUTime
alloc1 <- liftIO getAllocationCounter
-- recall that allocation counter counts down
@@ -753,7 +754,7 @@ withTiming' dflags what force_result prtimings action
whenPrintTimings $
dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText
- $ text $ showSDocOneLine dflags
+ $ text $ showSDocOneLine ctx
$ hsep [ what <> colon
, text "alloc=" <> ppr alloc
, text "time=" <> doublePrec 3 time
@@ -762,15 +763,15 @@ withTiming' dflags what force_result prtimings action
else action
where whenPrintTimings = liftIO . when (prtimings == PrintTimings)
- eventBegins dflags w = do
- whenPrintTimings $ traceMarkerIO (eventBeginsDoc dflags w)
- liftIO $ traceEventIO (eventBeginsDoc dflags w)
- eventEnds dflags w = do
- whenPrintTimings $ traceMarkerIO (eventEndsDoc dflags w)
- liftIO $ traceEventIO (eventEndsDoc dflags w)
-
- eventBeginsDoc dflags w = showSDocOneLine dflags $ text "GHC:started:" <+> w
- eventEndsDoc dflags w = showSDocOneLine dflags $ text "GHC:finished:" <+> w
+ eventBegins ctx w = do
+ whenPrintTimings $ traceMarkerIO (eventBeginsDoc ctx w)
+ liftIO $ traceEventIO (eventBeginsDoc ctx w)
+ eventEnds ctx w = do
+ whenPrintTimings $ traceMarkerIO (eventEndsDoc ctx w)
+ liftIO $ traceEventIO (eventEndsDoc ctx w)
+
+ eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w
+ eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg dflags val msg = ifVerbose dflags val $
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index c23f6ed180..d36faa4724 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -96,7 +96,7 @@ import GhcPrelude
import {-# SOURCE #-} GHC.Driver.Session
( DynFlags, hasPprDebug, hasNoDebugOutput
- , pprUserLength, pprCols
+ , pprUserLength
, unsafeGlobalDynFlags, initSDocContext
)
import {-# SOURCE #-} GHC.Types.Module( UnitId, Module, ModuleName, moduleName )
@@ -484,43 +484,43 @@ whenPprDebug d = ifPprDebug d empty
-- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the
-- terminal doesn't get screwed up by the ANSI color codes if an exception
-- is thrown during pretty-printing.
-printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO ()
-printSDoc mode dflags handle sty doc =
+printSDoc :: SDocContext -> Mode -> Handle -> SDoc -> IO ()
+printSDoc ctx mode handle doc =
Pretty.printDoc_ mode cols handle (runSDoc doc ctx)
`finally`
Pretty.printDoc_ mode cols handle
(runSDoc (coloured Col.colReset empty) ctx)
where
- cols = pprCols dflags
- ctx = initSDocContext dflags sty
+ cols = sdocLineLength ctx
-- | Like 'printSDoc' but appends an extra newline.
-printSDocLn :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO ()
-printSDocLn mode dflags handle sty doc =
- printSDoc mode dflags handle sty (doc $$ text "")
+printSDocLn :: SDocContext -> Mode -> Handle -> SDoc -> IO ()
+printSDocLn ctx mode handle doc =
+ printSDoc ctx mode handle (doc $$ text "")
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser dflags handle unqual doc
- = printSDocLn PageMode dflags handle
- (mkUserStyle dflags unqual AllTheWay) doc
+ = printSDocLn ctx PageMode handle doc
+ where ctx = initSDocContext dflags (mkUserStyle dflags unqual AllTheWay)
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
-> IO ()
printForUserPartWay dflags handle d unqual doc
- = printSDocLn PageMode dflags handle
- (mkUserStyle dflags unqual (PartWay d)) doc
+ = printSDocLn ctx PageMode handle doc
+ where ctx = initSDocContext dflags (mkUserStyle dflags unqual (PartWay d))
-- | Like 'printSDocLn' but specialized with 'LeftMode' and
-- @'PprCode' 'CStyle'@. This is typically used to output C-- code.
printForC :: DynFlags -> Handle -> SDoc -> IO ()
printForC dflags handle doc =
- printSDocLn LeftMode dflags handle (PprCode CStyle) doc
+ printSDocLn ctx LeftMode handle doc
+ where ctx = initSDocContext dflags (PprCode CStyle)
-- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that
-- outputs to a 'BufHandle'.
-bufLeftRenderSDoc :: DynFlags -> BufHandle -> PprStyle -> SDoc -> IO ()
-bufLeftRenderSDoc dflags bufHandle sty doc =
- Pretty.bufLeftRender bufHandle (runSDoc doc (initSDocContext dflags sty))
+bufLeftRenderSDoc :: SDocContext -> BufHandle -> SDoc -> IO ()
+bufLeftRenderSDoc ctx bufHandle doc =
+ Pretty.bufLeftRender bufHandle (runSDoc doc ctx)
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
@@ -566,12 +566,12 @@ renderWithStyle ctx sdoc
-- This shows an SDoc, but on one line only. It's cheaper than a full
-- showSDoc, designed for when we're getting results like "Foo.bar"
-- and "foo{uniq strictness}" so we don't want fancy layout anyway.
-showSDocOneLine :: DynFlags -> SDoc -> String
-showSDocOneLine dflags d
+showSDocOneLine :: SDocContext -> SDoc -> String
+showSDocOneLine ctx d
= let s = Pretty.style{ Pretty.mode = OneLineMode,
- Pretty.lineLength = pprCols dflags } in
+ Pretty.lineLength = sdocLineLength ctx } in
Pretty.renderStyle s $
- runSDoc d (initSDocContext dflags (defaultUserStyle dflags))
+ runSDoc d ctx
showSDocDumpOneLine :: DynFlags -> SDoc -> String
showSDocDumpOneLine dflags d
View Lorry Controller Status