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

4 files changed, 17 insertions, 9 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