summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-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
12 files changed, 62 insertions, 55 deletions
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
View Lorry Controller Status