From a8d7e66da4dcc3b242103271875261604be42d6e Mon Sep 17 00:00:00 2001
From: Gert-Jan Bottu <gertjan.bottu@kuleuven.be>
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