From a197615a032f14f20761a7dec21ea098297eda31 Mon Sep 17 00:00:00 2001 From: "Dr. ERDI Gergo" Date: Thu, 20 Nov 2014 22:35:38 +0800 Subject: Update Haddock to new pattern synonym type signature syntax Conflicts: haddock-api/src/Haddock/Backends/Xhtml/Decl.hs haddock-api/src/Haddock/Convert.hs --- haddock-api/src/Haddock/Backends/LaTeX.hs | 70 ++++++++++++------------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 72 ++++++++++++++------------ 2 files changed, 72 insertions(+), 70 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index e9cc48c2..309e0f76 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -293,8 +293,8 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of -- Family instances happen via FamInst now TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode - SigD (PatSynSig lname args ty prov req) -> - ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode + SigD (PatSynSig lname qtvs prov req ty) -> + ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" @@ -350,32 +350,28 @@ ppFunSig loc doc docnames typ unicode = names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName - -> HsPatSynDetails (LHsType DocName) -> LHsType DocName + -> (HsExplicitFlag, LHsTyVarBndrs DocName) -> LHsContext DocName -> LHsContext DocName + -> LHsType DocName -> Bool -> LaTeX -ppLPatSig loc doc docname args typ prov req unicode = - ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode - -ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName - -> HsPatSynDetails (HsType DocName) -> HsType DocName - -> HsContext DocName -> HsContext DocName - -> Bool -> LaTeX -ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc) +ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode + = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern" - , pp_ctx prov - , pp_head + , ppDocBinder name , dcolon unicode - , pp_ctx req - , ppType unicode typ + , ppLTyVarBndrs expl qtvs unicode + , ctx + , ppType unicode ty ] - pp_head = case args of - PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs - InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right] + ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of + (Nothing, Nothing) -> empty + (Nothing, Just req) -> parens empty <+> darr <+> req <+> darr + (Just prov, Nothing) -> prov <+> darr + (Just prov, Just req) -> prov <+> darr <+> req <+> darr - pp_type = ppParendType unicode - pp_ctx ctx = ppContext ctx unicode + darr = darrow unicode ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) @@ -787,15 +783,21 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc +ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX +ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc + +ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX +ppContextNoLocsMaybe [] _ = Nothing +ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX -ppContextNoArrow [] _ = empty -ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode +ppContextNoArrow cxt unicode = fromMaybe empty $ + ppContextNoLocsMaybe (map unLoc cxt) unicode ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX -ppContextNoLocs [] _ = empty -ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode +ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode ppContext :: HsContext DocName -> Bool -> LaTeX @@ -870,14 +872,16 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName -> Located (HsContext DocName) -> Bool -> LaTeX -ppForAll expl tvs cxt unicode - | show_forall = forall_part <+> ppLContext cxt unicode - | otherwise = ppLContext cxt unicode +ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode + +ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Bool -> LaTeX +ppLTyVarBndrs expl tvs unicode + | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot + | otherwise = empty where show_forall = not (null (hsQTvBndrs tvs)) && is_explicit is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot - ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode @@ -955,11 +959,6 @@ ppBinder n | isInfixName n = parens $ ppOccName n | otherwise = ppOccName n -ppBinderInfix :: OccName -> LaTeX -ppBinderInfix n - | isInfixName n = ppOccName n - | otherwise = quotes $ ppOccName n - isInfixName :: OccName -> Bool isInfixName n = isVarSym n || isConSym n @@ -998,9 +997,6 @@ ppLDocName (L _ d) = ppDocName d ppDocBinder :: DocName -> LaTeX ppDocBinder = ppBinder . nameOccName . getName -ppDocBinderInfix :: DocName -> LaTeX -ppDocBinderInfix = ppBinderInfix . nameOccName . getName - ppName :: Name -> LaTeX ppName = ppOccName . nameOccName diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 893c2a50..ae01ab6e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -32,7 +32,6 @@ import Control.Applicative import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe -import Data.Monoid ( mempty ) import Text.XHtml hiding ( name, title, p, quote ) import GHC @@ -49,8 +48,8 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs spl TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual - SigD (PatSynSig lname args ty prov req) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual + SigD (PatSynSig lname qtvs prov req ty) -> + ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" @@ -74,39 +73,32 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual = ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Located DocName -> - HsPatSynDetails (LHsType DocName) -> LHsType DocName -> - LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] -> + (HsExplicitFlag, LHsTyVarBndrs DocName) -> + LHsContext DocName -> LHsContext DocName -> + LHsType DocName -> + [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual = - ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) - (unLoc prov) (unLoc req) fixities splice unicode qual - -ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - DocName -> - HsPatSynDetails (HsType DocName) -> HsType DocName -> - HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities - splice unicode qual +ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual | summary = pref1 - | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual) + | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) +++ docSection Nothing qual doc where pref1 = hsep [ toHtml "pattern" - , pp_cxt prov - , pp_head + , ppBinder summary occname , dcolon unicode - , pp_cxt req - , ppType unicode qual typ + , ppLTyVarBndrs expl qtvs unicode qual + , cxt + , ppLType 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 + cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of + (Nothing, Nothing) -> noHtml + (Nothing, Just req) -> parens noHtml <+> darr <+> req <+> darr + (Just prov, Nothing) -> prov <+> darr + (Just prov, Just req) -> prov <+> darr <+> req <+> darr - occname = nameOccName . getName $ docname + darr = darrow unicode + occname = nameOccName . getName $ name ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> @@ -356,17 +348,23 @@ ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc +ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html +ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc + ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html -ppContextNoArrow [] _ _ = noHtml -ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual +ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ + ppContextNoLocsMaybe (map unLoc cxt) unicode qual ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html -ppContextNoLocs [] _ _ = noHtml -ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual - <+> darrow unicode +ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode qual +ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html +ppContextNoLocsMaybe [] _ _ = Nothing +ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual + ppContext :: HsContext DocName -> Unicode -> Qualification -> Html ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual @@ -812,10 +810,18 @@ ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName ppForAllCon expl tvs cxt unicode qual | show_forall = forall_part <+> ppLContext cxt unicode qual | otherwise = ppLContext cxt unicode qual + where + forall_part = ppLTyVarBndrs expl tvs unicode qual + +ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Unicode -> Qualification + -> Html +ppLTyVarBndrs expl tvs unicode _qual + | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot + | otherwise = noHtml where show_forall = not (null (hsQTvBndrs tvs)) && is_explicit is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html -- cgit v1.2.3