[commit: ghc] master: A little tidying up in ErrUtils (4425ab9)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/4425ab99d6410839fa7567950b0a4696b0a3d70f/ghc

>---------------------------------------------------------------

commit 4425ab99d6410839fa7567950b0a4696b0a3d70f
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Jan 9 10:07:02 2015 +0000

    A little tidying up in ErrUtils
    
    This module is a disorganised mess.
    
    For example, there is literally *no* documentation of what the *seven*
    different forms of 'Severity' are intended to connote.
    
    Anyway this patch makes a tiny step by not exporting unused functions
    pprMsgBag and isWarning, and a little bit of internal refactoring


>---------------------------------------------------------------

4425ab99d6410839fa7567950b0a4696b0a3d70f
 compiler/main/ErrUtils.hs | 59 ++++++++++++++++++-----------------------------
 1 file changed, 23 insertions(+), 36 deletions(-)

diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 59bc01b..20d628f 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -13,8 +13,8 @@ module ErrUtils (
         ErrMsg, WarnMsg, Severity(..),
         Messages, ErrorMessages, WarningMessages,
         errMsgSpan, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
-        mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc,
-        pprLocErrMsg, makeIntoWarning, isWarning,
+        mkLocMessage, pprMessageBag, pprErrMsgBagWithLoc,
+        pprLocErrMsg, makeIntoWarning,
 
         errorsFound, emptyMessages, isEmptyMessages,
         mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
@@ -91,12 +91,12 @@ type WarningMessages = Bag WarnMsg
 type ErrorMessages   = Bag ErrMsg
 
 data ErrMsg = ErrMsg {
-        errMsgSpan      :: SrcSpan,
-        errMsgContext   :: PrintUnqualified,
-        errMsgShortDoc  :: MsgDoc,   -- errMsgShort* should always
-        errMsgShortString :: String, -- contain the same text
-        errMsgExtraInfo :: MsgDoc,
-        errMsgSeverity  :: Severity
+        errMsgSpan        :: SrcSpan,
+        errMsgContext     :: PrintUnqualified,
+        errMsgShortDoc    :: MsgDoc,   -- errMsgShort* should always
+        errMsgShortString :: String,   -- contain the same text
+        errMsgExtraInfo   :: MsgDoc,
+        errMsgSeverity    :: Severity
         }
         -- The SrcSpan is used for sorting errors into line-number order
 
@@ -111,6 +111,10 @@ data Severity
   | SevError
   | SevFatal
 
+isWarning :: Severity -> Bool
+isWarning SevWarning = True
+isWarning _          = False
+
 instance Show ErrMsg where
     show em = errMsgShortString em
 
@@ -128,19 +132,14 @@ mkLocMessage severity locn msg
                   else ppr (srcSpanStart locn)
       in hang (locn' <> colon <+> sev_info) 4 msg
   where
-    sev_info = case severity of
-                 SevWarning -> ptext (sLit "Warning:")
-                 _other     -> empty
+    sev_info = ppWhen (isWarning severity)
+                      (ptext (sLit "Warning:"))
       -- For warnings, print    Foo.hs:34: Warning:
       --                           <the warning message>
 
 makeIntoWarning :: ErrMsg -> ErrMsg
 makeIntoWarning err = err { errMsgSeverity = SevWarning }
 
-isWarning :: ErrMsg -> Bool
-isWarning err
-  | SevWarning <- errMsgSeverity err = True
-  | otherwise                        = False
 -- -----------------------------------------------------------------------------
 -- Collecting up messages for later ordering and printing.
 
@@ -181,16 +180,13 @@ errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
 
 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
 printBagOfErrors dflags bag_of_errors
-  = printMsgBag dflags bag_of_errors
-
-pprErrMsgBag :: Bag ErrMsg -> [SDoc]
-pprErrMsgBag bag
-  = [ sdocWithDynFlags $ \dflags ->
-      let style = mkErrStyle dflags unqual
-      in withPprStyle style (d $$ e)
-    | ErrMsg { errMsgShortDoc  = d,
-               errMsgExtraInfo = e,
-               errMsgContext   = unqual } <- sortMsgBag bag ]
+  = sequence_ [ let style = mkErrStyle dflags unqual
+                in log_action dflags dflags sev s style (d $$ e)
+              | ErrMsg { errMsgSpan      = s,
+                         errMsgShortDoc  = d,
+                         errMsgSeverity  = sev,
+                         errMsgExtraInfo = e,
+                         errMsgContext   = unqual } <- sortMsgBag bag_of_errors ]
 
 pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
 pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag bag ]
@@ -202,17 +198,8 @@ pprLocErrMsg (ErrMsg { errMsgSpan      = s
                      , errMsgSeverity  = sev
                      , errMsgContext   = unqual })
   = sdocWithDynFlags $ \dflags ->
-    withPprStyle (mkErrStyle dflags unqual) (mkLocMessage sev s (d $$ e))
-
-printMsgBag :: DynFlags -> Bag ErrMsg -> IO ()
-printMsgBag dflags bag
-  = sequence_ [ let style = mkErrStyle dflags unqual
-                in log_action dflags dflags sev s style (d $$ e)
-              | ErrMsg { errMsgSpan      = s,
-                         errMsgShortDoc  = d,
-                         errMsgSeverity  = sev,
-                         errMsgExtraInfo = e,
-                         errMsgContext   = unqual } <- sortMsgBag bag ]
+    withPprStyle (mkErrStyle dflags unqual) $
+    mkLocMessage sev s (d $$ e)
 
 sortMsgBag :: Bag ErrMsg -> [ErrMsg]
 sortMsgBag bag = sortBy (comparing errMsgSpan) $ bagToList bag