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 SrcSpan  to keep working correctly, we must *ignore* additional
information when comparing SrcSpan values:

	instance Ord SrcSpan where
	  compare (RealSrcSpan r1 _) (RealSrcSpan r2 _) = compare r1 r2
	  ...

However, this would violate an important law:

	a == b  therefore  f a == f b

Ignoring  AdditionalInformation  in comparisons would mean that with
f=getAdditionalInformation, the law above does not hold.

A more robust design is to avoid  Ord SrcSpan  altogether, which is what this patch implements.
The mappings are changed to use RealSrcSpan instead:

	blackList :: Set RealSrcSpan         -- compiler/GHC/HsToCore/Coverage.hs
	instanceMap :: Map RealSrcSpan Name  -- compiler/GHC/HsToCore/Docs.hs

All SrcSpan comparisons are now done with explicit comparison strategies:

	SrcLoc.leftmost_smallest
	SrcLoc.leftmost_largest
	SrcLoc.rightmost_smallest

These strategies are not subject to the law mentioned above and can easily
discard both the string stored in  UnhelpfulSpan  and  AdditionalInformation.

Updates haddock submodule.

23 files changed, 129 insertions, 114 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 9200f27809..392d695997 100644
--- a/compiler/GHC.hs
+++ b/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
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 6796216c87..483a952e62 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/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
diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs
index 34709b71f1..dabedb5fb6 100644
--- a/compiler/GHC/Hs/Types.hs
+++ b/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
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index a87d46bbcc..b93f04b3fa 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/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
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index e08b46729e..e6c63efade 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/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.
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index e9d7a2ca50..d6525f83f2 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/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
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index 91fe256cc8..d89a346d9f 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/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
diff --git a/compiler/GHC/Rename/Binds.hs b/compiler/GHC/Rename/Binds.hs
index a9a3653e0d..e50c97d54c 100644
--- a/compiler/GHC/Rename/Binds.hs
+++ b/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"
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 8e24004653..d66226579b 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/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)
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 48208dba46..d57453fdd7 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/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)
 
 
 
diff --git a/compiler/GHC/Rename/Source.hs b/compiler/GHC/Rename/Source.hs
index 9bb577f48b..8237e32877 100644
--- a/compiler/GHC/Rename/Source.hs
+++ b/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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs
index 1e494331e4..4380e9ef17 100644
--- a/compiler/GHC/Rename/Unbound.hs
+++ b/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
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 11cbb745bc..998bd974d9 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/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
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index 634f5eb2ec..82584b0903 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/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
diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs
index 199888ced6..113756ffea 100644
--- a/compiler/basicTypes/SrcLoc.hs
+++ b/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
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 5adc4c61f4..94ed59eccd 100644
--- a/compiler/main/ErrUtils.hs
+++ b/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
diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs
index 43ebcba8a7..748e9fd8bf 100644
--- a/compiler/typecheck/FamInst.hs
+++ b/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
 
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index edc986f6ff..525fa7ebf3 100644
--- a/compiler/typecheck/Inst.hs
+++ b/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
+   -- The sortBy just arranges that instances are displayed in order
    -- of source location, which reduced wobbling in error messages,
    -- and is better for users
diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
index 4b3f434b39..7fbf553afa 100644
--- a/compiler/typecheck/TcRnExports.hs
+++ b/compiler/typecheck/TcRnExports.hs
@@ -849,6 +849,8 @@ exportClashErr global_env occ name1 name2 ie1 ie2
         = fromMaybe (pprPanic "exportClashErr" (ppr name))
                     (lookupGRE_Name_OccName global_env name occ)
     get_loc name = greSrcSpan (get_gre name)
-    (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
-                                   then (name1, ie1, name2, ie2)
-                                   else (name2, ie2, name1, ie1)
+    (name1', ie1', name2', ie2') =
+      case SrcLoc.leftmost_smallest (get_loc name1) (get_loc name2) of
+        LT -> (name1, ie1, name2, ie2)
+        GT -> (name2, ie2, name1, ie1)
+        EQ -> panic "exportClashErr: clashing exports have idential location"
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 2559152954..ef78dca036 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -1325,8 +1325,9 @@ printTypeOfNames names
  = mapM_ (printTypeOfName ) $ sortBy compareNames names
 
 compareNames :: Name -> Name -> Ordering
-n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
-    where compareWith n = (getOccString n, getSrcSpan n)
+n1 `compareNames` n2 =
+  (compare `on` getOccString) n1 n2 `thenCmp`
+  (SrcLoc.leftmost_smallest `on` getSrcSpan) n1 n2
 
 printTypeOfName :: GHC.GhcMonad m => Name -> m ()
 printTypeOfName n
@@ -2406,7 +2407,7 @@ browseModule bang modl exports_only = do
                 -- has a good source location, then they all should.
                 loc_sort ns
                       | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)
-                      = sortBy (compare `on` nameSrcSpan) ns
+                      = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) ns
                       | otherwise
                       = occ_sort ns
 
diff --git a/testsuite/tests/quasiquotation/T7918.hs b/testsuite/tests/quasiquotation/T7918.hs
index a5a2ddfb70..da770f11c1 100644
--- a/testsuite/tests/quasiquotation/T7918.hs
+++ b/testsuite/tests/quasiquotation/T7918.hs
@@ -7,6 +7,7 @@ import Outputable
 import MonadUtils
 import NameSet
 import Var
+import SrcLoc
 
 import Data.Data
 
@@ -14,7 +15,7 @@ import System.Environment
 import Control.Monad
 import Control.Monad.Trans.State
 import Data.List (sortBy)
-import Data.Ord
+import Data.Function
 import Prelude hiding (traverse)
 
 type Traverse a = State (SrcSpan, [(Name, SrcSpan)]) a
@@ -71,7 +72,7 @@ test7918 = do
 
   typecheckedB <- getModSummary (mkModuleName "T7918B") >>= parseModule >>= typecheckModule
   let (_loc, ids) = execState (traverse (tm_typechecked_source typecheckedB)) (noSrcSpan, [])
-  liftIO . forM_ (sortBy (comparing snd) (reverse ids)) $ putStrLn . showSDoc dynFlags . ppr
+  liftIO . forM_ (sortBy (SrcLoc.leftmost_smallest `on` snd) (reverse ids)) $ putStrLn . showSDoc dynFlags . ppr
 
 main :: IO ()
 main = do
diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs
index 227e47d0b5..c5561a8567 100644
--- a/utils/check-ppr/Main.hs
+++ b/utils/check-ppr/Main.hs
@@ -91,7 +91,7 @@ getPragmas anns = pragmaStr
     tokComment (L _ (AnnLineComment  s)) = s
     tokComment _ = ""
 
-    comments = map tokComment $ sortLocated $ apiAnnRogueComments anns
+    comments = map tokComment $ sortRealLocated $ apiAnnRogueComments anns
     pragmas = filter (\c -> isPrefixOf "{-#" c ) comments
     pragmaStr = intercalate "\n" pragmas
 
diff --git a/utils/haddock b/utils/haddock
-Subproject 70c86ff53f97ed9b6a41b90c61357de2ac44d70
+Subproject 844c0c47a223e2e1bb3767afc05639269dad8ee