aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs29
-rw-r--r--haddock-api/src/Haddock/Convert.hs42
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs34
3 files changed, 84 insertions, 21 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index b2b6f904..56b64120 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -230,7 +230,8 @@ ppTyName = ppName Prefix
ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
-> Unicode -> Qualification -> Html
ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
- , fdKindSig = mkind })
+ , fdResultSig = L _ result
+ , fdInjectivityAnn = injectivity })
unicode qual =
(case info of
OpenTypeFamily
@@ -245,11 +246,24 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
ppFamDeclBinderWithVars summary d <+>
- (case mkind of
- Just kind -> dcolon unicode <+> ppLKind unicode qual kind
- Nothing -> noHtml
+ (case result of
+ NoSig -> noHtml
+ KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind
+ TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+ ) <+>
+
+ (case injectivity of
+ Nothing -> noHtml
+ Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn
)
+
+ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html
+ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =
+ char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+>
+ hsep (map (ppLDocName qual Raw) rhs)
+
+
ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->
[(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html
@@ -817,6 +831,13 @@ ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual
ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
+ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html
+ppHsTyVarBndr _ qual (UserTyVar 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)
+
ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index ce30e1dd..43cd0ea2 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -28,7 +28,7 @@ import DataCon
import FamInstEnv
import Haddock.Types
import HsSyn
-import Kind ( splitKindFunTys, synTyConResKind, isKind )
+import Kind ( splitKindFunTys, tyConResKind, isKind )
import Name
import PatSyn
import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
@@ -39,6 +39,7 @@ import TypeRep
import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName, eqTyCon, ipTyCon )
import Unique ( getUnique )
+import Util ( filterByList )
import Var
@@ -165,7 +166,8 @@ synifyTyCon coax tc
| isTypeFamilyTyCon tc
= case famTyConFlav_maybe tc of
Just rhs ->
- let info = case rhs of
+ let resultVar = famTcResVar tc
+ info = case rhs of
OpenSynFamilyTyCon -> return OpenTypeFamily
ClosedSynFamilyTyCon mb -> case mb of
Just (CoAxiom { co_ax_branches = branches })
@@ -177,21 +179,25 @@ synifyTyCon coax tc
AbstractClosedSynFamilyTyCon {}
-> return $ ClosedTypeFamily Nothing
in info >>= \i ->
- return (FamDecl
- (FamilyDecl { fdInfo = i
- , fdLName = synifyName tc
- , fdTyVars = synifyTyVars (tyConTyVars tc)
- , fdKindSig =
- Just (synifyKindSig (synTyConResKind tc))
- }))
+ return (FamDecl (FamilyDecl { fdInfo = i
+ , fdLName = synifyName tc
+ , fdTyVars = synifyTyVars (tyConTyVars tc)
+ , fdResultSig =
+ synifyFamilyResultSig resultVar (tyConResKind tc)
+ , fdInjectivityAnn =
+ synifyInjectivityAnn resultVar (tyConTyVars tc)
+ (familyTyConInjectivityInfo tc)
+ }))
Nothing -> Left "synifyTyCon: impossible open type synonym?"
| isDataFamilyTyCon tc
= --(why no "isOpenAlgTyCon"?)
case algTyConRhs tc of
DataFamilyTyCon -> return $
- FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
- Nothing) --always kind '*'
+ FamDecl (FamilyDecl DataFamily (synifyName tc)
+ (synifyTyVars (tyConTyVars tc))
+ (noLoc NoSig) -- always kind '*'
+ Nothing) -- no injectivity
_ -> Left "synifyTyCon: impossible open data type?"
| Just ty <- synTyConRhs_maybe tc
= return $ SynDecl { tcdLName = synifyName tc
@@ -242,6 +248,20 @@ synifyTyCon coax tc
, tcdFVs = placeHolderNamesTc }
dataConErrs -> Left $ unlines dataConErrs
+synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity
+ -> Maybe (LInjectivityAnn Name)
+synifyInjectivityAnn Nothing _ _ = Nothing
+synifyInjectivityAnn _ _ NotInjective = Nothing
+synifyInjectivityAnn (Just lhs) tvs (Injective inj) =
+ let rhs = map (noLoc . tyVarName) (filterByList inj tvs)
+ in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs
+
+synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name
+synifyFamilyResultSig Nothing kind =
+ noLoc $ KindSig (synifyKindSig kind)
+synifyFamilyResultSig (Just name) kind =
+ noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind))
+
-- User beware: it is your responsibility to pass True (use_gadt_syntax)
-- for any constructor that would be misrepresented by omitting its
-- result-type.
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 2b50ce9a..b8fac887 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -176,6 +176,25 @@ renameLKind = renameLType
renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
renameMaybeLKind = traverse renameLKind
+renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName)
+renameFamilyResultSig (L loc NoSig)
+ = return (L loc NoSig)
+renameFamilyResultSig (L loc (KindSig ki))
+ = do { ki' <- renameLKind ki
+ ; return (L loc (KindSig ki')) }
+renameFamilyResultSig (L loc (TyVarSig bndr))
+ = do { bndr' <- renameLTyVarBndr bndr
+ ; return (L loc (TyVarSig bndr')) }
+
+renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName)
+renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))
+ = do { lhs' <- renameL lhs
+ ; rhs' <- mapM renameL rhs
+ ; return (L loc (InjectivityAnn lhs' rhs')) }
+
+renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name)
+ -> RnM (Maybe (LInjectivityAnn DocName))
+renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameType :: HsType Name -> RnM (HsType DocName)
renameType t = case t of
@@ -335,13 +354,16 @@ renameTyClD d = case d of
renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
- , fdTyVars = ltyvars, fdKindSig = tckind }) = do
- info' <- renameFamilyInfo info
- lname' <- renameL lname
- ltyvars' <- renameLTyVarBndrs ltyvars
- tckind' <- renameMaybeLKind tckind
+ , fdTyVars = ltyvars, fdResultSig = result
+ , fdInjectivityAnn = injectivity }) = do
+ info' <- renameFamilyInfo info
+ lname' <- renameL lname
+ ltyvars' <- renameLTyVarBndrs ltyvars
+ result' <- renameFamilyResultSig result
+ injectivity' <- renameMaybeInjectivityAnn injectivity
return (FamilyDecl { fdInfo = info', fdLName = lname'
- , fdTyVars = ltyvars', fdKindSig = tckind' })
+ , fdTyVars = ltyvars', fdResultSig = result'
+ , fdInjectivityAnn = injectivity' })
renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
renameFamilyInfo DataFamily = return DataFamily
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-16 02:23:23 +0000