From 5f475ed8d2457925231389048d843ee1261802ac Mon Sep 17 00:00:00 2001 From: David Waern Date: Sun, 11 Nov 2007 00:50:57 +0000 Subject: Do some refactoring in the html backend This also merges an old patch by Augustsson: Wed Jul 12 19:54:36 CEST 2006 lennart.augustsson@credit-suisse.com * Print type definitions like signatures if given arrows. --- src/Haddock/Backends/Html.hs | 113 +++++++++++++++++++++++-------------------- src/Haddock/Types.hs | 5 ++ 2 files changed, 66 insertions(+), 52 deletions(-) (limited to 'src/Haddock') diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs index ab8fdce0..ae78f9fc 100644 --- a/src/Haddock/Backends/Html.hs +++ b/src/Haddock/Backends/Html.hs @@ -664,78 +664,86 @@ doDecl :: Bool -> LinksInfo -> Name -> LHsDecl DocName -> doDecl summary links x (L loc d) mbDoc instances docMap = doDecl d where doDecl (TyClD d) = doTyClD d - doDecl (SigD s) = ppSig summary links loc mbDoc s + doDecl (SigD (TypeSig (L _ n) (L _ t))) = + ppFunSig summary links loc mbDoc (getName n) t doDecl (ForD d) = ppFor summary links loc mbDoc d doTyClD d0@(TyData {}) = ppDataDecl summary links instances x loc mbDoc d0 doTyClD d0@(TySynonym {}) = ppTySyn summary links loc mbDoc d0 doTyClD d0@(ClassDecl {}) = ppClassDecl summary links instances x loc mbDoc docMap d0 -ppSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> Sig DocName -> HtmlTable -ppSig summary links loc mbDoc (TypeSig lname ltype) - | summary || noArgDocs t = - declWithDoc summary links loc n mbDoc (ppTypeSig summary n t) - | otherwise = topDeclBox links loc n (ppBinder False n) + +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> + Name -> HsType DocName -> HtmlTable +ppFunSig summary links loc mbDoc name typ = + ppTypeOrFunSig summary links loc name typ mbDoc + (ppTypeSig summary name typ, ppBinder False name, dcolon) + + +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> Name -> HsType DocName -> + Maybe (HsDoc DocName) -> (Html, Html, Html) -> HtmlTable +ppTypeOrFunSig summary links loc name typ doc (pref1, pref2, sep) + | summary || noArgDocs typ = declWithDoc summary links loc name doc pref1 + | otherwise = topDeclBox links loc name pref2 (tda [theclass "body"] << vanillaTable << ( - do_args dcolon t - (case mbDoc of + do_args sep typ + (case doc of Just doc -> ndocBox (docToHtml doc) Nothing -> Html.emptyTable) )) - where - t = unLoc ltype - NoLink n = unLoc lname - - noLArgDocs (L _ t) = noArgDocs t - noArgDocs (HsForAllTy _ _ _ t) = noLArgDocs t - noArgDocs (HsFunTy (L _ (HsDocTy _ _)) _) = False - noArgDocs (HsFunTy _ r) = noLArgDocs r - noArgDocs (HsDocTy _ _) = False - noArgDocs _ = True - - do_largs leader (L _ t) = do_args leader t - do_args :: Html -> (HsType DocName) -> HtmlTable - do_args leader (HsForAllTy Explicit tvs lctxt ltype) - = (argBox ( - leader <+> - hsep (keyword "forall" : ppTyVars tvs ++ [dot]) <+> - ppLContextNoArrow lctxt) + noLArgDocs (L _ t) = noArgDocs t + noArgDocs (HsForAllTy _ _ _ t) = noLArgDocs t + noArgDocs (HsFunTy (L _ (HsDocTy _ _)) _) = False + noArgDocs (HsFunTy _ r) = noLArgDocs r + noArgDocs (HsDocTy _ _) = False + noArgDocs _ = True + + do_largs leader (L _ t) = do_args leader t + do_args :: Html -> (HsType DocName) -> HtmlTable + do_args leader (HsForAllTy Explicit tvs lctxt ltype) + = (argBox ( + leader <+> + hsep (keyword "forall" : ppTyVars tvs ++ [dot]) <+> + ppLContextNoArrow lctxt) + <-> rdocBox noHtml) + do_largs darrow ltype + do_args leader (HsForAllTy Implicit _ lctxt ltype) + = (argBox (leader <+> ppLContextNoArrow lctxt) <-> rdocBox noHtml) do_largs darrow ltype - do_args leader (HsForAllTy Implicit _ lctxt ltype) - = (argBox (leader <+> ppLContextNoArrow lctxt) - <-> rdocBox noHtml) - do_largs darrow ltype - do_args leader (HsFunTy (L _ (HsDocTy lt ldoc)) r) - = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc))) - do_largs arrow r - do_args leader (HsFunTy lt r) - = (argBox (leader <+> ppLType lt) <-> rdocBox noHtml) do_largs arrow r - do_args leader (HsDocTy lt ldoc) - = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc))) - do_args leader t - = argBox (leader <+> ppType t) <-> rdocBox (noHtml) + do_args leader (HsFunTy (L _ (HsDocTy lt ldoc)) r) + = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc))) + do_largs arrow r + do_args leader (HsFunTy lt r) + = (argBox (leader <+> ppLType lt) <-> rdocBox noHtml) do_largs arrow r + do_args leader (HsDocTy lt ldoc) + = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc))) + do_args leader t + = argBox (leader <+> ppType t) <-> rdocBox (noHtml) + ppTyVars tvs = ppTyNames (tyvarNames tvs) tyvarNames = map f where f x = let NoLink n = hsTyVarName (unLoc x) in n -ppFor summary links loc mbDoc (ForeignImport lname ltype _) - = ppSig summary links loc mbDoc (TypeSig lname ltype) +ppFor summary links loc mbDoc (ForeignImport (L _ name) (L _ typ) _) + = ppFunSig summary links loc mbDoc (getName name) typ ppFor _ _ _ _ _ = error "ppFor" -- we skip type patterns for now -ppTySyn summary links loc mbDoc (TySynonym lname ltyvars _ ltype) - = declWithDoc summary links loc n mbDoc ( - hsep ([keyword "type", ppBinder summary n] - ++ ppTyVars ltyvars) <+> equals <+> ppLType ltype) - where NoLink n = unLoc lname +ppTySyn summary links loc mbDoc (TySynonym (L _ name) ltyvars _ ltype) + = ppTypeOrFunSig summary links loc n (unLoc ltype) mbDoc + (full, hdr, spaceHtml +++ equals) + where + hdr = hsep ([keyword "type", ppBinder summary n] ++ ppTyVars ltyvars) + full = hdr <+> equals <+> ppLType ltype + NoLink n = name ppLType (L _ t) = ppType t -ppTypeSig :: Bool -> Name -> (HsType DocName) -> Html +ppTypeSig :: Bool -> Name -> HsType DocName -> Html ppTypeSig summary nm ty = ppBinder summary nm <+> dcolon <+> ppType ty @@ -804,8 +812,9 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc (tda [theclass "body"] << vanillaTable << aboves ([ ppAT summary at | L _ at <- ats ] ++ - [ ppSig summary links loc mbDoc sig - | L _ sig@(TypeSig (L _ (NoLink n)) ty) <- sigs, let mbDoc = Map.lookup n docMap ]) + [ ppFunSig summary links loc mbDoc n typ + | L _ (TypeSig (L _ (NoLink n)) (L _ typ)) <- sigs + , let mbDoc = Map.lookup n docMap ]) ) where hdr = ppClassHdr summary lctxt nm tvs fds @@ -846,9 +855,9 @@ ppClassDecl summary links instances orig_c loc mbDoc docMap | otherwise = s8 methHdr tda [theclass "body"] << vanillaTable << ( - abovesSep s8 [ ppSig summary links loc mbDoc sig - | L _ sig@(TypeSig n _) <- lsigs, - let mbDoc = Map.lookup (orig n) docMap ] + abovesSep s8 [ ppFunSig summary links loc mbDoc (orig n) typ + | L _ (TypeSig n (L _ typ)) <- lsigs + , let mbDoc = Map.lookup (orig n) docMap ] ) instId = collapseId nm diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index e46ddf9e..6143ae02 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -89,6 +89,11 @@ instance Outputable DocName where ppr (NoLink n) = ppr n +instance NamedThing DocName where + getName (Link n) = n + getName (NoLink n) = n + + -- | This structure holds the module information we get from GHC's -- type checking phase data GhcModule = GhcModule { -- cgit v1.2.3