aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-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.hs12
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs18
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs4
-rw-r--r--haddock-api/src/Haddock/Types.hs2
6 files changed, 35 insertions, 23 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 1043453d..38fccf0c 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -530,14 +530,14 @@ ppDocInstances unicode (i : rest)
(is, rest') = spanWith isUndocdInstance rest
isUndocdInstance :: DocInstance a -> Maybe (InstHead a)
-isUndocdInstance (i,Nothing,_) = Just i
+isUndocdInstance (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 DocNameI -> LaTeX
-ppDocInstance unicode (instHead, doc, _) =
+ppDocInstance unicode (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 6e733373..d92bdd3a 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -566,8 +566,8 @@ ppInstances links origin instances splice unicode qual
where
instName = getOccString origin
instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)
- instDecl no (inst, mdoc, loc) =
- ((ppInstHead links splice unicode qual mdoc origin False no inst), loc)
+ instDecl no (inst, mdoc, loc, mdl) =
+ ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), loc)
ppOrphanInstances :: LinksInfo
@@ -581,8 +581,8 @@ ppOrphanInstances links instances splice unicode qual
instOrigin inst = OriginClass (ihdClsName inst)
instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)
- instDecl no (inst, mdoc, loc) =
- ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc)
+ instDecl no (inst, mdoc, loc, mdl) =
+ ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst mdl), loc)
ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
@@ -591,13 +591,14 @@ ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
-> Bool -- ^ Is instance orphan
-> Int -- ^ Normal
-> InstHead DocNameI
+ -> Maybe Module
-> SubDecl
-ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
+ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) mdl =
case ihdInstType of
ClassInst { .. } ->
( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ
, mdoc
- , [subInstDetails iid ats sigs]
+ , [subInstDetails iid ats sigs mname]
)
where
sigs = ppInstanceSigs links splice unicode qual clsiSigs
@@ -605,7 +606,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
TypeInst rhs ->
( subInstHead iid ptype
, mdoc
- , [subFamInstDetails iid prhs]
+ , [subFamInstDetails iid prhs mname]
)
where
ptype = keyword "type" <+> typ
@@ -614,11 +615,12 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
DataInst dd ->
( subInstHead iid pdata
, mdoc
- , [subFamInstDetails iid pdecl])
+ , [subFamInstDetails iid pdecl mname])
where
pdata = keyword "data" <+> typ
pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
where
+ mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl
iid = instanceId origin no orphan ihd
typ = ppAppNameTypes ihdClsName ihdTypes unicode qual
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index e020b909..217ca2af 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -47,7 +47,7 @@ import Haddock.Backends.Xhtml.Utils
import Haddock.Types
import Haddock.Utils (makeAnchorId, nameAnchorId)
import qualified Data.Map as Map
-import Text.XHtml hiding ( name, title, p, quote )
+import Text.XHtml hiding ( name, title, quote )
import FastString ( unpackFS )
import GHC
@@ -228,15 +228,17 @@ subInstHead iid hdr =
subInstDetails :: String -- ^ Instance unique id (for anchor generation)
-> [Html] -- ^ Associated type contents
-> [Html] -- ^ Method contents (pretty-printed signatures)
+ -> Html -- ^ Source module
-> Html
-subInstDetails iid ats mets =
- subInstSection iid << (subAssociatedTypes ats <+> subMethods mets)
+subInstDetails iid ats mets mdl =
+ subInstSection iid << (p mdl <+> subAssociatedTypes ats <+> subMethods mets)
subFamInstDetails :: String -- ^ Instance unique id (for anchor generation)
-> Html -- ^ Type or data family instance
+ -> Html -- ^ Source module TODO: use this
-> Html
-subFamInstDetails iid fi =
- subInstSection iid << thediv ! [theclass "src"] << fi
+subFamInstDetails iid fi mdl =
+ subInstSection iid << (p mdl <+> (thediv ! [theclass "src"] << fi))
subInstSection :: String -- ^ Instance unique id (for anchor generation)
-> Html
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index ec8b98c8..d0ed1698 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -69,7 +69,7 @@ attachInstances expInfo ifaces instIfaceMap = do
attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn]
attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
- [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n))
+ [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n), Nothing)
| let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
@@ -91,7 +91,11 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
let mb_instances = lookupNameEnv index (tcdName d)
cls_instances = maybeToList mb_instances >>= fst
fam_instances = maybeToList mb_instances >>= snd
- fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) )
+ fam_insts = [ ( synifyFamInst i opaque
+ , doc
+ , spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d))
+ , nameModule_maybe n
+ )
| i <- sortBy (comparing instFam) fam_instances
, let n = getName i
, let doc = instLookup instDocMap n iface ifaceMap instIfaceMap
@@ -99,14 +103,18 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
, not $ any (isTypeHidden expInfo) (fi_tys i)
, let opaque = isTypeHidden expInfo (fi_rhs i)
]
- cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d)))
+ cls_insts = [ ( synifyInstHead i
+ , instLookup instDocMap n iface ifaceMap instIfaceMap
+ , spanName n (synifyInstHead i) (L eSpan (tcdName d))
+ , nameModule_maybe n
+ )
| let is = [ (instanceSig 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 = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ]
- famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ]
+ cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]
+ famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ]
in do
dfs <- getDynFlags
let mkBug = (text "haddock-bug:" <+>) . text
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index df25e6a7..b2d0e1e1 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -627,11 +627,11 @@ renameWc rn_thing (HsWC { hswc_body = thing })
, hswc_wcs = PlaceHolder }) }
renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI)
-renameDocInstance (inst, idoc, L l n) = do
+renameDocInstance (inst, idoc, L l n, m) = do
inst' <- renameInstHead inst
n' <- rename n
idoc' <- mapM renameDoc idoc
- return (inst', idoc',L l n')
+ return (inst', idoc', L l n', m)
renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI)
renameExportItem item = case item of
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 725606b2..2810862f 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -388,7 +388,7 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
-- | An instance head that may have documentation and a source location.
-type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name))
+type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name), Maybe Module)
-- | The head of an instance. Consists of a class name, a list of type
-- parameters (which may be annotated with kinds), and an instance type
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 01:58:20 +0000