Commit 26e8fff3 authored by Vladislav Zavialov's avatar Vladislav Zavialov Committed by Marge Bot

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.
parent 1d9df9e0
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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.
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......@@ -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)
......
......@@ -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)
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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"
......@@ -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
......
......@@ -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
......
......@@ -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
......
Subproject commit 70c86ff53f97ed9b6a41b90c61357de2ac44d702
Subproject commit 844c0c47a223e2e1bb3767afc05639269dad8ee9
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment