From ab24835eadb99059934d7a14f86564eea6449257 Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Sat, 11 Jun 2011 00:33:33 +0000
Subject: * Merge in git patch from Michal Terepeta
From 6fc71d067738ef4b7de159327bb6dc3d0596be29 Mon Sep 17 00:00:00 2001
From: Michal Terepeta <michal.terepeta@gmail.com>
Date: Sat, 14 May 2011 19:18:22 +0200
Subject: [PATCH] Follow the change of TypeSig in GHC.
This follows the change in GHC to make TypeSig take a list
of names (instead of just one); GHC ticket #1595. This
should also improve the Haddock output in case the user
writes a type signature that refers to many names:
-- | Some comment..
foo, bar :: ...
will now generate the expected output with one signature for
both names.
---
src/Haddock/Backends/Hoogle.hs | 7 ++--
src/Haddock/Backends/LaTeX.hs | 65 ++++++++++++++++--------------
src/Haddock/Backends/Xhtml.hs | 28 ++++++-------
src/Haddock/Backends/Xhtml/Decl.hs | 78 +++++++++++++++++++++---------------
src/Haddock/Backends/Xhtml/Layout.hs | 7 ++--
src/Haddock/Convert.hs | 4 +-
src/Haddock/GhcUtils.hs | 53 ++++++++++++++++++++----
src/Haddock/Interface/Create.hs | 62 +++++++++++++++++-----------
src/Haddock/Interface/Rename.hs | 6 +--
src/Haddock/Utils.hs | 6 +--
10 files changed, 194 insertions(+), 122 deletions(-)
(limited to 'src/Haddock')
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)
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 9892ff47..34de6775 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -54,7 +54,7 @@ tyThingToLHsDecl t = noLoc $ case t of
ACoAxiom ax -> TyClD (synifyAxiom ax)
-- a data-constructor alone just gets rendered as a function:
- ADataCon dc -> SigD (TypeSig (synifyName dc)
+ ADataCon dc -> SigD (TypeSig [synifyName dc]
(synifyType ImplicitizeForAll (dataConUserType dc)))
-- classes are just a little tedious
AClass cl ->
@@ -220,7 +220,7 @@ synifyName = noLoc . getName
synifyIdSig :: SynifyTypeState -> Id -> Sig Name
-synifyIdSig s i = TypeSig (synifyName i) (synifyType s (varType i))
+synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i))
synifyCtx :: [PredType] -> LHsContext Name
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index a668d205..597ed123 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -17,6 +17,7 @@ module Haddock.GhcUtils where
import Data.Version
+import Control.Applicative ( (<$>) )
import Control.Arrow
import Data.Foldable hiding (concatMap)
import Data.Traversable
@@ -81,18 +82,54 @@ isVarSym :: OccName -> Bool
isVarSym = isLexVarSym . occNameFS
-getMainDeclBinder :: HsDecl name -> Maybe name
-getMainDeclBinder (TyClD d) = Just (tcdName d)
+getMainDeclBinder :: HsDecl name -> [name]
+getMainDeclBinder (TyClD d) = [tcdName d]
getMainDeclBinder (ValD d) =
+#if __GLASGOW_HASKELL__ == 612
+ case collectAcc d [] of
+ [] -> []
+ (name:_) -> [unLoc name]
+#else
case collectHsBindBinders d of
+ [] -> []
+ (name:_) -> [name]
+#endif
+
+getMainDeclBinder (SigD d) = sigNameNoLoc d
+getMainDeclBinder (ForD (ForeignImport name _ _)) = [unLoc name]
+getMainDeclBinder (ForD (ForeignExport _ _ _)) = []
+getMainDeclBinder _ = []
+
+-- Useful when there is a signature with multiple names, e.g.
+-- foo, bar :: Types..
+-- but only one of the names is exported and we have to change the
+-- type signature to only include the exported names.
+filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name)
+filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig)
+
+filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name)
+filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig
+filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig
+filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig
+filterSigNames p (TypeSig ns ty) =
+ case filter (p . unLoc) ns of
[] -> Nothing
- (name:_) -> Just name
+ filtered -> Just (TypeSig filtered ty)
+filterSigNames _ _ = Nothing
+ifTrueJust :: Bool -> name -> Maybe name
+ifTrueJust True = Just
+ifTrueJust False = const Nothing
-getMainDeclBinder (SigD d) = sigNameNoLoc d
-getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
-getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing
-getMainDeclBinder _ = Nothing
+sigName :: LSig name -> [name]
+sigName (L _ sig) = sigNameNoLoc sig
+
+sigNameNoLoc :: Sig name -> [name]
+sigNameNoLoc (TypeSig ns _) = map unLoc ns
+sigNameNoLoc (SpecSig n _ _) = [unLoc n]
+sigNameNoLoc (InlineSig n _) = [unLoc n]
+sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n]
+sigNameNoLoc _ = []
isTyClD :: HsDecl a -> Bool
@@ -184,7 +221,7 @@ instance Parent (TyClDecl Name) where
| isDataDecl d = map (unL . con_name . unL) . tcdCons $ d
| isClassDecl d =
map (tcdName . unL) (tcdATs d) ++
- [ unL n | L _ (TypeSig n _) <- tcdSigs d ]
+ [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
| otherwise = []
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 0123d22a..78c73c09 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -176,9 +176,10 @@ mkSubMap declMap exports =
-- subordinate names, but map them to their parent declarations.
mkDeclMap :: [DeclInfo] -> Map Name DeclInfo
mkDeclMap decls = Map.fromList . concat $
- [ (declName d, (parent, doc, subs)) : subDecls
+ [ decls_ ++ subDecls
| (parent@(L _ d), doc, subs) <- decls
- , let subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ]
+ , let decls_ = [ (name, (parent, doc, subs)) | name <- declNames d ]
+ subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ]
, not (isDocD d), not (isInstD d) ]
@@ -227,8 +228,9 @@ classDataSubs decl
| isDataDecl decl = dataSubs
| otherwise = []
where
- classSubs = [ (declName d, doc, fnArgsDoc)
+ classSubs = [ (name, doc, fnArgsDoc)
| (L _ d, doc) <- classDecls decl
+ , name <- declNames d
, let fnArgsDoc = getDeclFnArgDocs d ]
dataSubs = constrs ++ fields
where
@@ -259,12 +261,12 @@ declsFromClass class_ = docs ++ defs ++ sigs ++ ats
ats = mkDecls tcdATs TyClD class_
-declName :: HsDecl a -> a
-declName (TyClD d) = tcdName d
-declName (ForD (ForeignImport n _ _)) = unLoc n
+declNames :: HsDecl a -> [a]
+declNames (TyClD d) = [tcdName d]
+declNames (ForD (ForeignImport n _ _)) = [unLoc n]
-- we have normal sigs only (since they are taken from ValBindsOut)
-declName (SigD sig) = fromJust $ sigNameNoLoc sig
-declName _ = error "unexpected argument to declName"
+declNames (SigD sig) = sigNameNoLoc sig
+declNames _ = error "unexpected argument to declNames"
-- | The top-level declarations of a module that we care about,
@@ -453,8 +455,17 @@ mkExportItems modMap thisMod gre exportedNames decls declMap
optExports _ instIfaceMap dflags =
case optExports of
Nothing -> liftErrMsg $ fullContentsOfThisModule dflags gre decls
- Just exports -> liftM concat $ mapM lookupExport exports
+ Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports
where
+ -- A type signature can have multiple names, like:
+ -- foo, bar :: Types..
+ -- When going throug the exported names we have to take care to detect such
+ -- situations and remove the duplicates.
+ commaDeclared (ExportDecl (L _ sig1) _ _ _) (ExportDecl (L _ sig2) _ _ _) =
+ getMainDeclBinder sig1 == getMainDeclBinder sig2
+ commaDeclared _ _ = False
+
+
lookupExport (IEVar x) = declWith x
lookupExport (IEThingAbs t) = declWith t
lookupExport (IEThingAll t) = declWith t
@@ -483,11 +494,8 @@ mkExportItems modMap thisMod gre exportedNames decls declMap
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
declWith t =
case findDecl t of
- Just x@(decl,_,_) ->
- let declName_ =
- case getMainDeclBinder (unL decl) of
- Just n -> n
- Nothing -> error "declWith: should not happen"
+ Just (decl, doc, subs) ->
+ let declNames_ = getMainDeclBinder (unL decl)
in case () of
_
-- temp hack: we filter out separately exported ATs, since we haven't decided how
@@ -497,7 +505,7 @@ mkExportItems modMap thisMod gre exportedNames decls declMap
-- We should not show a subordinate by itself if any of its
-- parents is also exported. See note [1].
- | t /= declName_,
+ | not $ t `elem` declNames_,
Just p <- find isExported (parents t $ unL decl) ->
do liftErrMsg $ tell [
"Warning: " ++ moduleString thisMod ++ ": " ++
@@ -508,7 +516,18 @@ mkExportItems modMap thisMod gre exportedNames decls declMap
return []
-- normal case
- | otherwise -> return [ mkExportDecl t x ]
+ | otherwise -> return [ mkExportDecl t (newDecl, doc, subs) ]
+ where
+ -- Since a single signature might refer to many names, we
+ -- need to filter the ones that are actually exported. This
+ -- requires modifying the type signatures to "hide" the
+ -- names that are not exported.
+ newDecl = case decl of
+ (L loc (SigD sig)) ->
+ L loc . SigD . fromJust $ filterSigNames isExported sig
+ -- fromJust is safe since we already checked in guards
+ -- that 't' is a name declared in this declaration.
+ _ -> decl
Nothing -> do
-- If we can't find the declaration, it must belong to
-- another package
@@ -720,11 +739,11 @@ fullContentsOfThisModule dflags gre decls = liftM catMaybes $ mapM mkExportItem
-- together a type signature for it...)
extractDecl :: Name -> Module -> Decl -> Decl
extractDecl name mdl decl
- | Just n <- getMainDeclBinder (unLoc decl), n == name = decl
+ | name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
case unLoc decl of
TyClD d | isClassDecl d ->
- let matches = [ sig | sig <- tcdSigs d, sigName sig == Just name,
+ let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
isVanillaLSig sig ] -- TODO: document fixity
in case matches of
[s0] -> let (n, tyvar_names) = name_and_tyvars d
@@ -762,7 +781,7 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (L _ con : rest) =
case con_details con of
RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
- L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty))))
+ L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))))
_ -> extractRecSel nm mdl t tvs rest
where
matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]
@@ -782,10 +801,7 @@ mkVisibleNames exports opts
| OptHide `elem` opts = []
| otherwise = concatMap exportName exports
where
- exportName e@ExportDecl {} =
- case getMainDeclBinder $ unL $ expItemDecl e of
- Just n -> n : subs
- Nothing -> subs
+ exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs
where subs = map fst (expItemSubDocs e)
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
-- we don't want links to go to them.
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index b53f579c..2d5c899a 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -401,10 +401,10 @@ renameTyClD d = case d of
renameSig :: Sig Name -> RnM (Sig DocName)
renameSig sig = case sig of
- TypeSig lname ltype -> do
- lname' <- renameL lname
+ TypeSig lnames ltype -> do
+ lnames' <- mapM renameL lnames
ltype' <- renameLType ltype
- return (TypeSig lname' ltype')
+ return (TypeSig lnames' ltype')
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index be75e3e4..20598263 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -68,7 +68,7 @@ import Data.Map ( Map )
import qualified Data.Map as Map hiding ( Map )
import Data.IORef ( IORef, newIORef, readIORef )
import Data.List ( isSuffixOf )
-import Data.Maybe ( fromJust )
+import Data.Maybe ( mapMaybe )
import System.Environment ( getProgName )
import System.Exit ( exitWith, ExitCode(..) )
import System.IO ( hPutStr, stderr )
@@ -160,9 +160,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
-restrictDecls names decls = filter keep decls
- where keep d = fromJust (sigName d) `elem` names
- -- has to have a name, since it's a class method type signature
+restrictDecls names decls = mapMaybe (filterLSigNames (`elem` names)) decls
restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name]
--
cgit v1.2.3