[commit: ghc] wip/nomeata-T8466: Report identical errors only once (132a3d8)

[git at git.haskell.org]

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

On branch  : wip/nomeata-T8466
Link       : http://ghc.haskell.org/trac/ghc/changeset/132a3d8fa5a018fec927ada0ae1c0eb6e4a5a1d5/ghc

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

commit 132a3d8fa5a018fec927ada0ae1c0eb6e4a5a1d5
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Thu Oct 24 22:28:29 2013 +0200

    Report identical errors only once
    
    This is a prototype for #8466


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

132a3d8fa5a018fec927ada0ae1c0eb6e4a5a1d5
 compiler/main/ErrUtils.lhs |   33 +++++++++++++++++++++++++++------
 1 file changed, 27 insertions(+), 6 deletions(-)

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 6957fa0..80a6f77 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -83,6 +83,7 @@ data Severity
   | SevWarning
   | SevError
   | SevFatal
+  deriving Eq
 
 instance Show ErrMsg where
     show em = errMsgShortString em
@@ -176,12 +177,32 @@ pprLocErrMsg (ErrMsg { errMsgSpans     = s
 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 { errMsgSpans     = s,
-                         errMsgShortDoc  = d,
-                         errMsgSeverity  = sev,
-                         errMsgExtraInfo = e,
-                         errMsgContext   = unqual } <- sortMsgBag bag ]
+                    extraloc | null ss = empty
+                             | otherwise = parens $ text "also at" <+> pprWithCommas ppr ss
+                in log_action dflags dflags sev s style (d $$ e $$ extraloc)
+              | (ErrMsg { errMsgSpans     = s,
+                          errMsgShortDoc  = d,
+                          errMsgSeverity  = sev,
+                          errMsgExtraInfo = e,
+                          errMsgContext   = unqual }, ss) <- groupAndSortBag bag ]
+
+-- | Returns unique (up to their SrcSpan) error message, sorted by the first occurring
+--   SrcSpan, together with other SrcSpan where the error is occuring.
+groupAndSortBag :: Bag ErrMsg -> [ (ErrMsg, [SrcSpan]) ]
+groupAndSortBag bag = group [] $ sortMsgBag bag
+  where
+    -- We sort first by span, so that we have the right (the first) SrcSpan in
+    -- the retained ErrMsg
+    group r [] = r
+    group r (e:es) = group (insert e r) es
+    insert e [] = [(e,[])]
+    insert e ((e',ss):es) =
+        if -- errMsgContext e     == errMsgContext e' &&
+           errMsgShortString e == errMsgShortString e' &&
+           -- errMsgExtraInfo e   == errMsgExtraInfo e' &&
+           errMsgSeverity e    == errMsgSeverity e'
+        then ((e',ss++[errMsgSpans e]) : es)
+        else ((e',ss):insert e es) 
 
 sortMsgBag :: Bag ErrMsg -> [ErrMsg]
 sortMsgBag bag = sortBy (comparing errMsgSpans) $ bagToList bag