aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs18
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs44
3 files changed, 43 insertions, 23 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index b717fc01..ee5bc861 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -544,14 +544,14 @@ ppDocInstances unicode (i : rest)
(is, rest') = spanWith isUndocdInstance rest
isUndocdInstance :: DocInstance a -> Maybe (InstHead a)
-isUndocdInstance (i,Nothing) = Just i
+isUndocdInstance (L _ i,Nothing) = Just i
isUndocdInstance _ = Nothing
-- | Print a possibly commented instance. The instance header is printed inside
-- an 'argBox'. The comment is printed to the right of the box in normal comment
-- style.
ppDocInstance :: Bool -> DocInstance DocName -> LaTeX
-ppDocInstance unicode (instHead, doc) =
+ppDocInstance unicode (L _ instHead, doc) =
declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 3bf4322d..d24a3f04 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -18,7 +18,6 @@ module Haddock.Backends.Xhtml.Decl (
tyvarNames
) where
-
import Haddock.Backends.Xhtml.DocMarkup
import Haddock.Backends.Xhtml.Layout
import Haddock.Backends.Xhtml.Names
@@ -270,7 +269,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
= subEquations qual $ map (ppTyFamEqn . unLoc) eqns
| otherwise
- = ppInstances instances docname unicode qual
+ = ppInstances links instances docname unicode qual
-- Individual equation of a closed type family
ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
@@ -492,18 +491,19 @@ ppClassDecl summary links instances fixities loc d subdocs
ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
where wrap | p = parens | otherwise = id
- instancesBit = ppInstances instances nm unicode qual
+ instancesBit = ppInstances links instances nm unicode qual
ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
-ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
-ppInstances instances baseName unicode qual
- = subInstances qual instName (map instDecl instances)
+ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
+ppInstances links instances baseName unicode qual
+ = subInstances qual instName links True baseName (map instDecl instances)
+ -- force Splice = True to use line URLs
where
instName = getOccString $ getName baseName
- instDecl :: DocInstance DocName -> SubDecl
- instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
+ instDecl :: DocInstance DocName -> (SubDecl,SrcSpan)
+ instDecl (L l inst, maybeDoc) = ((instHead inst, maybeDoc, []),l)
instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
<+> ppAppNameTypes n ks ts unicode qual
instHead (n, ks, ts, TypeInst rhs) = keyword "type"
@@ -582,7 +582,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
(map unLoc (con_names (unLoc c)))) fixities
]
- instancesBit = ppInstances instances docname unicode qual
+ instancesBit = ppInstances links instances docname unicode qual
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index b2c60534..923958a7 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -148,6 +148,20 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls)
docElement td << fmap (docToHtml Nothing qual) mdoc)
: map (cell . (td <<)) subs
+-- | Sub table with source information (optional).
+subTableSrc :: Qualification -> LinksInfo -> Bool -> DocName -> [(SubDecl,SrcSpan)] -> Maybe Html
+subTableSrc _ _ _ _ [] = Nothing
+subTableSrc qual lnks splice dn decls = Just $ table << aboves (concatMap subRow decls)
+ where
+ subRow ((decl, mdoc, subs),loc) =
+ (td ! [theclass "src"] << decl
+ <+> linkHtml loc
+ <->
+ docElement td << fmap (docToHtml Nothing qual) mdoc
+ )
+ : map (cell . (td <<)) subs
+ linkHtml loc@(RealSrcSpan _) = links lnks loc splice dn
+ linkHtml _ = noHtml
subBlock :: [Html] -> Maybe Html
subBlock [] = Nothing
@@ -174,13 +188,15 @@ subEquations :: Qualification -> [SubDecl] -> Html
subEquations qual = divSubDecls "equations" "Equations" . subTable qual
+-- | Generate sub table for instance declarations, with source
subInstances :: Qualification
-> String -- ^ Class name, used for anchor generation
- -> [SubDecl] -> Html
-subInstances qual nm = maybe noHtml wrap . instTable
+ -> LinksInfo -> Bool -> DocName
+ -> [(SubDecl,SrcSpan)] -> Html
+subInstances qual nm lnks splice dn = maybe noHtml wrap . instTable
where
wrap = (subSection <<) . (subCaption +++)
- instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual
+ instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice dn
subSection = thediv ! [theclass "subs instances"]
subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
id_ = makeAnchorId $ "i:" ++ nm
@@ -200,12 +216,19 @@ declElem = paragraph ! [theclass "src"]
-- a box for top level documented names
-- it adds a source and wiki link at the right hand side of the box
topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
-topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html =
- declElem << (html <+> srcLink <+> wikiLink)
+topDeclElem lnks loc splice names html =
+ declElem << (html <+> (links lnks loc splice $ 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 (Documented n mdl) =
+ (srcLink <+> wikiLink)
where srcLink = let nameUrl = Map.lookup origPkg sourceMap
lineUrl = Map.lookup origPkg lineMap
mUrl | splice = lineUrl
- -- Use the lineUrl as a backup
+ -- Use the lineUrl as a backup
| otherwise = maybe lineUrl Just nameUrl in
case mUrl of
Nothing -> noHtml
@@ -227,10 +250,7 @@ topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names htm
origMod = nameModule n
origPkg = modulePackageKey origMod
- -- Name must be documented, otherwise we wouldn't get here
- Documented n mdl = head names
- -- FIXME: is it ok to simply take the first name?
-
fname = case loc of
- RealSrcSpan l -> unpackFS (srcSpanFile l)
- UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan"
+ RealSrcSpan l -> unpackFS (srcSpanFile l)
+ UnhelpfulSpan _ -> error "links: UnhelpfulSpan"
+links _ _ _ _ = noHtml
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 06:58:10 +0000