[Git][ghc/ghc][master] DynFlags: store default depth in SDocContext (#17957)
Marge Bot
gitlab at gitlab.haskell.org
Fri Jun 19 03:08:00 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
2af0ec90 by Sylvain Henry at 2020-06-18T23:07:47-04:00
DynFlags: store default depth in SDocContext (#17957)
It avoids having to use DynFlags to reach for pprUserLength.
- - - - -
9 changed files:
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Driver/Session.hs-boot
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Utils/Error.hs
- compiler/GHC/Utils/Outputable.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Monad.hs
=====================================
@@ -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) }
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -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
=====================================
compiler/GHC/Driver/Session.hs-boot
=====================================
@@ -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
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -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
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -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 }
=====================================
compiler/GHC/Utils/Error.hs
=====================================
@@ -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
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -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 at 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 at 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.
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -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 )
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2af0ec9059b94e1fa6b37eda60216e0222e1a53d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2af0ec9059b94e1fa6b37eda60216e0222e1a53d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200618/a0314a45/attachment-0001.html>
More information about the ghc-commits
mailing list