Commit 46c184e1 authored by Ian Lynagh's avatar Ian Lynagh

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

parent 0f3d8ab9
......@@ -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))
......
......@@ -8,4 +8,5 @@ data DynFlags
tracingDynFlags :: DynFlags
targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
......@@ -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
......
......@@ -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
......
......@@ -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 }
......
......@@ -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
......
......@@ -2712,7 +2712,7 @@
<row>
<entry><option>-dppr-user-length</option></entry>
<entry>Set the depth for printing expressions in error msgs</entry>
<entry>static</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment