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.

6 files changed, 26 insertions, 18 deletions

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