diff options
author | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-01-09 01:42:55 -0600 |
---|---|---|
committer | Austin Seipp <austin@well-typed.com> | 2014-01-19 15:35:16 -0600 |
commit | 7c905816eb12981840efe4136989799db437f357 (patch) | |
tree | 254618be017084ab4a1a61e499aae85ff4479b11 /src/Haddock/Backends/Xhtml | |
parent | 764a6b85b686dee3d93e130bd650ee33a985aca2 (diff) |
Support for -XPatternSynonyms
Signed-off-by: Austin Seipp <austin@well-typed.com>
Diffstat (limited to 'src/Haddock/Backends/Xhtml')
-rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 71 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/Names.hs | 23 |
2 files changed, 75 insertions, 19 deletions
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 91e6871d..04f94c49 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -30,6 +30,7 @@ import Haddock.Doc (combineDocumentation) import Data.List ( intersperse ) import qualified Data.Map as Map import Data.Maybe +import Data.Monoid ( mempty ) import Text.XHtml hiding ( name, title, p, quote ) import GHC @@ -40,21 +41,69 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual - TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual - SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual + TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual + TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual + TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual + SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty unicode qual + SigD (PatSynSig lname args ty prov req) -> + ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" +ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + [Located DocName] -> LHsType DocName -> Bool -> Qualification -> Html +ppLFunSig summary links loc doc lnames lty unicode qual = + ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) unicode qual + ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName -> Bool -> Qualification -> Html ppFunSig summary links loc doc docnames typ unicode qual = + ppSigLike summary links loc mempty doc docnames (typ, pp_typ) unicode qual + where + pp_typ = ppType unicode qual typ + +ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + Located DocName -> + HsPatSynDetails (LHsType DocName) -> LHsType DocName -> + LHsContext DocName -> LHsContext DocName -> + Bool -> Qualification -> Html +ppLPatSig summary links loc doc lname args typ prov req unicode qual = + ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode qual + +ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + DocName -> + HsPatSynDetails (HsType DocName) -> HsType DocName -> + HsContext DocName -> HsContext DocName -> + Bool -> Qualification -> Html +ppPatSig summary links loc (doc, _argDocs) docname args typ prov req unicode qual + | summary = pref1 + | otherwise = topDeclElem links loc [docname] pref1 +++ docSection qual doc + where + -- pref1 = leader <+> ppTypeSig summary occnames pp_typ unicode + pref1 = hsep [ toHtml "pattern" + , pp_cxt prov + , pp_head + , dcolon unicode + , pp_cxt req + , ppType unicode qual typ + ] + pp_head = case args of + PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs + InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right] + + pp_cxt cxt = ppContext cxt unicode qual + pp_type = ppParendType unicode qual + + occname = nameOccName . getName $ docname + +ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> + [DocName] -> (HsType DocName, Html) -> Bool -> Qualification -> Html +ppSigLike summary links loc leader doc docnames (typ, pp_typ) unicode qual = ppTypeOrFunSig summary links loc docnames typ doc - ( ppTypeSig summary occnames typ unicode qual + ( leader <+> ppTypeSig summary occnames pp_typ unicode , concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode ) @@ -127,9 +176,9 @@ ppTySyn summary links loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvar ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" -ppTypeSig :: Bool -> [OccName] -> HsType DocName -> Bool -> Qualification -> Html -ppTypeSig summary nms ty unicode qual = - concatHtml htmlNames <+> dcolon unicode <+> ppType unicode qual ty +ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html +ppTypeSig summary nms pp_ty unicode = + concatHtml htmlNames <+> dcolon unicode <+> pp_ty where htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms @@ -465,7 +514,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of char '}') InfixCon arg1 arg2 -> (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, - ppBinder summary occ, ppLParendType unicode qual arg2], + ppBinderInfix summary occ, ppLParendType unicode qual arg2], noHtml, noHtml) ResTyGADT resTy -> case con_details con of @@ -526,7 +575,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) InfixCon arg1 arg2 -> hsep [header_ unicode qual +++ ppLParendType unicode qual arg1, - ppBinder False occ, + ppBinderInfix False occ, ppLParendType unicode qual arg2] ResTyGADT resTy -> case con_details con of diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 2f2b82ed..280a888c 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -12,7 +12,7 @@ ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Names ( ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, - ppBinder, ppBinder', + ppBinder, ppBinderInfix, ppBinder', ppModule, ppModuleRef, ppIPName, linkId @@ -105,16 +105,23 @@ ppName name = toHtml (getOccString name) ppBinder :: Bool -> OccName -> Html -- The Bool indicates whether we are generating the summary, in which case -- the binder will be a link to the full definition. -ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' n +ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' False n ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' n + << ppBinder' False n +ppBinderInfix :: Bool -> OccName -> Html +ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' True n +ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"] + << ppBinder' True n -ppBinder' :: OccName -> Html -ppBinder' n - | isVarSym n = parens $ ppOccName n - | otherwise = ppOccName n - +ppBinder' :: Bool -> OccName -> Html +-- The Bool indicates if it is to be rendered in infix notation +ppBinder' is_infix n = wrap $ ppOccName n + where + wrap | is_infix && not is_sym = quote + | not is_infix && is_sym = parens + | otherwise = id + is_sym = isVarSym n || isConSym n linkId :: Module -> Maybe Name -> Html -> Html linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) |