diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/DynFlags.hs | 7 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs-boot | 1 | ||||
| -rw-r--r-- | compiler/main/ErrUtils.lhs | 14 | ||||
| -rw-r--r-- | compiler/main/StaticFlags.hs | 4 |
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 |