aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Org.hs
diff options
context:
space:
mode:
authorYuchen Pei <hi@ypei.me>2022-08-16 09:56:48 +1000
committerYuchen Pei <hi@ypei.me>2022-08-16 14:06:43 +1000
commit679feca3756129aed29ac992013d5a5a081f0391 (patch)
treed544c0bc8e2d98978864fd49149ac92861dee158 /haddock-api/src/Haddock/Backends/Org.hs
parent60c434026e14a03252282e9dd82c6787cc90c442 (diff)
handling associated types for classes
Also fixed the familydecl a bit
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Org.hs')
-rw-r--r--haddock-api/src/Haddock/Backends/Org.hs72
1 files changed, 47 insertions, 25 deletions
diff --git a/haddock-api/src/Haddock/Backends/Org.hs b/haddock-api/src/Haddock/Backends/Org.hs
index 70994d1a..1de6200c 100644
--- a/haddock-api/src/Haddock/Backends/Org.hs
+++ b/haddock-api/src/Haddock/Backends/Org.hs
@@ -537,45 +537,67 @@ ppTyClDecl (ClassDecl {..}) docs subdocs path level =
-- TODO: do we need an aDoc here instead of M.empty?
-- TODO: handle default sigs
++ concatMap
+ ((\assoc -> ppFamilyDecl assoc False emptyDoc subdocs path (level + 1))
+ . unLoc
+ )
+ tcdATs
+ ++ concatMap
((\sig -> ppSig sig emptyDoc subdocs path (level + 1)) . unLoc)
tcdSigs
-- type family ... where
-- TODO: handle infix
-ppTyClDecl (FamDecl _ (FamilyDecl _ (ClosedTypeFamily mbEqns) TopLevel (L _ name) tyvars _fixity (L _ resSig) mbInj)) docs subdocs path level
+ppTyClDecl (FamDecl _ familyDecl) docs subdocs path level =
+ ppFamilyDecl familyDecl True docs subdocs path level
+
+ppFamilyDecl
+ :: FamilyDecl DocNameI
+ -> Bool
+ -> DocForDecl DocName
+ -> SubDocs
+ -> ModPath
+ -> Int
+ -> [OrgBlock]
+ppFamilyDecl (FamilyDecl _ info@(ClosedTypeFamily mbEqns) TopLevel (L _ name) tyvars _fixity (L _ resSig) mbInj) isFamDecl docs subdocs path level
= Heading
level
- ( [plaintext "type family ", Plain $ docNameToDoc name, Whitespace]
+ ( ppFamilyInfo info isFamDecl
+ ++ [Whitespace, Plain $ docNameToDoc name, Whitespace]
++ ppLHsQTyVars tyvars
- ++ ppFamilyResultSig resSig "="
+ ++ ppFamilyResultSig resSig
++ maybe [] ppLInjectivityAnn mbInj
++ [plaintext " where"]
)
(cIdPaths path name)
- : ppDocForDecl docs (Just level)
+ : (if isFamDecl
+ then ppDocForDecl docs (Just level)
+ else maybe [] (`ppDocForDecl` (Just level)) (lookup name subdocs)
+ )
++ concatMap (\x -> ppLTyFamInstEqn x subdocs path (level + 1))
(fromMaybe [] mbEqns)
--- data family
--- type family
--- DataFamily or OpenTypeFamily
-ppTyClDecl (FamDecl _ (FamilyDecl _ info TopLevel (L _ name) tyvars _fixity (L _ resSig) mbInj)) docs _ path level
+ppFamilyDecl (FamilyDecl _ info TopLevel (L _ name) tyvars _fixity (L _ resSig) mbInj) isFamDecl docs subdocs path level
= Heading
level
- ( [pre, Plain $ docNameToDoc name, Whitespace]
+ ( ppFamilyInfo info isFamDecl
+ ++ [Whitespace, Plain $ docNameToDoc name, Whitespace]
++ ppLHsQTyVars tyvars
- ++ ppFamilyResultSig resSig op
+ ++ ppFamilyResultSig resSig
++ maybe [] ppLInjectivityAnn mbInj
)
(cIdPaths path name)
- : ppDocForDecl docs (Just level)
+ : (if isFamDecl
+ then ppDocForDecl docs (Just level)
+ else maybe [] (`ppDocForDecl` (Just level)) (lookup name subdocs)
+ )
+ppFamilyDecl _ _ docs _ _ level =
+ unimpHeading "FamilyDecl" level : ppDocForDecl docs (Just level)
+
+ppFamilyInfo :: FamilyInfo DocNameI -> Bool -> [OrgInline]
+ppFamilyInfo info isFamDecl = dataOrType : family
where
- pre = case info of
- DataFamily -> plaintext "data family "
- OpenTypeFamily -> plaintext "type family "
- op = case info of
- DataFamily -> "::"
- _ -> "="
-ppTyClDecl (FamDecl{}) docs _ _ level =
- unimpHeading "FamDecl" level : ppDocForDecl docs (Just level)
+ dataOrType = case info of
+ DataFamily -> plaintext "data"
+ _ -> plaintext "type"
+ family = if isFamDecl then [plaintext " family"] else []
ppLTyFamInstEqn
:: LTyFamInstEqn DocNameI -> SubDocs -> ModPath -> Int -> [OrgBlock]
@@ -606,12 +628,12 @@ ppLInjectivityAnn (L _ (InjectivityAnn _ (L _ l) rs)) =
]
ppLInjectivityAnn _ = [plaintext $ unimp "LInjectivityAnn"]
-ppFamilyResultSig :: FamilyResultSig DocNameI -> String -> [OrgInline]
-ppFamilyResultSig (KindSig _ (L _ x)) op =
- [Whitespace, plaintext op, Whitespace] ++ ppHsType x
-ppFamilyResultSig (NoSig{}) _ = []
-ppFamilyResultSig (TyVarSig _ x) op =
- [Whitespace, plaintext op, Whitespace] ++ ppLHsTyVarBndr x
+ppFamilyResultSig :: FamilyResultSig DocNameI -> [OrgInline]
+ppFamilyResultSig (KindSig _ (L _ x)) =
+ [Whitespace, plaintext "::", Whitespace] ++ ppHsType x
+ppFamilyResultSig (NoSig{}) = []
+ppFamilyResultSig (TyVarSig _ x) =
+ [Whitespace, plaintext "=", Whitespace] ++ ppLHsTyVarBndr x
ppDataDefn :: HsDataDefn DocNameI -> SubDocs -> ModPath -> Int -> [OrgBlock]
ppDataDefn (HsDataDefn _ _ _ _ _ cons _derivs) subdocs path level =