diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-06-17 17:11:19 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-06-18 23:07:47 -0400 |
commit | 2af0ec9059b94e1fa6b37eda60216e0222e1a53d (patch) | |
tree | db9449d504a8e0065bf2cbfd1243c4837ad2476a | |
parent | da18ff9935e72c7fe6127cb5d5d0c53654a204b0 (diff) | |
download | haskell-2af0ec9059b94e1fa6b37eda60216e0222e1a53d.tar.gz |
DynFlags: store default depth in SDocContext (#17957)
It avoids having to use DynFlags to reach for pprUserLength.
-rw-r--r-- | compiler/GHC/Core/Opt/Monad.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs-boot | 3 | ||||
-rw-r--r-- | compiler/GHC/Rename/Names.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Utils/Error.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 66 | ||||
-rw-r--r-- | ghc/GHCi/UI.hs | 2 | ||||
-rw-r--r-- | ghc/GHCi/UI/Monad.hs | 10 |
9 files changed, 50 insertions, 48 deletions
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 0febfdb787..aa651355f4 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/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) } diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 0d08d0cc26..d2f1b42ac3 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/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 diff --git a/compiler/GHC/Driver/Session.hs-boot b/compiler/GHC/Driver/Session.hs-boot index 3dcc6b3a6e..41daf4d3b2 100644 --- a/compiler/GHC/Driver/Session.hs-boot +++ b/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 diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 69c0746646..677e695420 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/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 diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index f1d82c1228..dc7994a62b 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/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 } diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 6854846a81..3bb9aa7329 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/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 diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 809c06b64d..151800a30b 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/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@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. diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 2a7f385830..9db2dd5773 100644 --- a/ghc/GHCi/UI.hs +++ b/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 ) diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index 8174c47a8f..63f330d86c 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/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 |