Add flag to reverse errors in GHC/GHCi

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1367

GHC Trac Issues: #10848

3 files changed, 29 insertions, 6 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 438586595e..4af16cfbc5 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -897,7 +897,10 @@ data DynFlags = DynFlags {
 
   -- | Only inline memset if it generates no more than this many
   -- pseudo (roughly: Cmm) instructions.
-  maxInlineMemsetInsns  :: Int
+  maxInlineMemsetInsns  :: Int,
+
+  -- | Reverse the order of error messages in GHC/GHCi
+  reverseErrors :: Bool
 }
 
 class HasDynFlags m where
@@ -1558,7 +1561,9 @@ defaultDynFlags mySettings =
 
         maxInlineAllocSize = 128,
         maxInlineMemcpyInsns = 32,
-        maxInlineMemsetInsns = 32
+        maxInlineMemsetInsns = 32,
+
+        reverseErrors = False
       }
 
 defaultWays :: Settings -> [Way]
@@ -2397,6 +2402,10 @@ dynamic_flags = [
                                      deprecate "Use -fno-force-recomp instead"))
   , defGhcFlag "no-recomp" (NoArg (do setGeneralFlag Opt_ForceRecomp
                                       deprecate "Use -fforce-recomp instead"))
+  , defGhcFlag "freverse-errors"
+      (noArg (\d -> d {reverseErrors = True} ))
+  , defGhcFlag "fno-reverse-errors"
+      (noArg (\d -> d {reverseErrors = False} ))
 
         ------ HsCpp opts ---------------------------------------------------
   , defFlag "D"              (AnySuffix (upd . addOptP))
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index fd10694234..11c8c9d0db 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -54,6 +54,7 @@ import System.FilePath  ( takeDirectory, (</>) )
 import Data.List
 import qualified Data.Set as Set
 import Data.IORef
+import Data.Maybe       ( fromMaybe )
 import Data.Ord
 import Data.Time
 import Control.Monad
@@ -198,10 +199,12 @@ printBagOfErrors dflags bag_of_errors
                          errMsgShortDoc  = d,
                          errMsgSeverity  = sev,
                          errMsgExtraInfo = e,
-                         errMsgContext   = unqual } <- sortMsgBag bag_of_errors ]
+                         errMsgContext   = unqual } <- sortMsgBag (Just dflags)
+                                                                  bag_of_errors
+              ]
 
 pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
-pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag bag ]
+pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
 
 pprLocErrMsg :: ErrMsg -> SDoc
 pprLocErrMsg (ErrMsg { errMsgSpan      = s
@@ -213,8 +216,12 @@ pprLocErrMsg (ErrMsg { errMsgSpan      = s
     withPprStyle (mkErrStyle dflags unqual) $
     mkLocMessage sev s (d $$ e)
 
-sortMsgBag :: Bag ErrMsg -> [ErrMsg]
-sortMsgBag bag = sortBy (comparing errMsgSpan) $ bagToList bag
+sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
+sortMsgBag dflags = sortBy (maybeFlip $ comparing errMsgSpan) . bagToList
+  where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
+        maybeFlip
+          | fromMaybe False (fmap reverseErrors dflags) = flip
+          | otherwise                                  = id
 
 ghcExit :: DynFlags -> Int -> IO ()
 ghcExit dflags val
diff --git a/utils/mkUserGuidePart/Options/Misc.hs b/utils/mkUserGuidePart/Options/Misc.hs
index d6a4c4eaec..141a9caf1c 100644
--- a/utils/mkUserGuidePart/Options/Misc.hs
+++ b/utils/mkUserGuidePart/Options/Misc.hs
@@ -29,4 +29,11 @@ miscOptions =
            "the main thread, rather than a forked thread."
          , flagType = DynamicFlag
          }
+  , flag { flagName = "-freverse-errors"
+         , flagDescription =
+           "Display errors in GHC/GHCi sorted by reverse order of "++
+           "source code line numbers."
+         , flagType = DynamicFlag
+         , flagReverse = "-fno-reverse-errors"
+         }
   ]