From e185254b6cb8a7811eeed1f993612c90b2ff757e Mon Sep 17 00:00:00 2001
From: Vladislav Zavialov <vlad.z.4096@gmail.com>
Date: Wed, 19 Feb 2020 00:25:40 +0300
Subject: Use RealSrcSpan in InstMap

---
 haddock-api/src/Haddock/Interface/Create.hs | 30 ++++++++++++-----------------
 haddock-api/src/Haddock/Types.hs            |  2 +-
 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
 
-- 
cgit v1.2.3