aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Backends')
-rw-r--r--src/Haddock/Backends/Hoogle.hs7
-rw-r--r--src/Haddock/Backends/LaTeX.hs65
-rw-r--r--src/Haddock/Backends/Xhtml.hs28
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs78
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs7
5 files changed, 103 insertions, 82 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index e4415db9..44e83d64 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -114,16 +114,17 @@ ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl)
f (TyClD d@TyData{}) = ppData d subdocs
f (TyClD d@ClassDecl{}) = ppClass d
f (TyClD d@TySynonym{}) = ppSynonym d
- f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig name typ
- f (ForD (ForeignExport name typ _)) = ppSig $ TypeSig name typ
+ f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig [name] typ
+ f (ForD (ForeignExport name typ _)) = ppSig $ TypeSig [name] typ
f (SigD sig) = ppSig sig
f _ = []
ppExport _ = []
ppSig :: Sig Name -> [String]
-ppSig (TypeSig name sig) = [operator (out name) ++ " :: " ++ outHsType typ]
+ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ]
where
+ prettyNames = concat . intersperse ", " $ map out names
typ = case unL sig of
HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c
x -> x
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 71773d0d..27f6bd5e 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)
- = ppDocBinder (declName decl) <>
+ = sep (punctuate comma . map ppDocBinder $ declNames decl) <>
case subdocs of
[] -> empty
_ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))
@@ -197,8 +197,8 @@ processExports :: [ExportItem DocName] -> LaTeX
processExports [] = empty
processExports (decl : es)
| Just sig <- isSimpleSig decl
- = multiDecl [ ppTypeSig (getName name) typ False
- | (name,typ) <- sig:sigs ] $$
+ = multiDecl [ ppTypeSig (map getName names) typ False
+ | (names,typ) <- sig:sigs ] $$
processExports es'
where (sigs, es') = spanWith isSimpleSig es
processExports (ExportModule mdl : es)
@@ -209,10 +209,10 @@ processExports (e : es) =
processExport e $$ processExports es
-isSimpleSig :: ExportItem DocName -> Maybe (DocName, HsType DocName)
-isSimpleSig (ExportDecl (L _ (SigD (TypeSig (L _ n) (L _ t))))
+isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
+isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t))))
(Nothing, argDocs) _ _)
- | Map.null argDocs = Just (n, t)
+ | Map.null argDocs = Just (map unLoc lnames, t)
isSimpleSig _ = Nothing
@@ -244,11 +244,11 @@ ppDocGroup lev doc = sec lev <> braces doc
sec _ = text "\\paragraph"
-declName :: LHsDecl DocName -> DocName
-declName (L _ decl) = case decl of
- TyClD d -> unLoc $ tcdLName d
- SigD (TypeSig (L _ n) _) -> n
- _ -> error "declaration not supported by declName"
+declNames :: LHsDecl DocName -> [DocName]
+declNames (L _ decl) = case decl of
+ TyClD d -> [unLoc $ tcdLName d]
+ SigD (TypeSig lnames _) -> map unLoc lnames
+ _ -> error "declaration not supported by declNames"
forSummary :: (ExportItem DocName) -> Bool
@@ -286,7 +286,7 @@ ppDecl (L loc decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of
| Nothing <- tcdTyPats d -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode
| Just _ <- tcdTyPats d -> ppTyInst False loc mbDoc d unicode
TyClD d@(ClassDecl {}) -> ppClassDecl instances loc mbDoc subdocs d unicode
- SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) n t unicode
+ SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode
ForD d -> ppFor loc (mbDoc, fnArgsDoc) d unicode
InstD _ -> empty
_ -> error "declaration not supported by ppDecl"
@@ -325,7 +325,7 @@ ppFor _ _ _ _ =
ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX
ppTySyn loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode
- = ppTypeOrFunSig loc name (unLoc ltype) doc (full, hdr, char '=') unicode
+ = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
where
hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
full = hdr <+> char '=' <+> ppLType unicode ltype
@@ -338,20 +338,22 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
-------------------------------------------------------------------------------
-ppFunSig :: SrcSpan -> DocForDecl DocName -> DocName -> HsType DocName
+ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName
-> Bool -> LaTeX
-ppFunSig loc doc docname typ unicode =
- ppTypeOrFunSig loc docname typ doc
- (ppTypeSig name typ False, ppSymName name, dcolon unicode)
+ppFunSig loc doc docnames typ unicode =
+ ppTypeOrFunSig loc docnames typ doc
+ ( ppTypeSig names typ False
+ , hsep . punctuate comma $ map ppSymName names
+ , dcolon unicode)
unicode
where
- name = getName docname
+ names = map getName docnames
-ppTypeOrFunSig :: SrcSpan -> DocName -> HsType DocName ->
- DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
+ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
+ -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
-> Bool -> LaTeX
-ppTypeOrFunSig _loc _docname typ (doc, argDocs) (pref1, pref2, sep0)
+ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
unicode
| Map.null argDocs =
declWithDoc pref1 (fmap docToLaTeX doc)
@@ -388,9 +390,11 @@ ppTypeOrFunSig _loc _docname typ (doc, argDocs) (pref1, pref2, sep0)
= decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl
-ppTypeSig :: Name -> HsType DocName -> Bool -> LaTeX
-ppTypeSig nm ty unicode =
- ppSymName nm <+> dcolon unicode <+> ppType unicode ty
+ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX
+ppTypeSig nms ty unicode =
+ hsep (punctuate comma $ map ppSymName nms)
+ <+> dcolon unicode
+ <+> ppType unicode ty
ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX]
@@ -489,12 +493,13 @@ ppClassDecl instances loc mbDoc subdocs
methodTable =
text "\\haddockpremethods{}\\textbf{Methods}" $$
- vcat [ ppFunSig loc doc n typ unicode
- | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
- , let doc = lookupAnySubdoc n subdocs ]
-
--- atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats
--- , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
+ vcat [ ppFunSig loc doc names typ unicode
+ | L _ (TypeSig lnames (L _ typ)) <- lsigs
+ , let doc = lookupAnySubdoc (head names) subdocs
+ names = map unLoc lnames ]
+ -- FIXME: is taking just the first name ok? Is it possible that
+ -- there are different subdocs for different names in a single
+ -- type signature?
instancesBit = ppDocInstances unicode instances
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 3bc2dd6f..d3d3c79c 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -547,31 +547,31 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html
miniSynopsis mdl iface unicode qual =
- divInterface << mapMaybe (processForMiniSynopsis mdl unicode qual) exports
+ divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports
where
exports = numberSectionHeadings (ifaceRnExportItems iface)
processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
- -> Maybe Html
+ -> [Html]
processForMiniSynopsis mdl unicode _ (ExportDecl (L _loc decl0) _doc _ _insts) =
((divTopDecl <<).(declElem <<)) `fmap` case decl0 of
TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
- (TyFamily{}) -> Just $ ppTyFamHeader True False d unicode
+ (TyFamily{}) -> [ppTyFamHeader True False d unicode]
(TyData{tcdTyPats = ps})
- | Nothing <- ps -> Just $ keyword "data" <+> b
- | Just _ <- ps -> Just $ keyword "data" <+> keyword "instance" <+> b
+ | Nothing <- ps -> [keyword "data" <+> b]
+ | Just _ <- ps -> [keyword "data" <+> keyword "instance" <+> b]
(TySynonym{tcdTyPats = ps})
- | Nothing <- ps -> Just $ keyword "type" <+> b
- | Just _ <- ps -> Just $ keyword "type" <+> keyword "instance" <+> b
- (ClassDecl {}) -> Just $ keyword "class" <+> b
- _ -> Nothing
- SigD (TypeSig (L _ n) (L _ _)) ->
- Just $ ppNameMini mdl (nameOccName . getName $ n)
- _ -> Nothing
+ | Nothing <- ps -> [keyword "type" <+> b]
+ | Just _ <- ps -> [keyword "type" <+> keyword "instance" <+> b]
+ (ClassDecl {}) -> [keyword "class" <+> b]
+ _ -> []
+ SigD (TypeSig lnames (L _ _)) ->
+ map (ppNameMini mdl . nameOccName . getName . unLoc) lnames
+ _ -> []
processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
- Just $ groupTag lvl << docToHtml qual txt
-processForMiniSynopsis _ _ _ _ = Nothing
+ [groupTag lvl << docToHtml qual txt]
+processForMiniSynopsis _ _ _ = []
ppNameMini :: Module -> OccName -> Html
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 381802b4..bd93ac25 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -27,6 +27,7 @@ import Haddock.GhcUtils
import Haddock.Types
import Control.Monad ( join )
+import Data.List ( intersperse )
import qualified Data.Map as Map
import Data.Maybe
import Text.XHtml hiding ( name, title, p, quote )
@@ -50,28 +51,31 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual
| Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
| Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
- SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode qual
+ SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual
ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual
InstD _ -> noHtml
_ -> error "declaration not supported by ppDecl"
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- DocName -> HsType DocName -> Bool -> Qualification -> Html
-ppFunSig summary links loc doc docname typ unicode qual =
- ppTypeOrFunSig summary links loc docname typ doc
- (ppTypeSig summary occname typ unicode qual, ppBinder False occname, dcolon unicode)
+ [DocName] -> HsType DocName -> Bool Qualification -> Html
+ppFunSig summary links loc doc docnames typ unicode qual =
+ ppTypeOrFunSig summary links loc docnames typ doc
+ ( ppTypeSig summary occnames typ unicode qual
+ , concatHtml . punctuate comma $ map (ppBinder False) occnames
+ , dcolon unicode
+ )
unicode qual
where
- occname = nameOccName . getName $ docname
+ occnames = map (nameOccName . getName) docnames
-ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName ->
- DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification-> Html
-ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode qual
+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
| summary = pref1
- | Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection qual doc
- | otherwise = topDeclElem links loc docname pref2 +++
+ | Map.null argDocs = topDeclElem links loc docnames pref1 +++ maybeDocSection qual doc
+ | otherwise = topDeclElem links loc docnames pref2 +++
subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc
where
argDoc n = Map.lookup n argDocs
@@ -108,10 +112,10 @@ tyvarNames :: [LHsTyVarBndr DocName] -> [Name]
tyvarNames = map (getName . hsTyVarName . unLoc)
-ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool
- -> Qualification -> Html
+ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
+ -> ForeignDecl DocName -> Bool -> Qualification -> Html
ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode qual
- = ppFunSig summary links loc doc name typ unicode qual
+ = ppFunSig summary links loc doc [name] typ unicode qual
ppFor _ _ _ _ _ _ _ = error "ppFor"
@@ -119,7 +123,7 @@ ppFor _ _ _ _ _ _ _ = error "ppFor"
ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool
-> Qualification -> Html
ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode qual
- = ppTypeOrFunSig summary links loc name (unLoc ltype) doc
+ = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
(full, hdr, spaceHtml +++ equals) unicode qual
where
hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
@@ -128,9 +132,11 @@ ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode qua
ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
-ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Qualification -> Html
-ppTypeSig summary nm ty unicode qual =
- ppBinder summary nm <+> dcolon unicode <+> ppType unicode qual ty
+ppTypeSig :: Bool -> [OccName] -> HsType DocName -> Bool -> Qualification -> Html
+ppTypeSig summary nms ty unicode qual =
+ concatHtml htmlNames <+> dcolon unicode <+> ppType unicode qual ty
+ where
+ htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms
ppTyName :: Name -> Html
@@ -173,7 +179,7 @@ ppTyFam summary associated links loc mbDoc decl unicode qual
where
docname = tcdName decl
- header_ = topDeclElem links loc docname (ppTyFamHeader summary associated decl unicode)
+ header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode)
instancesBit = ppInstances instances docname unicode qual
@@ -213,8 +219,8 @@ ppTyInst summary associated links loc mbDoc decl unicode qual
where
docname = tcdName decl
- header_ = topDeclElem links loc docname
- (ppTyInstHeader summary associated decl unicode qual)
+ header_ = topDeclElem links loc [docname]
+ (ppTyInstHeader summary associated decl unicode qual)
ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
@@ -349,16 +355,20 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
subdocs 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 [nm]) hdr
+ else (if summary then id else topDeclElem links loc [nm]) (hdr <+> keyword "where")
+++ shortSubDecls
(
[ ppAssocType summary links doc at unicode qual | at <- ats
, let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++
- [ ppFunSig summary links loc doc n typ unicode qual
- | L _ (TypeSig (L _ n) (L _ typ)) <- sigs
- , let doc = lookupAnySubdoc n subdocs ]
+ [ ppFunSig summary links loc doc names typ unicode qual
+ | L _ (TypeSig lnames (L _ typ)) <- sigs
+ , let doc = lookupAnySubdoc (head names) subdocs
+ names = map unLoc lnames ]
+ -- FIXME: is taking just the first name ok? Is it possible that
+ -- there are different subdocs for different names in a single
+ -- type signature?
)
where
hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual
@@ -377,8 +387,8 @@ ppClassDecl summary links instances loc mbDoc subdocs
+++ atBit +++ methodBit +++ instancesBit
where
classheader
- | null lsigs = topDeclElem links loc nm (hdr unicode qual)
- | otherwise = topDeclElem links loc nm (hdr unicode qual <+> keyword "where")
+ | null lsigs = topDeclElem links loc [nm] (hdr unicode qual)
+ | otherwise = topDeclElem links loc [nm] (hdr unicode qual <+> keyword "where")
nm = unLoc $ tcdLName decl
@@ -388,9 +398,13 @@ ppClassDecl summary links instances loc mbDoc subdocs
| at <- ats
, let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
- methodBit = subMethods [ ppFunSig summary links loc doc n typ unicode qual
- | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
- , let doc = lookupAnySubdoc n subdocs ]
+ methodBit = subMethods [ ppFunSig summary links loc doc names typ unicode qual
+ | L _ (TypeSig lnames (L _ typ)) <- lsigs
+ , let doc = lookupAnySubdoc (head names) subdocs
+ names = map unLoc lnames ]
+ -- FIXME: is taking just the first name ok? Is it possible that
+ -- there are different subdocs for different names in a single
+ -- type signature?
instancesBit = ppInstances instances nm unicode qual
@@ -461,7 +475,7 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual
cons = tcdCons dataDecl
resTy = (con_res . unLoc . head) cons
- header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode qual
+ header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual
<+> whereBit)
whereBit
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index e5d8c24e..91eac9c6 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -176,8 +176,8 @@ 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 name html =
+topDeclElem :: LinksInfo -> SrcSpan -> [DocName] -> Html -> Html
+topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc names html =
declElem << (html +++ srcLink +++ wikiLink)
where srcLink =
case Map.lookup origPkg sourceMap of
@@ -201,7 +201,8 @@ topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc name html =
origPkg = modulePackageId origMod
-- Name must be documented, otherwise we wouldn't get here
- Documented n mdl = name
+ Documented n mdl = head names
+ -- FIXME: is it ok to simply take the first name?
fname = unpackFS (srcSpanFile loc)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 09:27:38 +0000