summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC.hs2
-rw-r--r--compiler/GHC/Hs/Binds.hs4
-rw-r--r--compiler/GHC/Hs/Types.hs1
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs20
-rw-r--r--compiler/GHC/HsToCore/Docs.hs37
-rw-r--r--compiler/GHC/HsToCore/Quote.hs4
-rw-r--r--compiler/GHC/Iface/Ext/Binary.hs7
-rw-r--r--compiler/GHC/Rename/Binds.hs6
-rw-r--r--compiler/GHC/Rename/Env.hs5
-rw-r--r--compiler/GHC/Rename/Names.hs18
-rw-r--r--compiler/GHC/Rename/Source.hs6
-rw-r--r--compiler/GHC/Rename/Unbound.hs7
-rw-r--r--compiler/GHC/Rename/Utils.hs2
-rw-r--r--compiler/basicTypes/RdrName.hs27
-rw-r--r--compiler/basicTypes/SrcLoc.hs49
-rw-r--r--compiler/main/ErrUtils.hs12
-rw-r--r--compiler/typecheck/FamInst.hs8
-rw-r--r--compiler/typecheck/Inst.hs6
-rw-r--r--compiler/typecheck/TcRnExports.hs8
-rw-r--r--ghc/GHCi/UI.hs7
-rw-r--r--testsuite/tests/quasiquotation/T7918.hs5
-rw-r--r--utils/check-ppr/Main.hs2
m---------utils/haddock0
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
View Lorry Controller Status