aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs42
-rw-r--r--haddock-api/src/Haddock/Convert.hs42
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs34
3 files changed, 96 insertions, 22 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 69393a37..bc16bdcd 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -257,12 +257,32 @@ ppFamilyKind _ _ Nothing = noHtml
ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
-> Unicode -> Qualification -> Html
ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
- , fdKindSig = mkind })
+ , fdResultSig = L _ result
+ , fdInjectivityAnn = injectivity })
unicode qual =
- ppFamilyInfo associated info <+>
- ppFamDeclBinderWithVars summary d <+>
- ppFamilyKind unicode qual mkind
-
+ (case info of
+ OpenTypeFamily
+ | associated -> keyword "type"
+ | otherwise -> keyword "type family"
+ DataFamily
+ | associated -> keyword "data"
+ | otherwise -> keyword "data family"
+ ClosedTypeFamily _
+ -> keyword "type family"
+ ) <+>
+
+ ppFamDeclBinderWithVars summary d <+>
+
+ (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
+ )
ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName
-> Html
@@ -271,6 +291,11 @@ ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>
ppFamilyKind unicode qual pfdKindSig
+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 ->
@@ -913,6 +938,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 24947876..cf8b8243 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -26,7 +26,7 @@ import Data.List( partition )
import DataCon
import FamInstEnv
import HsSyn
-import Kind ( splitKindFunTys, synTyConResKind, isKind )
+import Kind ( splitKindFunTys, tyConResKind, isKind )
import Name
import PatSyn
import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
@@ -37,6 +37,7 @@ import TypeRep
import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName, eqTyCon, ipTyCon )
import Unique ( getUnique )
+import Util ( filterByList )
import Var
import Haddock.Types
@@ -166,7 +167,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 })
@@ -178,21 +180,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
@@ -243,6 +249,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 30074e4f..6ec1f2c5 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
@@ -343,13 +362,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' })
renamePseudoFamilyDecl :: PseudoFamilyDecl Name
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 09:02:18 +0000