From ab24835eadb99059934d7a14f86564eea6449257 Mon Sep 17 00:00:00 2001 From: David Waern 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 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