From a8d7e66da4dcc3b242103271875261604be42d6e Mon Sep 17 00:00:00 2001 From: Gert-Jan Bottu Date: Sun, 5 Apr 2020 11:16:56 +0200 Subject: Explicit Specificity Support for Haddock --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 +-- haddock-api/src/Haddock/Backends/LaTeX.hs | 25 +++++++++++---- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 42 +++++++++++++++++++------- 3 files changed, 52 insertions(+), 19 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 5d658a7e..e03611b2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -252,8 +252,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - tyVarArg (UserTyVar _ n) = HsTyVar noExtField NotPromoted n - tyVarArg (KindedTyVar _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty + tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n + tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty tyVarArg _ = panic "ppCtor" resType = apps $ map reL $ diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index c54cc459..13f22db7 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -29,6 +29,7 @@ import GHC import GHC.Types.Name.Occurrence import GHC.Types.Name ( nameOccName ) import GHC.Types.Name.Reader ( rdrNameOcc ) +import GHC.Core.Type ( Specificity(..) ) import GHC.Data.FastString ( unpackFS ) import GHC.Utils.Outputable ( panic) @@ -518,7 +519,7 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty -ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX] +ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX] ppTyVars = map (ppSymName . getName . hsLTyVarNameI) @@ -897,7 +898,8 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument" -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> DocName -> [LHsTyVarBndr DocNameI] -> LaTeX +ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag => + Bool -> DocName -> [LHsTyVarBndr flag DocNameI] -> LaTeX ppAppDocNameTyVarBndrs unicode n vs = ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc) where @@ -1007,10 +1009,21 @@ ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <> ppLParendType unicode ki ppLHsTypeArg _ (HsArgPar _) = text "" -ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX -ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name -ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = - parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind +class RenderableBndrFlag flag where + ppHsTyVarBndr :: Bool -> HsTyVarBndr flag DocNameI -> LaTeX + +instance RenderableBndrFlag () where + ppHsTyVarBndr _ (UserTyVar _ _ (L _ name)) = ppDocName name + ppHsTyVarBndr unicode (KindedTyVar _ _ (L _ name) kind) = + parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + +instance RenderableBndrFlag Specificity where + ppHsTyVarBndr _ (UserTyVar _ SpecifiedSpec (L _ name)) = ppDocName name + ppHsTyVarBndr _ (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName name + ppHsTyVarBndr unicode (KindedTyVar _ SpecifiedSpec (L _ name) kind) = + parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + ppHsTyVarBndr unicode (KindedTyVar _ InferredSpec (L _ name) kind) = + braces (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index a8ff584d..76b5fae8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -34,6 +34,7 @@ import qualified Data.Map as Map import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) +import GHC.Core.Type ( Specificity(..) ) import GHC.Types.Basic (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..)) import GHC.Exts @@ -188,10 +189,10 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ -ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> ForallVisFlag +ppForAll :: [LHsTyVarBndr flag DocNameI] -> Unicode -> Qualification -> ForallVisFlag -> Html ppForAll tvs unicode qual fvf = - case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of + case [ppKTv n k | L _ (KindedTyVar _ _ (L _ n) k) <- tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ ppForAllSeparator unicode fvf where ppKTv n k = parens $ @@ -226,7 +227,8 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge -- | Pretty-print type variables. -ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html] +ppTyVars :: RenderableBndrFlag flag => + Unicode -> Qualification -> [LHsTyVarBndr flag DocNameI] -> [Html] ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs @@ -407,7 +409,8 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual = -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html +ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag => + Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr flag DocNameI] -> Html ppAppDocNameTyVarBndrs summ unicode qual n vs = ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc) where @@ -1107,12 +1110,28 @@ ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <> ppLParendType unicode qual emptyCtxts ki ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml "" -ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html -ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = - ppDocName qual Raw False name -ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) = - parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> - ppLKind unicode qual kind) + +class RenderableBndrFlag flag where + ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html + +instance RenderableBndrFlag () where + ppHsTyVarBndr _ qual (UserTyVar _ _ (L _ name)) = + ppDocName qual Raw False name + ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) = + parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + +instance RenderableBndrFlag Specificity where + ppHsTyVarBndr _ qual (UserTyVar _ SpecifiedSpec (L _ name)) = + ppDocName qual Raw False name + ppHsTyVarBndr _ qual (UserTyVar _ InferredSpec (L _ name)) = + braces $ ppDocName qual Raw False name + ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) = + parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) = + braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + ppLKind unicode qual kind) ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) @@ -1146,7 +1165,8 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html ppPatSigType unicode qual typ = let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ -ppForAllPart :: Unicode -> Qualification -> ForallVisFlag -> [LHsTyVarBndr DocNameI] -> Html +ppForAllPart :: RenderableBndrFlag flag => + Unicode -> Qualification -> ForallVisFlag -> [LHsTyVarBndr flag DocNameI] -> Html ppForAllPart unicode qual fvf tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ ppForAllSeparator unicode fvf -- cgit v1.2.3