aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock.hs6
-rw-r--r--src/Haddock/Backends/Hoogle.hs2
-rw-r--r--src/Haddock/Backends/LaTeX.hs6
-rw-r--r--src/Haddock/Backends/Xhtml.hs14
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs195
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs12
-rw-r--r--src/Haddock/Backends/Xhtml/Types.hs12
-rw-r--r--src/Haddock/Interface/Create.hs49
-rw-r--r--src/Haddock/Interface/Rename.hs4
-rw-r--r--src/Haddock/Options.hs18
-rw-r--r--src/Haddock/Types.hs4
11 files changed, 182 insertions, 140 deletions
diff --git a/src/Haddock.hs b/src/Haddock.hs
index cc7e7842..e4c7fdc0 100644
--- a/src/Haddock.hs
+++ b/src/Haddock.hs
@@ -242,9 +242,11 @@ render dflags flags qual ifaces installedIfaces srcMap = do
pkgStr = Just (packageIdString pkgId)
(pkgName,pkgVer) = modulePackageInfo pkgMod
- (srcBase, srcModule, srcEntity) = sourceUrls flags
+ (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity
- sourceUrls' = (srcBase, srcModule, srcMap')
+ -- TODO: Get these from the interface files as with srcMap
+ srcLMap' = maybe Map.empty (\path -> Map.singleton pkgId path) srcLEntity
+ sourceUrls' = (srcBase, srcModule, srcMap', srcLMap')
libDir <- getHaddockLibDir flags
prologue <- getPrologue dflags flags
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index dbce787f..6405861d 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -110,7 +110,7 @@ operator x = x
-- How to print each export
ppExport :: DynFlags -> ExportItem Name -> [String]
-ppExport dflags (ExportDecl decl dc subdocs _ _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
+ppExport dflags (ExportDecl decl dc subdocs _ _ _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
where
f (TyClD d@DataDecl{}) = ppData dflags d subdocs
f (TyClD d@SynDecl{}) = ppSynonym dflags d
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index e6108ab6..6535b24e 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -177,7 +177,7 @@ string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
exportListItem :: ExportItem DocName -> LaTeX
-exportListItem (ExportDecl decl _doc subdocs _insts _fixities)
+exportListItem (ExportDecl decl _doc subdocs _insts _fixities _splice)
= sep (punctuate comma . map ppDocBinder $ declNames decl) <>
case subdocs of
[] -> empty
@@ -212,7 +212,7 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t))))
- (Documentation Nothing Nothing, argDocs) _ _ _)
+ (Documentation Nothing Nothing, argDocs) _ _ _ _)
| Map.null argDocs = Just (map unLoc lnames, t)
isSimpleSig _ = Nothing
@@ -225,7 +225,7 @@ isExportModule _ = Nothing
processExport :: ExportItem DocName -> LaTeX
processExport (ExportGroup lev _id0 doc)
= ppDocGroup lev (docToLaTeX doc)
-processExport (ExportDecl decl doc subdocs insts fixities)
+processExport (ExportDecl decl doc subdocs insts fixities _splice)
= ppDecl decl doc insts subdocs fixities
processExport (ExportNoDecl y [])
= ppDocName y
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 4eda68f6..5e728108 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -130,9 +130,9 @@ headHtml docTitle miniPage themes =
srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
-srcButton (Just src_base_url, _, _) Nothing =
+srcButton (Just src_base_url, _, _, _) Nothing =
Just (anchor ! [href src_base_url] << "Source")
-srcButton (_, Just src_module_url, _) (Just iface) =
+srcButton (_, Just src_module_url, _, _) (Just iface) =
let url = spliceURL (Just $ ifaceOrigFilename iface)
(Just $ ifaceMod iface) Nothing Nothing src_module_url
in Just (anchor ! [href url] << "Source")
@@ -533,7 +533,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
-- todo: if something has only sub-docs, or fn-args-docs, should
-- it be measured here and thus prevent omitting the synopsis?
- has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _ _) = isJust mDoc || isJust mWarning
+ has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _ _ _) = isJust mDoc || isJust mWarning
has_doc (ExportNoDecl _ _) = False
has_doc (ExportModule _) = False
has_doc _ = True
@@ -578,7 +578,7 @@ miniSynopsis mdl iface unicode qual =
processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
-> [Html]
-processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts _fixities) =
+processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts _fixities _splice) =
((divTopDecl <<).(declElem <<)) <$> case decl0 of
TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
(FamDecl decl) -> [ppTyFamHeader True False decl unicode qual]
@@ -648,11 +648,11 @@ numberSectionHeadings = go 1
processExport :: Bool -> LinksInfo -> Bool -> Qualification
-> ExportItem DocName -> Maybe Html
-processExport _ _ _ _ (ExportDecl (L _ (InstD _)) _ _ _ _) = Nothing -- Hide empty instances
+processExport _ _ _ _ (ExportDecl (L _ (InstD _)) _ _ _ _ _) = Nothing -- Hide empty instances
processExport summary _ _ qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtml qual doc
-processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities)
- = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs unicode qual
+processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)
+ = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual
processExport summary _ _ qual (ExportNoDecl y [])
= processDeclOneLiner summary $ ppDocName qual Prefix True y
processExport summary _ _ qual (ExportNoDecl y subs)
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 20db5df1..5cc86d48 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -39,31 +39,33 @@ import Name
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
-> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
- -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html
-ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs unicode qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d unicode qual
- TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d unicode qual
- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d unicode qual
- SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities unicode qual
+ -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
+ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
+ TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
+ TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
+ SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual
SigD (PatSynSig lname args ty prov req) ->
- ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities unicode qual
- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities unicode qual
+ ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual
+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
InstD _ -> noHtml
_ -> error "declaration not supported by ppDecl"
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
- Bool -> Qualification -> Html
-ppLFunSig summary links loc doc lnames lty fixities unicode qual =
- ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities unicode qual
+ Splice -> Unicode -> Qualification -> Html
+ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =
+ ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities
+ splice unicode qual
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[DocName] -> HsType DocName -> [(DocName, Fixity)] ->
- Bool -> Qualification -> Html
-ppFunSig summary links loc doc docnames typ fixities unicode qual =
- ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ) unicode qual
+ Splice -> Unicode -> Qualification -> Html
+ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
+ ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ)
+ splice unicode qual
where
pp_typ = ppType unicode qual typ
@@ -71,18 +73,20 @@ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
Located DocName ->
HsPatSynDetails (LHsType DocName) -> LHsType DocName ->
LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] ->
- Bool -> Qualification -> Html
-ppLPatSig summary links loc doc lname args typ prov req fixities unicode qual =
- ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) fixities unicode qual
+ Splice -> Unicode -> Qualification -> Html
+ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual =
+ ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ)
+ (unLoc prov) (unLoc req) fixities splice unicode qual
ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
DocName ->
HsPatSynDetails (HsType DocName) -> HsType DocName ->
HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] ->
- Bool -> Qualification -> Html
-ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities unicode qual
+ Splice -> Unicode -> Qualification -> Html
+ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities
+ splice unicode qual
| summary = pref1
- | otherwise = topDeclElem links loc [docname] (ppFixities fixities qual <=> pref1)
+ | otherwise = topDeclElem links loc splice [docname] (ppFixities fixities qual <=> pref1)
+++ docSection qual doc
where
pref1 = hsep [ toHtml "pattern"
@@ -103,14 +107,15 @@ ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities un
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
[DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->
- Bool -> Qualification -> Html
-ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) unicode qual =
+ Splice -> Unicode -> Qualification -> Html
+ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
+ splice unicode qual =
ppTypeOrFunSig summary links loc docnames typ doc
( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
, addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
, dcolon unicode
)
- unicode qual
+ splice unicode qual
where
occnames = map (nameOccName . getName) docnames
addFixities html
@@ -119,11 +124,12 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) unicode q
ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
- -> DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification -> Html
-ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) unicode qual
+ -> DocForDecl DocName -> (Html, Html, Html)
+ -> Splice -> Unicode -> Qualification -> Html
+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual
| summary = pref1
- | Map.null argDocs = topDeclElem links loc docnames pref1 +++ docSection qual doc
- | otherwise = topDeclElem links loc docnames pref2 +++
+ | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection qual doc
+ | otherwise = topDeclElem links loc splice docnames pref2 +++
subArguments qual (do_args 0 sep typ) +++ docSection qual doc
where
argDoc n = Map.lookup n argDocs
@@ -171,20 +177,24 @@ tyvarNames = map getName . hsLTyVarNames
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
- -> ForeignDecl DocName -> [(DocName, Fixity)] -> Bool -> Qualification -> Html
-ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities unicode qual
- = ppFunSig summary links loc doc [name] typ fixities unicode qual
-ppFor _ _ _ _ _ _ _ _ = error "ppFor"
+ -> ForeignDecl DocName -> [(DocName, Fixity)]
+ -> Splice -> Unicode -> Qualification -> Html
+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities
+ splice unicode qual
+ = ppFunSig summary links loc doc [name] typ fixities splice unicode qual
+ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
-ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool
- -> Qualification -> Html
+ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan
+ -> DocForDecl DocName -> TyClDecl DocName
+ -> Splice -> Unicode -> Qualification -> Html
ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
, tcdRhs = ltype })
- unicode qual
+ splice unicode qual
= ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
- (fixs <=> full, fixs <=> hdr, spaceHtml +++ equals) unicode qual
+ (fixs <=> full, fixs <=> hdr, spaceHtml +++ equals)
+ splice unicode qual
where
hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
full = hdr <+> equals <+> ppLType unicode qual ltype
@@ -192,7 +202,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
fixs
| summary = noHtml
| otherwise = ppFixities fixities qual
-ppTySyn _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
+ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html
@@ -211,9 +221,11 @@ ppTyName = ppName Prefix
--------------------------------------------------------------------------------
-ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Bool -> Qualification -> Html
+ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
+ -> Unicode -> Qualification -> Html
ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
- , fdKindSig = mkind }) unicode qual =
+ , fdKindSig = mkind })
+ unicode qual =
(case info of
OpenTypeFamily
| associated -> keyword "type"
@@ -234,8 +246,8 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->
[(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
- FamilyDecl DocName -> Bool -> Qualification -> Html
-ppTyFam summary associated links instances fixities loc doc decl unicode qual
+ FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html
+ppTyFam summary associated links instances fixities loc doc decl splice unicode qual
| summary = ppTyFamHeader True associated decl unicode qual
| otherwise = header_ +++ docSection qual doc +++ instancesBit
@@ -243,7 +255,7 @@ ppTyFam summary associated links instances fixities loc doc decl unicode qual
where
docname = unLoc $ fdLName decl
- header_ = topDeclElem links loc [docname] $
+ header_ = topDeclElem links loc splice [docname] $
ppFixities fixities qual <=> ppTyFamHeader summary associated decl unicode qual
instancesBit
@@ -267,9 +279,9 @@ ppTyFam summary associated links instances fixities loc doc decl unicode qual
ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName
- -> [(DocName, Fixity)] -> Bool -> Qualification -> Html
-ppAssocType summ links doc (L loc decl) fixities unicode qual =
- ppTyFam summ True links [] fixities loc (fst doc) decl unicode qual
+ -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html
+ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
+ ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual
--------------------------------------------------------------------------------
@@ -293,7 +305,8 @@ ppDataBinderWithVars summ decl =
-- | Print an application of a DocName and two lists of HsTypes (kinds, types)
-ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> Qualification -> Html
+ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName]
+ -> Unicode -> Qualification -> Html
ppAppNameTypes n ks ts unicode qual =
ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual)
@@ -324,28 +337,28 @@ ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)
-------------------------------------------------------------------------------
-ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool
+ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode
-> Qualification -> Html
ppLContext = ppContext . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc
-ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html
+ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html
ppContextNoArrow [] _ _ = noHtml
ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual
-ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html
+ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html
ppContextNoLocs [] _ _ = noHtml
ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual
<+> darrow unicode
-ppContext :: HsContext DocName -> Bool -> Qualification -> Html
+ppContext :: HsContext DocName -> Unicode -> Qualification -> Html
ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
-ppHsContext :: [HsType DocName] -> Bool -> Qualification-> Html
+ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html
ppHsContext [] _ _ = noHtml
ppHsContext [p] unicode qual = ppCtxType unicode qual p
ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
@@ -358,7 +371,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
-> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
- -> Bool -> Qualification -> Html
+ -> Unicode -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
<+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
@@ -366,7 +379,7 @@ ppClassHdr summ lctxt n tvs fds unicode qual =
<+> ppFds fds unicode qual
-ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html
+ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html
ppFds fds unicode qual =
if null fds then noHtml else
char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
@@ -375,22 +388,22 @@ ppFds fds unicode qual =
ppVars = hsep . map (ppDocName qual Prefix True)
ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
- -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification
- -> Html
+ -> [(DocName, DocForDecl DocName)]
+ -> Splice -> Unicode -> Qualification -> Html
ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
, tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc
- subdocs unicode qual =
+ subdocs splice unicode qual =
if null sigs && null ats
- then (if summary then id else topDeclElem links loc [nm]) hdr
- else (if summary then id else topDeclElem links loc [nm]) (hdr <+> keyword "where")
+ then (if summary then id else topDeclElem links loc splice [nm]) hdr
+ else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")
+++ shortSubDecls
(
- [ ppAssocType summary links doc at [] unicode qual | at <- ats
+ [ ppAssocType summary links doc at [] splice unicode qual | at <- ats
, let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++
-- ToDo: add associated type defaults
- [ ppFunSig summary links loc doc names typ [] unicode qual
+ [ ppFunSig summary links loc doc names typ [] splice unicode qual
| L _ (TypeSig lnames (L _ typ)) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
@@ -401,24 +414,25 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
where
hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual
nm = unLoc lname
-ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)]
-> SrcSpan -> Documentation DocName
-> [(DocName, DocForDecl DocName)] -> TyClDecl DocName
- -> Bool -> Qualification -> Html
+ -> Splice -> Unicode -> Qualification -> Html
ppClassDecl summary links instances fixities loc d subdocs
decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
- , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) unicode qual
- | summary = ppShortClassDecl summary links decl loc subdocs unicode qual
+ , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })
+ splice unicode qual
+ | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual
| otherwise = classheader +++ docSection qual d
+++ atBit +++ methodBit +++ instancesBit
where
classheader
- | null lsigs = topDeclElem links loc [nm] (fixs <=> hdr unicode qual)
- | otherwise = topDeclElem links loc [nm] (fixs <=> hdr unicode qual <+> keyword "where")
+ | null lsigs = topDeclElem links loc splice [nm] (fixs <=> hdr unicode qual)
+ | otherwise = topDeclElem links loc splice [nm] (fixs <=> hdr unicode qual <+> keyword "where")
-- Only the fixity relevant to the class header
fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual
@@ -428,13 +442,13 @@ ppClassDecl summary links instances fixities loc d subdocs
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
-- ToDo: add assocatied typ defaults
- atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs unicode qual
+ atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual
| at <- ats
, let n = unL . fdLName $ unL at
doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
- methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs unicode qual
+ methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual
| L _ (TypeSig lnames (L _ typ)) <- lsigs
, let doc = lookupAnySubdoc (head names) subdocs
subfixs = [ f | n <- names
@@ -447,10 +461,10 @@ ppClassDecl summary links instances fixities loc d subdocs
instancesBit = ppInstances instances nm unicode qual
-ppClassDecl _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
-ppInstances :: [DocInstance DocName] -> DocName -> Bool -> Qualification -> Html
+ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
ppInstances instances baseName unicode qual
= subInstances qual instName (map instDecl instances)
where
@@ -476,7 +490,7 @@ lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
-- TODO: print contexts
-ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
ppShortDataDecl summary dataInst dataDecl unicode qual
| [] <- cons = dataHeader
@@ -504,9 +518,10 @@ ppShortDataDecl summary dataInst dataDecl unicode qual
ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->
[(DocName, DocForDecl DocName)] ->
- SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool ->
- Qualification -> Html
-ppDataDecl summary links instances fixities subdocs loc doc dataDecl unicode qual
+ SrcSpan -> Documentation DocName -> TyClDecl DocName ->
+ Splice -> Unicode -> Qualification -> Html
+ppDataDecl summary links instances fixities subdocs loc doc dataDecl
+ splice unicode qual
| summary = ppShortDataDecl summary False dataDecl unicode qual
| otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
@@ -516,7 +531,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl unicode qua
cons = dd_cons (tcdDataDefn dataDecl)
resTy = (con_res . unLoc . head) cons
- header_ = topDeclElem links loc [docname] (fix
+ header_ = topDeclElem links loc splice [docname] (fix
<=> ppDataHeader summary dataDecl unicode qual <+> whereBit)
fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual
@@ -537,7 +552,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl unicode qua
-ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Qualification -> Html
+ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html
ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
where
(cHead,cBody,cFoot) = ppShortConstrParts summary con unicode qual
@@ -545,7 +560,7 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
-- returns three pieces: header, body, footer so that header & footer can be
-- incorporated into the declaration
-ppShortConstrParts :: Bool -> ConDecl DocName -> Bool -> Qualification -> (Html, Html, Html)
+ppShortConstrParts :: Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html)
ppShortConstrParts summary con unicode qual = case con_res con of
ResTyH98 -> case con_details con of
PrefixCon args ->
@@ -591,7 +606,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool
+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode
-> Qualification -> Html
ppConstrHdr forall_ tvs ctxt unicode qual
= (if null tvs then noHtml else ppForall)
@@ -605,7 +620,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual
ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
- -> Bool -> Qualification -> LConDecl DocName -> SubDecl
+ -> Unicode -> Qualification -> LConDecl DocName -> SubDecl
ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart)
where
decl = case con_res con of
@@ -653,7 +668,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
mkFunTy a b = noLoc (HsFunTy a b)
-ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> Qualification
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
-> ConDeclField DocName -> SubDecl
ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
(ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype,
@@ -664,7 +679,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
mbDoc = lookup name subdocs >>= combineDocumentation . fst
-ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html
+ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
= ppBinder summary (nameOccName . getName $ name)
<+> dcolon unicode <+> ppLType unicode qual ltype
@@ -672,7 +687,7 @@ ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
-ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
ppDataHeader summary decl@(DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd
, dd_ctxt = ctxt } })
unicode qual
@@ -725,31 +740,31 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
| otherwise = p
-ppLType, ppLParendType, ppLFunLhType :: Bool -> Qualification
+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification
-> Located (HsType DocName) -> Html
ppLType unicode qual y = ppType unicode qual (unLoc y)
ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)
ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y)
-ppType, ppCtxType, ppParendType, ppFunLhType :: Bool -> Qualification
+ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification
-> HsType DocName -> Html
ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual
ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual
ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
-ppLKind :: Bool -> Qualification-> LHsKind DocName -> Html
+ppLKind :: Unicode -> Qualification-> LHsKind DocName -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)
-ppKind :: Bool -> Qualification-> HsKind DocName -> Html
+ppKind :: Unicode -> Qualification-> HsKind DocName -> Html
ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
- -> Located (HsContext DocName) -> Bool -> Qualification -> Html
+ -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
ppForAll expl tvs cxt unicode qual
| show_forall = forall_part <+> ppLContext cxt unicode qual
| otherwise = ppLContext cxt unicode qual
@@ -759,11 +774,11 @@ ppForAll expl tvs cxt unicode qual
forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
-ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Qualification -> Html
+ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html
ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
-ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html
+ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html
ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual
= maybeParen ctxt_prec pREC_FUN $
hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual]
@@ -814,7 +829,7 @@ ppr_tylit (HsNumTy n) = toHtml (show n)
ppr_tylit (HsStrTy s) = toHtml (show s)
-ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Qualification -> Html
+ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html
ppr_fun_ty ctxt_prec ty1 ty2 unicode qual
= let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual
p2 = ppr_mono_lty pREC_TOP ty2 unicode qual
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 9a0e461d..dfcda473 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -190,11 +190,15 @@ 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 -> [DocName] -> Html -> Html
-topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc names html =
+topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
+topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html =
declElem << (srcLink <+> wikiLink <+> html)
- where srcLink =
- case Map.lookup origPkg sourceMap of
+ where srcLink = let nameUrl = Map.lookup origPkg sourceMap
+ lineUrl = Map.lookup origPkg lineMap
+ mUrl | splice = lineUrl
+ -- Use the lineUrl as a backup
+ | otherwise = maybe lineUrl Just nameUrl in
+ case mUrl of
Nothing -> noHtml
Just url -> let url' = spliceURL (Just fname) (Just origMod)
(Just n) (Just loc) url
diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs
index 7bff0eb1..122861c3 100644
--- a/src/Haddock/Backends/Xhtml/Types.hs
+++ b/src/Haddock/Backends/Xhtml/Types.hs
@@ -12,7 +12,9 @@
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Types (
SourceURLs, WikiURLs,
- LinksInfo
+ LinksInfo,
+ Splice,
+ Unicode,
) where
@@ -21,9 +23,15 @@ import GHC
-- the base, module and entity URLs for the source code and wiki links.
-type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath)
+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath, Map PackageId FilePath)
type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
-- The URL for source and wiki links
type LinksInfo = (SourceURLs, WikiURLs)
+
+-- Whether something is a splice or not
+type Splice = Bool
+
+-- Whether unicode syntax is to be used
+type Unicode = Bool
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 37d0fe7d..e23e9922 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -55,6 +55,7 @@ createInterface tm flags modMap instIfaceMap = do
let ms = pm_mod_summary . tm_parsed_module $ tm
mi = moduleInfo tm
+ L _ hsm = parsedSource tm
!safety = modInfoSafe mi
mdl = ms_mod ms
dflags = ms_hspp_opts ms
@@ -85,6 +86,8 @@ createInterface tm flags modMap instIfaceMap = do
(decls, _) = unzip declsWithDocs
localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances
++ map getName fam_instances
+ -- Locations of all TH splices
+ splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
maps@(!docMap, !argMap, !subMap, !declMap, _) <-
liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
@@ -98,8 +101,8 @@ createInterface tm flags modMap instIfaceMap = do
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
- exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps fixMap exports
- instIfaceMap dflags
+ exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls
+ maps fixMap splices exports instIfaceMap dflags
let !visibleNames = mkVisibleNames maps exportItems opts
@@ -477,15 +480,16 @@ mkExportItems
-> [LHsDecl Name]
-> Maps
-> FixMap
+ -> [SrcSpan] -- splice locations
-> Maybe [IE Name]
-> InstIfaceMap
-> DynFlags
-> ErrMsgGhc [ExportItem Name]
mkExportItems
modMap thisMod warnings gre exportedNames decls
- maps@(docMap, argMap, subMap, declMap, instMap) fixMap optExports instIfaceMap dflags =
+ maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
case optExports of
- Nothing -> fullModuleContents dflags warnings gre maps fixMap decls
+ Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
Just exports -> liftM concat $ mapM lookupExport exports
where
lookupExport (IEVar x) = declWith x
@@ -493,7 +497,7 @@ mkExportItems
lookupExport (IEThingAll t) = declWith t
lookupExport (IEThingWith t _) = declWith t
lookupExport (IEModuleContents m) =
- moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap
+ moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
lookupExport (IEGroup lev docStr) = liftErrMsg $
ifDoc (processDocString dflags gre docStr)
(\doc -> return [ ExportGroup lev "" doc ])
@@ -516,9 +520,9 @@ mkExportItems
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
declWith t =
case findDecl t of
- ([L _ (ValD _)], (doc, _)) -> do
+ ([L l (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
- export <- hiValExportItem dflags t doc $ M.lookup t fixMap
+ export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
let declNames = getMainDeclBinder (unL decl)
@@ -577,7 +581,7 @@ mkExportItems
mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
mkExportDecl name decl (doc, subs) = decl'
where
- decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities
+ decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False
mdl = nameModule name
subs' = filter (isExported . fst) subs
sub_names = map fst subs'
@@ -608,12 +612,12 @@ hiDecl dflags t = do
Just x -> return (Just (tyThingToLHsDecl x))
-hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
-hiValExportItem dflags name doc fixity = do
+hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
+hiValExportItem dflags name doc splice fixity = do
mayDecl <- hiDecl dflags name
case mayDecl of
Nothing -> return (ExportNoDecl name [])
- Just decl -> return (ExportDecl decl doc [] [] fixities)
+ Just decl -> return (ExportDecl decl doc [] [] fixities splice)
where
fixities = case fixity of
Just f -> [(name, f)]
@@ -656,9 +660,10 @@ moduleExports :: Module -- ^ Module A
-> InstIfaceMap -- ^ Interfaces in other packages
-> Maps
-> FixMap
+ -> [SrcSpan] -- ^ Locations of all TH splices
-> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
-moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap
- | m == thisMod = fullModuleContents dflags warnings gre maps fixMap decls
+moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices
+ | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls
| otherwise =
case M.lookup m ifaceMap of
Just iface
@@ -696,9 +701,9 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
-- (For more information, see Trac #69)
-fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap
+fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]
-> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
-fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap decls =
+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
liftM catMaybes $ mapM mkExportItem (expandSig decls)
where
-- A type signature can have multiple names, like:
@@ -721,20 +726,20 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr
return $ fmap ExportDoc mbDoc
- mkExportItem (L _ (ValD d))
+ mkExportItem (L l (ValD d))
| name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
-- Top-level binding without type signature.
let (doc, _) = lookupDocs name warnings docMap argMap subMap in
- fmap Just (hiValExportItem dflags name doc $ M.lookup name fixMap)
+ fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap)
| otherwise = return Nothing
- mkExportItem decl@(L _ (InstD d))
+ mkExportItem decl@(L l (InstD d))
| Just name <- M.lookup (getInstLoc d) instMap =
let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
- return $ Just (ExportDecl decl doc subs [] (fixities name subs))
- mkExportItem decl
- | name:_ <- getMainDeclBinder (unLoc decl) =
+ return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ mkExportItem decl@(L l d)
+ | name:_ <- getMainDeclBinder d =
let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
- return $ Just (ExportDecl decl doc subs [] (fixities name subs))
+ return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
| otherwise = return Nothing
fixities name subs = [ (n,f) | n <- name : map fst subs
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 4bf39dfb..a5cde195 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -477,7 +477,7 @@ renameExportItem item = case item of
ExportGroup lev id_ doc -> do
doc' <- renameDoc doc
return (ExportGroup lev id_ doc')
- ExportDecl decl doc subs instances fixities -> do
+ ExportDecl decl doc subs instances fixities splice -> do
decl' <- renameLDecl decl
doc' <- renameDocForDecl doc
subs' <- mapM renameSub subs
@@ -488,7 +488,7 @@ renameExportItem item = case item of
fixities' <- forM fixities $ \(name, fixity) -> do
name' <- lookupRn name
return (name', fixity)
- return (ExportDecl decl' doc' subs' instances' fixities')
+ return (ExportDecl decl' doc' subs' instances' fixities' splice)
ExportNoDecl x subs -> do
x' <- lookupRn x
subs' <- mapM lookupRn subs
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 2e10827e..b166de46 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -51,9 +51,10 @@ data Flag
| Flag_Lib String
| Flag_OutputDir FilePath
| Flag_Prologue FilePath
- | Flag_SourceBaseURL String
- | Flag_SourceModuleURL String
- | Flag_SourceEntityURL String
+ | Flag_SourceBaseURL String
+ | Flag_SourceModuleURL String
+ | Flag_SourceEntityURL String
+ | Flag_SourceLEntityURL String
| Flag_WikiBaseURL String
| Flag_WikiModuleURL String
| Flag_WikiEntityURL String
@@ -114,6 +115,8 @@ options backwardsCompat =
"URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)",
Option [] ["source-entity"] (ReqArg Flag_SourceEntityURL "URL")
"URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",
+ Option [] ["source-entity-line"] (ReqArg Flag_SourceLEntityURL "URL")
+ "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.",
Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL")
"URL for a comments link on the contents\nand index pages",
Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL")
@@ -216,11 +219,12 @@ optCssFile :: [Flag] -> Maybe FilePath
optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
-sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
+sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)
sourceUrls flags =
- (optLast [str | Flag_SourceBaseURL str <- flags]
- ,optLast [str | Flag_SourceModuleURL str <- flags]
- ,optLast [str | Flag_SourceEntityURL str <- flags])
+ (optLast [str | Flag_SourceBaseURL str <- flags]
+ ,optLast [str | Flag_SourceModuleURL str <- flags]
+ ,optLast [str | Flag_SourceEntityURL str <- flags]
+ ,optLast [str | Flag_SourceLEntityURL str <- flags])
wikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 24f9e040..179413ea 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -201,6 +201,10 @@ data ExportItem name
-- | Fixity decls relevant to this declaration (including subordinates).
, expItemFixities :: ![(name, Fixity)]
+
+ -- | Whether the ExportItem is from a TH splice or not, for generating
+ -- the appropriate type of Source link.
+ , expItemSpliced :: !Bool
}
-- | An exported entity for which we have no documentation (perhaps because it
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 12:38:13 +0000