Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/46c184e101092c53e9675bcfcb90cf06e513368d >--------------------------------------------------------------- commit 46c184e101092c53e9675bcfcb90cf06e513368d Author: Ian Lynagh <[email protected]> Date: Thu Jun 14 16:20:06 2012 +0100 Change -dppr-user-length from a static to a dynamic flag >--------------------------------------------------------------- compiler/main/DynFlags.hs | 7 +++++++ compiler/main/DynFlags.hs-boot | 1 + compiler/main/ErrUtils.lhs | 14 +++++++++----- compiler/main/StaticFlags.hs | 4 ---- compiler/typecheck/TcRnMonad.lhs | 4 ++-- compiler/utils/Outputable.lhs | 16 +++++++++------- docs/users_guide/flags.xml | 2 +- 7 files changed, 29 insertions(+), 19 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index f5fc45a..e198d47 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 906e522..12489a6 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 47e3b4e..5f5769d 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 4c78070..06cf19d 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 7e6c1d9..24d4712 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 7774405..b2ad099 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 diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 726fcf8..cd45040 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -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> _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
