DynFlags: store default depth in SDocContext (#17957)

It avoids having to use DynFlags to reach for pprUserLength.

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