From 3d11080b9f56a901593b6237d674d617a429e64a Mon Sep 17 00:00:00 2001
From: jpmoresmau <jp@moresmau.fr>
Date: Sun, 17 May 2015 15:31:03 +0200
Subject: Attach to instance location the name that has the same location file
Fixes #383
---
.../src/Haddock/Interface/AttachInstances.hs | 23 +++++++++++++++++-----
haddock-api/src/Haddock/Interface/Rename.hs | 5 +++--
2 files changed, 21 insertions(+), 7 deletions(-)
(limited to 'haddock-api/src/Haddock/Interface')
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 37203d63..fc530507 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -38,6 +38,7 @@ import MonadUtils (liftIO)
import Name
import Outputable (text, sep, (<+>))
import PrelNames
+import SrcLoc
import TcRnDriver (tcRnGetInfo)
import TcType (tcSplitSigmaTy)
import TyCon
@@ -68,11 +69,11 @@ attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap
-> Ghc (ExportItem Name)
attachToExportItem expInfo iface ifaceMap instIfaceMap export =
case attachFixities export of
- e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do
+ e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do
mb_info <- getAllInfo (tcdName d)
insts <- case mb_info of
Just (_, _, cls_instances, fam_instances) ->
- let fam_insts = [ (L (getSrcSpan n) $ synifyFamInst i opaque, doc)
+ let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) )
| i <- sortBy (comparing instFam) fam_instances
, let n = getName i
, let doc = instLookup instDocMap n iface ifaceMap instIfaceMap
@@ -80,14 +81,14 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
, not $ any (isTypeHidden expInfo) (fi_tys i)
, let opaque = isTypeHidden expInfo (fi_rhs i)
]
- cls_insts = [ (L (getSrcSpan n) $ synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
+ cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d)))
| let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
]
-- fam_insts but with failing type fams filtered out
- cleanFamInsts = [ (L l fi, n) | (L l (Right fi), n) <- fam_insts ]
- famInstErrs = [ errm | (L _ (Left errm), _) <- fam_insts ]
+ cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ]
+ famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ]
in do
dfs <- getDynFlags
let mkBug = (text "haddock-bug:" <+>) . text
@@ -106,6 +107,18 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
] }
attachFixities e = e
+ -- spanName: attach the location to the name that is the same file as the instance location
+ spanName s (clsn,_,_,_) (L instL instn) =
+ let s1 = getSrcSpan s
+ sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL
+ then instn
+ else clsn
+ in L (getSrcSpan s) sn
+ -- spanName on Either
+ spanNameE s (Left e) _ = L (getSrcSpan s) (Left e)
+ spanNameE s (Right ok) linst =
+ let L l r = spanName s ok linst
+ in L l (Right r)
instLookup :: (InstalledInterface -> Map.Map Name a) -> Name
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index ee9f8fc4..1a559764 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -498,10 +498,11 @@ renameExportItem item = case item of
decl' <- renameLDecl decl
doc' <- renameDocForDecl doc
subs' <- mapM renameSub subs
- instances' <- forM instances $ \(L l inst, idoc) -> do
+ instances' <- forM instances $ \(inst, idoc, L l n) -> do
inst' <- renameInstHead inst
+ n' <- rename n
idoc' <- mapM renameDoc idoc
- return (L l inst', idoc')
+ return (inst', idoc',L l n')
fixities' <- forM fixities $ \(name, fixity) -> do
name' <- lookupRn name
return (name', fixity)
--
cgit v1.2.3