From 26e8fff33b1b46ba559538b4519730c60c0d45e5 Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Wed, 19 Feb 2020 00:07:22 +0300 Subject: 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. --- compiler/GHC.hs | 2 +- compiler/GHC/Hs/Binds.hs | 4 +-- compiler/GHC/Hs/Types.hs | 1 - compiler/GHC/HsToCore/Coverage.hs | 20 +++++++------- compiler/GHC/HsToCore/Docs.hs | 37 ++++++++++++------------- compiler/GHC/HsToCore/Quote.hs | 4 +-- compiler/GHC/Iface/Ext/Binary.hs | 7 +++-- compiler/GHC/Rename/Binds.hs | 6 ++-- compiler/GHC/Rename/Env.hs | 5 ++-- compiler/GHC/Rename/Names.hs | 18 +++++++----- compiler/GHC/Rename/Source.hs | 6 ++-- compiler/GHC/Rename/Unbound.hs | 7 +++-- compiler/GHC/Rename/Utils.hs | 2 +- compiler/basicTypes/RdrName.hs | 27 +++--------------- compiler/basicTypes/SrcLoc.hs | 49 +++++++++++++++++++++++---------- compiler/main/ErrUtils.hs | 12 ++++---- compiler/typecheck/FamInst.hs | 8 ++++-- compiler/typecheck/Inst.hs | 6 ++-- compiler/typecheck/TcRnExports.hs | 8 ++++-- ghc/GHCi/UI.hs | 7 +++-- testsuite/tests/quasiquotation/T7918.hs | 5 ++-- utils/check-ppr/Main.hs | 2 +- utils/haddock | 2 +- 23 files changed, 130 insertions(+), 115 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 index 70c86ff53f..844c0c47a2 160000 --- a/utils/haddock +++ b/utils/haddock @@ -1 +1 @@ -Subproject commit 70c86ff53f97ed9b6a41b90c61357de2ac44d702 +Subproject commit 844c0c47a223e2e1bb3767afc05639269dad8ee9 -- cgit v1.2.1