aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Xhtml
diff options
context:
space:
mode:
authorGert-Jan Bottu <gertjan.bottu@kuleuven.be>2020-04-05 11:16:56 +0200
committerGert-Jan Bottu <gertjan.bottu@kuleuven.be>2020-05-15 22:09:44 +0200
commita8d7e66da4dcc3b242103271875261604be42d6e (patch)
treee468ca29b905b35f76318f547a173de401995672 /haddock-api/src/Haddock/Backends/Xhtml
parent97f301a63ea8461074bfaa1486eb798e4be65f15 (diff)
Explicit Specificity Support for Haddock
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs42
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