Change -dppr-user-length from a static to a dynamic flag

6 files changed, 28 insertions, 18 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index f5fc45aab3..e198d472dc 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -611,6 +611,9 @@ data DynFlags = DynFlags {
   haddockOptions        :: Maybe String,
   ghciScripts           :: [String],
 
+  -- Output style options
+  pprUserLength         :: Int,
+
   -- | what kind of {-# SCC #-} to add automatically
   profAuto              :: ProfAuto,
 
@@ -967,6 +970,7 @@ defaultDynFlags mySettings =
         log_action = defaultLogAction,
         flushOut = defaultFlushOut,
         flushErr = defaultFlushErr,
+        pprUserLength = 5,
         profAuto = NoProfAuto,
         llvmVersion = panic "defaultDynFlags: No llvmVersion"
       }
@@ -1609,6 +1613,9 @@ dynamic_flags = [
   , Flag "I"              (Prefix    addIncludePath)
   , Flag "i"              (OptPrefix addImportPath)
 
+        ------ Output style options -----------------------------------------
+  , Flag "dppr-user-length" (intSuffix (\n d -> d{ pprUserLength = n }))
+
         ------ Debugging ----------------------------------------------------
   , Flag "dstg-stats"     (NoArg (setDynFlag Opt_StgStats))
 
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index 906e522479..12489a6e07 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -8,4 +8,5 @@ data DynFlags
 tracingDynFlags :: DynFlags
 
 targetPlatform :: DynFlags -> Platform
+pprUserLength :: DynFlags -> Int
 
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 47e3b4ebc6..5f5769d1c9 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -146,7 +146,8 @@ printBagOfErrors dflags bag_of_errors
 
 pprErrMsgBag :: Bag ErrMsg -> [SDoc]
 pprErrMsgBag bag
-  = [ let style = mkErrStyle unqual
+  = [ sdocWithDynFlags $ \dflags ->
+      let style = mkErrStyle dflags unqual
       in withPprStyle style (d $$ e)
     | ErrMsg { errMsgShortDoc  = d,
                errMsgExtraInfo = e,
@@ -161,13 +162,14 @@ pprLocErrMsg (ErrMsg { errMsgSpans     = spans
                      , errMsgExtraInfo = e
                      , errMsgSeverity  = sev
                      , errMsgContext   = unqual })
-  = withPprStyle (mkErrStyle unqual) (mkLocMessage sev s (d $$ e))
+  = sdocWithDynFlags $ \dflags ->
+    withPprStyle (mkErrStyle dflags unqual) (mkLocMessage sev s (d $$ e))
   where
     (s : _) = spans   -- Should be non-empty
 
 printMsgBag :: DynFlags -> Bag ErrMsg -> IO ()
 printMsgBag dflags bag
-  = sequence_ [ let style = mkErrStyle unqual
+  = sequence_ [ let style = mkErrStyle dflags unqual
                 in log_action dflags dflags sev s style (d $$ e)
               | ErrMsg { errMsgSpans     = s:_,
                          errMsgShortDoc  = d,
@@ -317,13 +319,15 @@ putMsgWith dflags print_unqual msg
     sty = mkUserStyle print_unqual AllTheWay
 
 errorMsg :: DynFlags -> MsgDoc -> IO ()
-errorMsg dflags msg = log_action dflags dflags SevError noSrcSpan defaultErrStyle msg
+errorMsg dflags msg =
+    log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
 
 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
 
 fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
-fatalErrorMsg' la dflags msg = la dflags SevFatal noSrcSpan defaultErrStyle msg
+fatalErrorMsg' la dflags msg =
+    la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
 
 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
 fatalErrorMsg'' fm msg = fm msg
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 4c78070930..06cf19dbac 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -27,7 +27,6 @@ module StaticFlags (
 	WayName(..), Way(..), v_Ways, isRTSWay, mkBuildTag,
 
 	-- Output style options
-	opt_PprUserLength,
 	opt_PprCols,
 	opt_PprCaseAsLet,
 	opt_PprStyle_Debug, opt_TraceLevel,
@@ -276,9 +275,6 @@ opt_TraceLevel :: Int
 opt_TraceLevel = lookup_def_int "-dtrace-level" 1  	-- Standard level is 1
 	       	 			    	        -- Less verbose is 0
 
-opt_PprUserLength   :: Int
-opt_PprUserLength	        = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
-
 opt_Fuel            :: Int
 opt_Fuel                        = lookup_def_int "-dopt-fuel" maxBound
 
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 7e6c1d98ae..24d4712ec1 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -1226,7 +1226,7 @@ failIfM msg
   = do  { env <- getLclEnv
         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
         ; dflags <- getDynFlags
-        ; liftIO (log_action dflags dflags SevFatal noSrcSpan defaultErrStyle full_msg)
+        ; liftIO (log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) full_msg)
         ; failM }
 
 --------------------
@@ -1257,7 +1257,7 @@ forkM_maybe doc thing_inside
                           dflags <- getDynFlags
                           let msg = hang (text "forkM failed:" <+> doc)
                                        2 (text (show exn))
-                          liftIO $ log_action dflags dflags SevFatal noSrcSpan defaultErrStyle msg
+                          liftIO $ log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
 
                     ; traceIf (text "} ending fork (badly)" <+> doc)
                     ; return Nothing }
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 7774405583..b2ad099009 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -71,7 +71,8 @@ module Outputable (
         pprDebugAndThen,
     ) where
 
-import {-# SOURCE #-}   DynFlags( DynFlags, tracingDynFlags, targetPlatform )
+import {-# SOURCE #-}   DynFlags( DynFlags, tracingDynFlags,
+                                  targetPlatform, pprUserLength )
 import {-# SOURCE #-}   Module( Module, ModuleName, moduleName )
 import {-# SOURCE #-}   Name( Name, nameModule )
 
@@ -195,16 +196,17 @@ defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
                  |  otherwise          = PprDump
 
 -- | Style for printing error messages
-mkErrStyle :: PrintUnqualified -> PprStyle
-mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
+mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
+mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags))
 
-defaultErrStyle :: PprStyle
+defaultErrStyle :: DynFlags -> PprStyle
 -- Default style for error messages
 -- 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
-  | opt_PprStyle_Debug   = mkUserStyle alwaysQualify AllTheWay
-  | otherwise            = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
+defaultErrStyle dflags = mkUserStyle alwaysQualify depth
+    where depth = if opt_PprStyle_Debug
+                  then AllTheWay
+                  else PartWay (pprUserLength dflags)
 
 mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
 mkUserStyle unqual depth