aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVladislav Zavialov <vlad.z.4096@gmail.com>2020-02-19 00:25:40 +0300
committerVladislav Zavialov <vlad.z.4096@gmail.com>2020-02-22 15:33:02 +0300
commite185254b6cb8a7811eeed1f993612c90b2ff757e (patch)
treec562dba018bae7a161d54c9b5297fe53ffe119bf
parent70c86ff53f97ed9b6a41b90c61357de2ac44d702 (diff)
Use RealSrcSpan in InstMap
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs30
-rw-r--r--haddock-api/src/Haddock/Types.hs2
2 files changed, 13 insertions, 19 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index dd89c62f..94443856 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -377,9 +377,8 @@ mkMaps dflags pkgName gre instances decls = do
, [(Name, Map Int (MDoc Name))]
, [(Name, [LHsDecl GhcRn])]
)
- mappings (ldecl, docStrs) = do
- let L l decl = ldecl
- declDoc :: [HsDocString] -> Map Int HsDocString
+ mappings (ldecl@(L (RealSrcSpan l) decl), docStrs) = do
+ let declDoc :: [HsDocString] -> Map Int HsDocString
-> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name))
declDoc strs m = do
doc' <- processDocStrings dflags pkgName gre strs
@@ -407,12 +406,13 @@ mkMaps dflags pkgName gre instances decls = do
seqList subDocs `seq`
seqList subArgs `seq`
pure (dm, am, cm)
+ mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], [])
- 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 :: SrcSpan -> HsDecl GhcRn -> [Name]
- names _ (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
+ names :: RealSrcSpan -> HsDecl GhcRn -> [Name]
+ names _ (InstD _ d) = maybeToList (SrcLoc.lookupSrcSpan loc instanceMap) -- See note [2].
where loc = case d of
-- The CoAx's loc is the whole line, but only for TFs. The
-- workaround is to dig into the family instance declaration and
@@ -446,7 +446,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 <- [SrcLoc.lookupSrcSpan l instMap] ] ++ dataSubs defn
InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
-> dataSubs (feqn_rhs d)
@@ -471,7 +471,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 <- [SrcLoc.lookupSrcSpan l instMap] ]
extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
extract_deriv_ty (L l ty) =
@@ -523,7 +523,7 @@ typeDocs = go 0
-- | 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 . SrcLoc.sortLocated $ decls
where
decls = docs ++ defs ++ sigs ++ ats
docs = mkDecls tcdDocs (DocD noExtField) class_
@@ -536,7 +536,7 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
-- ordered by source location, with documentation attached if it exists.
topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
topDecls =
- filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
+ filterClasses . filterDecls . collectDocs . SrcLoc.sortLocated . ungroup
-- | Extract a map of fixity declarations only
mkFixMap :: HsGroup GhcRn -> FixMap
@@ -570,12 +570,6 @@ ungroup group_ =
mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]
-
--- | Sort by source location
-sortByLoc :: [Located a] -> [Located a]
-sortByLoc = sortBy (comparing getLoc)
-
-
--------------------------------------------------------------------------------
-- Filtering of declarations
--
@@ -1196,7 +1190,7 @@ mkVisibleNames (_, _, _, instMap) exports opts
where subs = map fst (expItemSubDocs e)
patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
name = case unLoc $ expItemDecl e of
- InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap
+ InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap
decl -> getMainDeclBinder decl
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
-- we don't want links to go to them.
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index c8e415c1..2c46e14a 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -55,7 +55,7 @@ type DocMap a = Map Name (MDoc a)
type ArgMap a = Map Name (Map Int (MDoc a))
type SubMap = Map Name [Name]
type DeclMap = Map Name [LHsDecl GhcRn]
-type InstMap = Map SrcSpan Name
+type InstMap = Map RealSrcSpan Name
type FixMap = Map Name Fixity
type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources