* 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.

10 files changed, 194 insertions, 122 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)
 
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]