Remove Ord SrcLoc, Ord SrcSpan

Before this patch, GHC relied on Ord SrcSpan to identify source elements, by
using SrcSpan as Map keys:

	blackList :: Map SrcSpan ()      -- compiler/GHC/HsToCore/Coverage.hs
	instanceMap :: Map SrcSpan Name  -- compiler/GHC/HsToCore/Docs.hs

Firstly, this design is not valid in presence of UnhelpfulSpan, as it
distinguishes between  UnhelpfulSpan "X"  and  UnhelpfulSpan "Y", but those
strings are messages for the user, unfit to serve as identifiers for source
elements.

Secondly, this design made it hard to extend SrcSpan with additional data.
Recall that the definition of SrcSpan is:

	data SrcSpan =
	    RealSrcSpan !RealSrcSpan
	  | UnhelpfulSpan !FastString

Say we want to extend the RealSrcSpan constructor with additional information:

	data SrcSpan =
	    RealSrcSpan !RealSrcSpan !AdditionalInformation
	  | UnhelpfulSpan !FastString

	getAdditionalInformation :: SrcSpan -> AdditionalInformation
	getAdditionalInformation (RealSrcSpan _ a) = a

Now, in order for  Map S...

compiler/GHC.hs

@@ -260,7 +260,7 @@ module GHC (
 
         -- *** Combining and comparing Located values
         eqLocated, cmpLocated, combineLocs, addCLoc,
-        leftmost_smallest, leftmost_largest, rightmost,
+        leftmost_smallest, leftmost_largest, rightmost_smallest,
         spans, isSubspanOf,
 
         -- * Exceptions

compiler/GHC/Hs/Binds.hs

@@ -46,7 +46,7 @@ import BooleanFormula (LBooleanFormula)
 
 import Data.Data hiding ( Fixity )
 import Data.List hiding ( foldr )
-import Data.Ord
+import Data.Function
 
 {-
 ************************************************************************
@@ -667,7 +667,7 @@ pprLHsBindsForUser binds sigs
     decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
             [(loc, ppr bind) | L loc bind <- bagToList binds]
 
-    sort_by_loc decls = sortBy (comparing fst) decls
+    sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls
 
 pprDeclList :: [SDoc] -> SDoc   -- Braces with a space
 -- Print a bunch of declarations

compiler/GHC/Hs/Types.hs

@@ -1345,7 +1345,6 @@ data FieldOcc pass = FieldOcc { extFieldOcc     :: XCFieldOcc pass
   | XFieldOcc
       (XXFieldOcc pass)
 deriving instance Eq  (XCFieldOcc (GhcPass p)) => Eq  (FieldOcc (GhcPass p))
-deriving instance Ord (XCFieldOcc (GhcPass p)) => Ord (FieldOcc (GhcPass p))
 
 type instance XCFieldOcc GhcPs = NoExtField
 type instance XCFieldOcc GhcRn = Name

compiler/GHC/HsToCore/Coverage.hs

@@ -53,8 +53,8 @@ import Trace.Hpc.Mix
 import Trace.Hpc.Util
 
 import qualified Data.ByteString as BS
-import Data.Map (Map)
-import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
 
 {-
 ************************************************************************
@@ -91,9 +91,11 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
                       , exports      = exports
                       , inlines      = emptyVarSet
                       , inScope      = emptyVarSet
-                      , blackList    = Map.fromList
-                                          [ (getSrcSpan (tyConName tyCon),())
-                                          | tyCon <- tyCons ]
+                      , blackList    = Set.fromList $
+                                       mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of
+                                                             RealSrcSpan l -> Just l
+                                                             UnhelpfulSpan _ -> Nothing)
+                                                tyCons
                       , density      = mkDensity tickish dflags
                       , this_mod     = mod
                       , tickishType  = tickish
@@ -1034,7 +1036,7 @@ data TickTransEnv = TTE { fileName     :: FastString
                         , inlines      :: VarSet
                         , declPath     :: [String]
                         , inScope      :: VarSet
-                        , blackList    :: Map SrcSpan ()
+                        , blackList    :: Set RealSrcSpan
                         , this_mod     :: Module
                         , tickishType  :: TickishType
                         }
@@ -1167,10 +1169,8 @@ bindLocals new_ids (TM m)
   where occs = [ nameOccName (idName id) | id <- new_ids ]
 
 isBlackListed :: SrcSpan -> TM Bool
-isBlackListed pos = TM $ \ env st ->
-              case Map.lookup pos (blackList env) of
-                Nothing -> (False,noFVs,st)
-                Just () -> (True,noFVs,st)
+isBlackListed (RealSrcSpan pos) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st)
+isBlackListed (UnhelpfulSpan _) = return False
 
 -- the tick application inherits the source position of its
 -- expression argument to support nested box allocations

compiler/GHC/HsToCore/Docs.hs

@@ -23,7 +23,6 @@ import TcRnTypes
 
 import Control.Applicative
 import Data.Bifunctor (first)
-import Data.List
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Maybe
@@ -76,7 +75,7 @@ mkMaps instances decls =
              -> ( [(Name, HsDocString)]
                 , [(Name, Map Int (HsDocString))]
                 )
-    mappings (L l decl, docStrs) =
+    mappings (L (RealSrcSpan l) decl, docStrs) =
            (dm, am)
       where
         doc = concatDocs docStrs
@@ -92,17 +91,19 @@ mkMaps instances decls =
         subNs = [ n | (n, _, _) <- subs ]
         dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]
         am = [(n, args) | n <- ns] ++ zip subNs subArgs
+    mappings (L (UnhelpfulSpan _) _, _) = ([], [])
 
-    instanceMap :: Map SrcSpan Name
-    instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances]
+    instanceMap :: Map RealSrcSpan Name
+    instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l <- [getSrcSpan n] ]
+
+    names :: RealSrcSpan -> HsDecl GhcRn -> [Name]
+    names l (InstD _ d) = maybeToList $ -- See Note [1].
+      case d of
+              TyFamInstD _ _ -> M.lookup l instanceMap
+                -- The CoAx's loc is the whole line, but only
+                -- for TFs
+              _ -> lookupSrcSpan (getInstLoc d) instanceMap
 
-    names :: SrcSpan -> HsDecl GhcRn -> [Name]
-    names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See
-                                                                 -- Note [1].
-      where loc = case d of
-              TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only
-                                  -- for TFs
-              _ -> getInstLoc d
     names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
     names _ decl = getMainDeclBinder decl
 
@@ -160,7 +161,7 @@ getInstLoc = \case
 -- | Get all subordinate declarations inside a declaration, and their docs.
 -- A subordinate declaration is something like the associate type or data
 -- family of a type class.
-subordinates :: Map SrcSpan Name
+subordinates :: Map RealSrcSpan Name
              -> HsDecl GhcRn
              -> [(Name, [(HsDocString)], Map Int (HsDocString))]
 subordinates instMap decl = case decl of
@@ -168,7 +169,7 @@ subordinates instMap decl = case decl of
     DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
       FamEqn { feqn_tycon = L l _
              , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d
-    [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
+    [ (n, [], M.empty) | Just n <- [lookupSrcSpan l instMap] ] ++ dataSubs defn
 
   InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
     -> dataSubs (feqn_rhs d)
@@ -197,7 +198,7 @@ subordinates instMap decl = case decl of
                   | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
                                 concatMap (unLoc . deriv_clause_tys . unLoc) $
                                 unLoc $ dd_derivs dd
-                  , Just instName <- [M.lookup l instMap] ]
+                  , Just instName <- [lookupSrcSpan l instMap] ]
 
         extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
         extract_deriv_ty (L l ty) =
@@ -233,7 +234,7 @@ isValD _ = False
 -- | All the sub declarations of a class (that we handle), ordered by
 -- source location, with documentation attached if it exists.
 classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
-classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
+classDecls class_ = filterDecls . collectDocs . sortLocated $ decls
   where
     decls = docs ++ defs ++ sigs ++ ats
     docs  = mkDecls tcdDocs (DocD noExtField) class_
@@ -277,7 +278,7 @@ typeDocs = go 0
 -- | The top-level declarations of a module that we care about,
 -- ordered by source location, with documentation attached if it exists.
 topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
-topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
+topDecls = filterClasses . filterDecls . collectDocs . sortLocated . ungroup
 
 -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
 ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
@@ -298,10 +299,6 @@ ungroup group_ =
       concatMap bagToList . snd . unzip $ binds
     valbinds ValBinds{} = error "expected XValBindsLR"
 
--- | Sort by source location
-sortByLoc :: [Located a] -> [Located a]
-sortByLoc = sortOn getLoc
-
 -- | Collect docs and attach them to the right declarations.
 --
 -- A declaration may have multiple doc strings attached to it.

compiler/GHC/HsToCore/Quote.hs

@@ -80,6 +80,7 @@ import Data.Kind (Constraint)
 import Data.ByteString ( unpack )
 import Control.Monad
 import Data.List
+import Data.Function
 
 data MetaWrappers = MetaWrappers {
       -- Applies its argument to a type argument `m` and dictionary `Quote m`
@@ -2010,8 +2011,7 @@ repP other = notHandled "Exotic pattern" (ppr other)
 -- Declaration ordering helpers
 
 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
-sort_by_loc xs = sortBy comp xs
-    where comp x y = compare (fst x) (fst y)
+sort_by_loc = sortBy (SrcLoc.leftmost_smallest `on` fst)
 
 de_loc :: [(a, b)] -> [b]
 de_loc = map snd

compiler/GHC/Iface/Ext/Binary.hs

@@ -32,6 +32,7 @@ import SrcLoc
 import UniqSupply                 ( takeUniqFromSupply )
 import Unique
 import UniqFM
+import Util
 
 import qualified Data.Array as A
 import Data.IORef
@@ -56,8 +57,10 @@ data HieName
   deriving (Eq)
 
 instance Ord HieName where
-  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)
-  compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)
+  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` SrcLoc.leftmost_smallest c f
+    -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
+  compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` SrcLoc.leftmost_smallest b d
+    -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
   compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
     -- Not actually non deterministic as it is a KnownKey
   compare ExternalName{} _ = LT

compiler/GHC/Rename/Binds.hs

@@ -64,7 +64,7 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
 import Data.Foldable      ( toList )
-import Data.List          ( partition, sort )
+import Data.List          ( partition, sortBy )
 import Data.List.NonEmpty ( NonEmpty(..) )
 
 {-
@@ -1296,7 +1296,7 @@ dupSigDeclErr pairs@((L loc name, sig) :| _)
   = addErrAt loc $
     vcat [ text "Duplicate" <+> what_it_is
            <> text "s for" <+> quotes (ppr name)
-         , text "at" <+> vcat (map ppr $ sort
+         , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest
                                        $ map (getLoc . fst)
                                        $ toList pairs)
          ]
@@ -1332,6 +1332,6 @@ dupMinimalSigErr :: [LSig GhcPs] -> RnM ()
 dupMinimalSigErr sigs@(L loc _ : _)
   = addErrAt loc $
     vcat [ text "Multiple minimal complete definitions"
-         , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs)
+         , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLoc sigs)
          , text "Combine alternative minimal complete definitions with `|'" ]
 dupMinimalSigErr [] = panic "dupMinimalSigErr"

compiler/GHC/Rename/Env.hs

@@ -80,8 +80,9 @@ import GHC.Rename.Unbound
 import GHC.Rename.Utils
 import qualified Data.Semigroup as Semi
 import Data.Either      ( partitionEithers )
-import Data.List        (find)
+import Data.List        ( find, sortBy )
 import Control.Arrow    ( first )
+import Data.Function
 
 {-
 *********************************************************
@@ -349,7 +350,7 @@ sameNameErr gres@(_ : _)
   = hang (text "Same exact name in multiple name-spaces:")
        2 (vcat (map pp_one sorted_names) $$ th_hint)
   where
-    sorted_names = sortWith nameSrcLoc (map gre_name gres)
+    sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map gre_name gres)
     pp_one name
       = hang (pprNameSpace (occNameSpace (getOccName name))
               <+> quotes (ppr name) <> comma)

compiler/GHC/Rename/Names.hs

@@ -71,6 +71,7 @@ import Data.Map         ( Map )
 import qualified Data.Map as Map
 import Data.Ord         ( comparing )
 import Data.List        ( partition, (\\), find, sortBy )
+import Data.Function    ( on )
 import qualified Data.Set as S
 import System.FilePath  ((</>))
 
@@ -1395,7 +1396,7 @@ findImportUsage imports used_gres
     unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
       = (decl, used_gres, nameSetElemsStable unused_imps)
       where
-        used_gres = Map.lookup (srcSpanEnd loc) import_usage
+        used_gres = lookupSrcLoc (srcSpanEnd loc) import_usage
                                -- srcSpanEnd: see Note [The ImportMap]
                     `orElse` []
 
@@ -1459,7 +1460,7 @@ It's just a cheap hack; we could equally well use the Span too.
 The [GlobalRdrElt] are the things imported from that decl.
 -}
 
-type ImportMap = Map SrcLoc [GlobalRdrElt]  -- See [The ImportMap]
+type ImportMap = Map RealSrcLoc [GlobalRdrElt]  -- See [The ImportMap]
      -- If loc :-> gres, then
      --   'loc' = the end loc of the bestImport of each GRE in 'gres'
 
@@ -1470,12 +1471,13 @@ mkImportMap :: [GlobalRdrElt] -> ImportMap
 mkImportMap gres
   = foldr add_one Map.empty gres
   where
-    add_one gre@(GRE { gre_imp = imp_specs }) imp_map
-       = Map.insertWith add decl_loc [gre] imp_map
+    add_one gre@(GRE { gre_imp = imp_specs }) imp_map =
+      case srcSpanEnd (is_dloc (is_decl best_imp_spec)) of
+                              -- For srcSpanEnd see Note [The ImportMap]
+       RealSrcLoc decl_loc -> Map.insertWith add decl_loc [gre] imp_map
+       UnhelpfulLoc _ -> imp_map
        where
           best_imp_spec = bestImport imp_specs
-          decl_loc      = srcSpanEnd (is_dloc (is_decl best_imp_spec))
-                        -- For srcSpanEnd see Note [The ImportMap]
           add _ gres = gre : gres
 
 warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name)
@@ -1780,7 +1782,9 @@ addDupDeclErr gres@(gre : _)
                    vcat (map (ppr . nameSrcLoc) sorted_names)]
   where
     name = gre_name gre
-    sorted_names = sortWith nameSrcLoc (map gre_name gres)
+    sorted_names =
+      sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan)
+             (map gre_name gres)
 
 
 

compiler/GHC/Rename/Source.hs

@@ -1475,13 +1475,13 @@ dupRoleAnnotErr list
           quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
        2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
     where
-      sorted_list = NE.sortBy cmp_annot list
+      sorted_list = NE.sortBy cmp_loc list
       ((L loc first_decl) :| _) = sorted_list
 
       pp_role_annot (L loc decl) = hang (ppr decl)
                                       4 (text "-- written at" <+> ppr loc)
 
-      cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
+      cmp_loc = SrcLoc.leftmost_smallest `on` getLoc
 
 dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()
 dupKindSig_Err list
@@ -1496,7 +1496,7 @@ dupKindSig_Err list
       pp_kisig (L loc decl) =
         hang (ppr decl) 4 (text "-- written at" <+> ppr loc)
 
-      cmp_loc (L loc1 _) (L loc2 _) = loc1 `compare` loc2
+      cmp_loc = SrcLoc.leftmost_smallest `on` getLoc
 
 {- Note [Role annotations in the renamer]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

compiler/GHC/Rename/Unbound.hs

@@ -310,10 +310,13 @@ importSuggestions where_look global_env hpt currMod imports rdr_name
   -- We want to keep only one for each original module; preferably one with an
   -- explicit import list (for no particularly good reason)
   pick :: [ImportedModsVal] -> Maybe ImportedModsVal
-  pick = listToMaybe . sortBy (compare `on` prefer) . filter select
+  pick = listToMaybe . sortBy cmp . filter select
     where select imv = case mod_name of Just name -> imv_name imv == name
                                         Nothing   -> not (imv_qualified imv)
-          prefer imv = (imv_is_hiding imv, imv_span imv)
+          cmp a b =
+            (compare `on` imv_is_hiding) a b
+              `thenCmp`
+            (SrcLoc.leftmost_smallest `on` imv_span) a b
 
   -- Which of these would export a 'foo'
   -- (all of these are restricted imports, because if they were not, we

compiler/GHC/Rename/Utils.hs

@@ -426,7 +426,7 @@ dupNamesErr get_loc names
   where
     locs      = map get_loc (NE.toList names)
     big_loc   = foldr1 combineSrcSpans locs
-    locations = text "Bound at:" <+> vcat (map ppr (sort locs))
+    locations = text "Bound at:" <+> vcat (map ppr (sortBy SrcLoc.leftmost_smallest locs))
 
 badQualBndrErr :: RdrName -> SDoc
 badQualBndrErr rdr_name

compiler/basicTypes/RdrName.hs

@@ -1128,7 +1128,7 @@ shadowName env name
 -- It's quite elaborate so that we can give accurate unused-name warnings.
 data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,
                             is_item :: ImpItemSpec }
-                deriving( Eq, Ord, Data )
+                deriving( Eq, Data )
 
 -- | Import Declaration Specification
 --
@@ -1145,7 +1145,7 @@ data ImpDeclSpec
         is_as       :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause)
         is_qual     :: Bool,       -- ^ Was this import qualified?
         is_dloc     :: SrcSpan     -- ^ The location of the entire import declaration
-    } deriving Data
+    } deriving (Eq, Data)
 
 -- | Import Item Specification
 --
@@ -1166,26 +1166,7 @@ data ImpItemSpec
         --
         -- Here the constructors of @T@ are not named explicitly;
         -- only @T@ is named explicitly.
-  deriving Data
-
-instance Eq ImpDeclSpec where
-  p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False
-
-instance Ord ImpDeclSpec where
-   compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp`
-                     (is_dloc is1 `compare` is_dloc is2)
-
-instance Eq ImpItemSpec where
-  p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False
-
-instance Ord ImpItemSpec where
-   compare is1 is2 =
-    case (is1, is2) of
-      (ImpAll, ImpAll) -> EQ
-      (ImpAll, _)      -> GT
-      (_, ImpAll)      -> LT
-      (ImpSome _ l1, ImpSome _ l2) -> l1 `compare` l2
-
+  deriving (Eq, Data)
 
 bestImport :: [ImportSpec] -> ImportSpec
 -- See Note [Choosing the best import declaration]
@@ -1203,7 +1184,7 @@ bestImport iss
          (ImpSpec { is_item = item2, is_decl = d2 })
       = (is_qual d1 `compare` is_qual d2) `thenCmp`
         (best_item item1 item2)           `thenCmp`
-        (is_dloc d1 `compare` is_dloc d2)
+        SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2)
 
     best_item :: ImpItemSpec -> ImpItemSpec -> Ordering
     best_item ImpAll ImpAll = EQ

compiler/basicTypes/SrcLoc.hs

@@ -82,8 +82,10 @@ module SrcLoc (
 
         -- ** Combining and comparing Located values
         eqLocated, cmpLocated, combineLocs, addCLoc,
-        leftmost_smallest, leftmost_largest, rightmost,
+        leftmost_smallest, leftmost_largest, rightmost_smallest,
         spans, isSubspanOf, isRealSubspanOf, sortLocated,
+        sortRealLocated,
+        lookupSrcLoc, lookupSrcSpan,
 
         liftL
     ) where
@@ -99,7 +101,8 @@ import Control.DeepSeq
 import Data.Bits
 import Data.Data
 import Data.List (sortBy, intercalate)
-import Data.Ord
+import Data.Function (on)
+import qualified Data.Map as Map
 
 {-
 ************************************************************************
@@ -125,7 +128,7 @@ data RealSrcLoc
 data SrcLoc
   = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
   | UnhelpfulLoc FastString     -- Just a general indication
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Show)
 
 {-
 ************************************************************************
@@ -180,8 +183,19 @@ advanceSrcLoc (SrcLoc f l c) _    = SrcLoc f  l (c + 1)
 ************************************************************************
 -}
 
-sortLocated :: Ord l => [GenLocated l a] -> [GenLocated l a]
-sortLocated things = sortBy (comparing getLoc) things
+sortLocated :: [Located a] -> [Located a]
+sortLocated = sortBy (leftmost_smallest `on` getLoc)
+
+sortRealLocated :: [RealLocated a] -> [RealLocated a]
+sortRealLocated = sortBy (compare `on` getLoc)
+
+lookupSrcLoc :: SrcLoc -> Map.Map RealSrcLoc a -> Maybe a
+lookupSrcLoc (RealSrcLoc l) = Map.lookup l
+lookupSrcLoc (UnhelpfulLoc _) = const Nothing
+
+lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a
+lookupSrcSpan (RealSrcSpan l) = Map.lookup l
+lookupSrcSpan (UnhelpfulSpan _) = const Nothing
 
 instance Outputable RealSrcLoc where
     ppr (SrcLoc src_path src_line src_col)
@@ -254,8 +268,8 @@ data SrcSpan =
   | UnhelpfulSpan !FastString   -- Just a general indication
                                 -- also used to indicate an empty span
 
-  deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we
-                           -- derive Show for Token
+  deriving (Eq, Show) -- Show is used by Lexer.x, because we
+                      -- derive Show for Token
 
 instance ToJson SrcSpan where
   json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]
@@ -578,13 +592,20 @@ instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
 ************************************************************************
 -}
 
--- | Alternative strategies for ordering 'SrcSpan's
-leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering
-rightmost            = flip compare
-leftmost_smallest    = compare
-leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b)
-                                `thenCmp`
-                       (srcSpanEnd b `compare` srcSpanEnd a)
+-- | Strategies for ordering 'SrcSpan's
+leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering
+rightmost_smallest = compareSrcSpanBy (flip compare)
+leftmost_smallest = compareSrcSpanBy compare
+leftmost_largest = compareSrcSpanBy $ \a b ->
+  (realSrcSpanStart a `compare` realSrcSpanStart b)
+    `thenCmp`
+  (realSrcSpanEnd b `compare` realSrcSpanEnd a)
+
+compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering
+compareSrcSpanBy cmp (RealSrcSpan a)   (RealSrcSpan b)   = cmp a b
+compareSrcSpanBy _   (RealSrcSpan _)   (UnhelpfulSpan _) = LT
+compareSrcSpanBy _   (UnhelpfulSpan _) (RealSrcSpan _)   = GT
+compareSrcSpanBy _   (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ
 
 -- | Determines whether a span encloses a given line and column index
 spans :: SrcSpan -> (Int, Int) -> Bool

compiler/main/ErrUtils.hs

@@ -84,7 +84,7 @@ import Data.List
 import qualified Data.Set as Set
 import Data.IORef
 import Data.Maybe       ( fromMaybe )
-import Data.Ord
+import Data.Function
 import Data.Time
 import Debug.Trace
 import Control.Monad
@@ -409,12 +409,10 @@ pprLocErrMsg (ErrMsg { errMsgSpan      = s
     withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx doc)
 
 sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
-sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList
-  where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
-        maybeFlip
-          | fromMaybe False (fmap reverseErrors dflags) = flip
-          | otherwise                                   = id
-        cmp = comparing errMsgSpan
+sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
+  where cmp
+          | fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest
+          | otherwise                                   = SrcLoc.leftmost_smallest
         maybeLimit = case join (fmap maxErrors dflags) of
           Nothing        -> id
           Just err_limit -> take err_limit

compiler/typecheck/FamInst.hs

@@ -44,7 +44,9 @@ import VarSet
 import FV
 import Bag( Bag, unionBags, unitBag )
 import Control.Monad
+import Data.List ( sortBy )
 import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.Function ( on )
 
 import qualified GHC.LanguageExtensions  as LangExt
 
@@ -1032,7 +1034,7 @@ reportConflictInstErr _ []
   = return ()  -- No conflicts
 reportConflictInstErr fam_inst (match1 : _)
   | FamInstMatch { fim_instance = conf_inst } <- match1
-  , let sorted  = sortWith getSpan [fam_inst, conf_inst]
+  , let sorted  = sortBy (SrcLoc.leftmost_smallest `on` getSpan) [fam_inst, conf_inst]
         fi1     = head sorted
         span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))
   = setSrcSpan span $ addErr $
@@ -1041,8 +1043,8 @@ reportConflictInstErr fam_inst (match1 : _)
                | fi <- sorted
                , let ax = famInstAxiom fi ])
  where
-   getSpan = getSrcLoc . famInstAxiom
-   -- The sortWith just arranges that instances are displayed in order
+   getSpan = getSrcSpan . famInstAxiom
+   -- The sortBy just arranges that instances are displayed in order
    -- of source location, which reduced wobbling in error messages,
    -- and is better for users
 

compiler/typecheck/Inst.hs

@@ -76,7 +76,9 @@ import Outputable
 import BasicTypes ( TypeOrKind(..) )
 import qualified GHC.LanguageExtensions as LangExt
 
+import Data.List ( sortBy )
 import Control.Monad( unless )
+import Data.Function ( on )
 
 {-
 ************************************************************************
@@ -844,7 +846,7 @@ addClsInstsErr herald ispecs
   = setSrcSpan (getSrcSpan (head sorted)) $
     addErr (hang herald 2 (pprInstances sorted))
  where
-   sorted = sortWith getSrcLoc ispecs
-   -- The sortWith just arranges that instances are displayed in order
+   sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs