diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 42 |
1 files changed, 31 insertions, 11 deletions
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 |