Commit 2af0ec90 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

DynFlags: store default depth in SDocContext (#17957)

It avoids having to use DynFlags to reach for pprUserLength.
parent da18ff99
Pipeline #21139 canceled with stages
......@@ -778,7 +778,7 @@ msg sev reason doc
SevWarning -> err_sty
SevDump -> dump_sty
_ -> user_sty
err_sty = mkErrStyle dflags unqual
err_sty = mkErrStyle unqual
user_sty = mkUserStyle unqual AllTheWay
dump_sty = mkDumpStyle unqual
; liftIO $ putLogMsg dflags reason sev loc (withPprStyle sty doc) }
......
......@@ -5177,6 +5177,7 @@ initSDocContext dflags style = SDC
, sdocColScheme = colScheme dflags
, sdocLastColour = Col.colReset
, sdocShouldUseColor = overrideWith (canUseColor dflags) (useColor dflags)
, sdocDefaultDepth = pprUserLength dflags
, sdocLineLength = pprCols dflags
, sdocCanUseUnicode = useUnicode dflags
, sdocHexWordLiterals = gopt Opt_HexWordLiterals dflags
......
......@@ -8,8 +8,7 @@ import {-# SOURCE #-} GHC.Unit.State
data DynFlags
targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
unitState :: DynFlags -> UnitState
unitState :: DynFlags -> UnitState
unsafeGlobalDynFlags :: DynFlags
hasPprDebug :: DynFlags -> Bool
hasNoDebugOutput :: DynFlags -> Bool
......
......@@ -1623,7 +1623,7 @@ printMinimalImports imports_w_usage
; this_mod <- getModule
; dflags <- getDynFlags
; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h ->
printForUser dflags h neverQualify (vcat (map ppr imports'))
printForUser dflags h neverQualify AllTheWay (vcat (map ppr imports'))
-- The neverQualify is important. We are printing Names
-- but they are in the context of an 'import' decl, and
-- we never qualify things inside there
......
......@@ -1957,7 +1957,7 @@ failIfM msg
; let full_msg = (if_loc env <> colon) $$ nest 2 msg
; dflags <- getDynFlags
; liftIO (putLogMsg dflags NoReason SevFatal
noSrcSpan $ withPprStyle (defaultErrStyle dflags) full_msg)
noSrcSpan $ withPprStyle defaultErrStyle full_msg)
; failM }
--------------------
......@@ -1993,7 +1993,7 @@ forkM_maybe doc thing_inside
NoReason
SevFatal
noSrcSpan
$ withPprStyle (defaultErrStyle dflags) msg
$ withPprStyle defaultErrStyle msg
; traceIf (text "} ending fork (badly)" <+> doc)
; return Nothing }
......
......@@ -378,7 +378,7 @@ warningsToMessages dflags =
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
= sequence_ [ let style = mkErrStyle dflags unqual
= sequence_ [ let style = mkErrStyle unqual
ctx = initSDocContext dflags style
in putLogMsg dflags reason sev s $ withPprStyle style (formatErrDoc ctx doc)
| ErrMsg { errMsgSpan = s,
......@@ -621,15 +621,15 @@ ifVerbose dflags val act
errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg dflags msg
= putLogMsg dflags NoReason SevError noSrcSpan $ withPprStyle (defaultErrStyle dflags) msg
= putLogMsg dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg
warningMsg :: DynFlags -> MsgDoc -> IO ()
warningMsg dflags msg
= putLogMsg dflags NoReason SevWarning noSrcSpan $ withPprStyle (defaultErrStyle dflags) msg
= putLogMsg dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
fatalErrorMsg dflags msg =
putLogMsg dflags NoReason SevFatal noSrcSpan $ withPprStyle (defaultErrStyle dflags) msg
putLogMsg dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg
fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
......
......@@ -43,7 +43,7 @@ module GHC.Utils.Outputable (
coloured, keyword,
-- * Converting 'SDoc' into strings and outputting it
printSDoc, printSDocLn, printForUser, printForUserPartWay,
printSDoc, printSDocLn, printForUser,
printForC, bufLeftRenderSDoc,
pprCode, mkCodeStyle,
showSDoc, showSDocUnsafe, showSDocOneLine,
......@@ -96,7 +96,6 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Driver.Session
( DynFlags, hasPprDebug, hasNoDebugOutput
, pprUserLength
, unsafeGlobalDynFlags, initSDocContext
)
import {-# SOURCE #-} GHC.Unit.Types ( Unit, Module, moduleName )
......@@ -165,8 +164,10 @@ data PprStyle
data CodeStyle = CStyle -- The format of labels differs for C and assembler
| AsmStyle
data Depth = AllTheWay
| PartWay Int -- 0 => stop
data Depth
= AllTheWay
| PartWay Int -- ^ 0 => stop
| DefaultDepth -- ^ Use 'sdocDefaultDepth' field as depth
data Coloured
= Uncoloured
......@@ -263,13 +264,12 @@ mkDumpStyle print_unqual = PprDump print_unqual
-- | Default style for error messages, when we don't know PrintUnqualified
-- It's a bit of a hack because it doesn't take into account what's in scope
-- Only used for desugarer warnings, and typechecker errors in interface sigs
defaultErrStyle :: DynFlags -> PprStyle
defaultErrStyle dflags = mkErrStyle dflags neverQualify
defaultErrStyle :: PprStyle
defaultErrStyle = mkErrStyle neverQualify
-- | Style for printing error messages
mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
mkErrStyle dflags qual =
mkUserStyle qual (PartWay (pprUserLength dflags))
mkErrStyle :: PrintUnqualified -> PprStyle
mkErrStyle unqual = mkUserStyle unqual DefaultDepth
cmdlineParserStyle :: PprStyle
cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay
......@@ -282,8 +282,7 @@ withUserStyle unqual depth doc = withPprStyle (PprUser unqual depth Uncoloured)
withErrStyle :: PrintUnqualified -> SDoc -> SDoc
withErrStyle unqual doc =
sdocWithDynFlags $ \dflags ->
withPprStyle (mkErrStyle dflags unqual) doc
withPprStyle (mkErrStyle unqual) doc
setStyleColoured :: Bool -> PprStyle -> PprStyle
setStyleColoured col style =
......@@ -329,6 +328,7 @@ data SDocContext = SDC
-- ^ The most recently used colour.
-- This allows nesting colours.
, sdocShouldUseColor :: !Bool
, sdocDefaultDepth :: !Int
, sdocLineLength :: !Int
, sdocCanUseUnicode :: !Bool
-- ^ True if Unicode encoding is supported
......@@ -374,26 +374,34 @@ withPprStyle :: PprStyle -> SDoc -> SDoc
withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
pprDeeper :: SDoc -> SDoc
pprDeeper d = SDoc $ \ctx -> case ctx of
SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..."
SDC{sdocStyle=PprUser q (PartWay n) c} ->
runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
pprDeeper d = SDoc $ \ctx -> case sdocStyle ctx of
PprUser q depth c ->
let deeper 0 = Pretty.text "..."
deeper n = runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
in case depth of
DefaultDepth -> deeper (sdocDefaultDepth ctx)
PartWay n -> deeper n
AllTheWay -> runSDoc d ctx
_ -> runSDoc d ctx
-- | Truncate a list that is longer than the current depth.
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList f ds
| null ds = f []
| otherwise = SDoc work
where
work ctx@SDC{sdocStyle=PprUser q (PartWay n) c}
| n==0 = Pretty.text "..."
| otherwise =
runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
where
go _ [] = []
go i (d:ds) | i >= n = [text "...."]
| otherwise = d : go (i+1) ds
work ctx@SDC{sdocStyle=PprUser q depth c}
| DefaultDepth <- depth
= work (ctx { sdocStyle = PprUser q (PartWay (sdocDefaultDepth ctx)) c })
| PartWay 0 <- depth
= Pretty.text "..."
| PartWay n <- depth
= let
go _ [] = []
go i (d:ds) | i >= n = [text "...."]
| otherwise = d : go (i+1) ds
in runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
work other_ctx = runSDoc (f ds) other_ctx
pprSetDepth :: Depth -> SDoc -> SDoc
......@@ -485,16 +493,10 @@ 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 ctx PageMode handle doc
where ctx = initSDocContext dflags (mkUserStyle unqual AllTheWay)
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
-> IO ()
printForUserPartWay dflags handle d unqual doc
printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO ()
printForUser dflags handle unqual depth doc
= printSDocLn ctx PageMode handle doc
where ctx = initSDocContext dflags (mkUserStyle unqual (PartWay d))
where ctx = initSDocContext dflags (mkUserStyle unqual depth)
-- | Like 'printSDocLn' but specialized with 'LeftMode' and
-- @'PprCode' 'CStyle'@. This is typically used to output C-- code.
......
......@@ -68,7 +68,7 @@ import GHC.Types.SrcLoc as SrcLoc
import qualified GHC.Parser.Lexer as Lexer
import GHC.Data.StringBuffer
import GHC.Utils.Outputable hiding ( printForUser, printForUserPartWay )
import GHC.Utils.Outputable hiding ( printForUser )
import GHC.Runtime.Loader ( initializePlugins )
......
......@@ -38,7 +38,7 @@ module GHCi.UI.Monad (
import GHCi.UI.Info (ModInfo)
import qualified GHC
import GHC.Driver.Monad hiding (liftIO)
import GHC.Utils.Outputable hiding (printForUser, printForUserPartWay)
import GHC.Utils.Outputable hiding (printForUser)
import qualified GHC.Utils.Outputable as Outputable
import GHC.Types.Name.Occurrence
import GHC.Driver.Session
......@@ -331,26 +331,26 @@ unsetOption opt
printForUserNeverQualify :: GhcMonad m => SDoc -> m ()
printForUserNeverQualify doc = do
dflags <- getDynFlags
liftIO $ Outputable.printForUser dflags stdout neverQualify doc
liftIO $ Outputable.printForUser dflags stdout neverQualify AllTheWay doc
printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()
printForUserModInfo info doc = do
dflags <- getDynFlags
mUnqual <- GHC.mkPrintUnqualifiedForModule info
unqual <- maybe GHC.getPrintUnqual return mUnqual
liftIO $ Outputable.printForUser dflags stdout unqual doc
liftIO $ Outputable.printForUser dflags stdout unqual AllTheWay doc
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
unqual <- GHC.getPrintUnqual
dflags <- getDynFlags
liftIO $ Outputable.printForUser dflags stdout unqual doc
liftIO $ Outputable.printForUser dflags stdout unqual AllTheWay doc
printForUserPartWay :: GhcMonad m => SDoc -> m ()
printForUserPartWay doc = do
unqual <- GHC.getPrintUnqual
dflags <- getDynFlags
liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
liftIO $ Outputable.printForUser dflags stdout unqual Outputable.DefaultDepth doc
-- | Run a single Haskell expression
runStmt
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment