aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
authorAlec Theriault <alec.theriault@gmail.com>2018-07-20 03:02:16 -0700
committerAlexander Biehl <alexbiehl@gmail.com>2018-07-20 12:02:16 +0200
commit2de7c2acf9b1ec85b09027a8bb58bf8512e91c05 (patch)
tree3c6ee4683f58ba78efda6b8cc740e609c56d0ad0 /haddock-api/src/Haddock/Backends
parent133e9c2c168db19c1135479f7ab144c4e33af2a4 (diff)
Fix broken instance source links (#869)
The problem manifests itself in instances that are defined in modules other than the module where the class is defined. The fix is just to thread through the 'Module' of the instance further along. Since orphan instances appear to already have been working, I didn't do anything there.
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs8
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs33
2 files changed, 22 insertions, 19 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 1daf9ace..01380c94 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -572,9 +572,9 @@ ppInstances links origin instances splice unicode pkg qual
-- force Splice = True to use line URLs
where
instName = getOccString origin
- instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)
+ instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)
instDecl no (inst, mdoc, loc, mdl) =
- ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), loc)
+ ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), mdl, loc)
ppOrphanInstances :: LinksInfo
@@ -587,9 +587,9 @@ ppOrphanInstances links instances splice unicode pkg qual
instOrigin :: InstHead name -> InstOrigin (IdP name)
instOrigin inst = OriginClass (ihdClsName inst)
- instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)
+ instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)
instDecl no (inst, mdoc, loc, mdl) =
- ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst mdl), loc)
+ ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing), mdl, loc)
ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 501caa4b..1c44ffda 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -40,7 +40,6 @@ module Haddock.Backends.Xhtml.Layout (
topDeclElem, declElem,
) where
-
import Haddock.Backends.Xhtml.DocMarkup
import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
@@ -48,6 +47,7 @@ import Haddock.Types
import Haddock.Utils (makeAnchorId, nameAnchorId)
import qualified Data.Map as Map
import Text.XHtml hiding ( name, title, quote )
+import Data.Maybe (fromMaybe)
import FastString ( unpackFS )
import GHC
@@ -151,20 +151,22 @@ subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls)
-- | Sub table with source information (optional).
subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool
- -> [(SubDecl,Located DocName)] -> Maybe Html
+ -> [(SubDecl, Maybe Module, Located DocName)] -> Maybe Html
subTableSrc _ _ _ _ [] = Nothing
subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)
where
- subRow ((decl, mdoc, subs),L loc dn) =
+ subRow ((decl, mdoc, subs), mdl, L loc dn) =
(td ! [theclass "src clearfix"] <<
(thespan ! [theclass "inst-left"] << decl)
- <+> linkHtml loc dn
+ <+> linkHtml loc mdl dn
<->
docElement td << fmap (docToHtml Nothing pkg qual) mdoc
)
: map (cell . (td <<)) subs
- linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn
- linkHtml _ _ = noHtml
+
+ linkHtml :: SrcSpan -> Maybe Module -> DocName -> Html
+ linkHtml loc@(RealSrcSpan _) mdl dn = links lnks loc splice mdl dn
+ linkHtml _ _ _ = noHtml
subBlock :: [Html] -> Maybe Html
subBlock [] = Nothing
@@ -197,7 +199,7 @@ subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual
subInstances :: Maybe Package -> Qualification
-> String -- ^ Class name, used for anchor generation
-> LinksInfo -> Bool
- -> [(SubDecl,Located DocName)] -> Html
+ -> [(SubDecl, Maybe Module, Located DocName)] -> Html
subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable
where
wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents))
@@ -209,7 +211,7 @@ subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable
subOrphanInstances :: Maybe Package -> Qualification
-> LinksInfo -> Bool
- -> [(SubDecl,Located DocName)] -> Html
+ -> [(SubDecl, Maybe Module, Located DocName)] -> Html
subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable
where
wrap = ((h1 << "Orphan instances") +++)
@@ -268,13 +270,13 @@ declElem = paragraph ! [theclass "src"]
-- it adds a source and wiki link at the right hand side of the box
topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
topDeclElem lnks loc splice names html =
- declElem << (html <+> (links lnks loc splice $ head names))
+ declElem << (html <+> (links lnks loc splice Nothing $ head names))
-- FIXME: is it ok to simply take the first name?
-- | Adds a source and wiki link at the right hand side of the box.
-- Name must be documented, otherwise we wouldn't get here.
-links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html
-links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice docName@(Documented n mdl) =
+links :: LinksInfo -> SrcSpan -> Bool -> Maybe Module -> DocName -> Html
+links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice mdl' docName@(Documented n mdl) =
srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#")
where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName)))
@@ -298,12 +300,13 @@ links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice docName@(Docume
-- For source links, we want to point to the original module,
-- because only that will have the source.
- -- TODO: do something about type instances. They will point to
- -- the module defining the type family, which is wrong.
- origMod = nameModule n
+ --
+ -- 'mdl'' is a way of "overriding" the module. Without it, instances
+ -- will point to the module defining the class/family, which is wrong.
+ origMod = fromMaybe (nameModule n) mdl'
origPkg = moduleUnitId origMod
fname = case loc of
RealSrcSpan l -> unpackFS (srcSpanFile l)
UnhelpfulSpan _ -> error "links: UnhelpfulSpan"
-links _ _ _ _ = noHtml
+links _ _ _ _ _ = noHtml