From e0718f203f2448ba2029e70d14aed075860b7fac Mon Sep 17 00:00:00 2001
From: nand <git@nand.wakku.to>
Date: Tue, 4 Feb 2014 22:13:27 +0100
Subject: Add support for type/data families
This adds support for type/data families with their respective
instances, as well as closed type families and associated type/data
families.
Signed-off-by: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
---
src/Haddock/Backends/Xhtml/Decl.hs | 42 +++++++++++++++++++++---------------
src/Haddock/Backends/Xhtml/Layout.hs | 5 +++++
2 files changed, 30 insertions(+), 17 deletions(-)
(limited to 'src/Haddock/Backends/Xhtml')
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index acde5a0f..9180c3c3 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,7 +41,7 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
Bool -> Qualification -> Html
ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual
+ TyClD (FamDecl d) -> ppTyFam summ False links instances loc mbDoc d unicode qual
TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
@@ -212,9 +212,9 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
Nothing -> noHtml
)
-ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
+ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan -> Documentation DocName ->
FamilyDecl DocName -> Bool -> Qualification -> Html
-ppTyFam summary associated links loc doc decl unicode qual
+ppTyFam summary associated links instances loc doc decl unicode qual
| summary = ppTyFamHeader True associated decl unicode qual
| otherwise = header_ +++ docSection qual doc +++ instancesBit
@@ -225,16 +225,19 @@ ppTyFam summary associated links loc doc decl unicode qual
header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual)
instancesBit
- | FamilyDecl { fdInfo = ClosedTypeFamily _eqns } <- decl
+ | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl
, not summary
- = noHtml -- TODO: print eqns
+ = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
| otherwise
= ppInstances instances docname unicode qual
- -- TODO: get the instances
- instances = []
-
+ -- Individual equation of a closed type family
+ ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs
+ , tfie_pats = HsWB { hswb_cts = ts }}
+ = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
+ <+> equals <+> ppType unicode qual (unLoc rhs)
+ , Nothing, [] )
--------------------------------------------------------------------------------
-- * Associated Types
@@ -244,7 +247,7 @@ ppTyFam summary associated links loc doc decl unicode qual
ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName -> Bool
-> Qualification -> Html
ppAssocType summ links doc (L loc decl) unicode qual =
- ppTyFam summ True links loc (fst doc) decl unicode qual
+ ppTyFam summ True links [] loc (fst doc) decl unicode qual
--------------------------------------------------------------------------------
@@ -423,10 +426,14 @@ ppInstances instances baseName unicode qual
instName = getOccString $ getName baseName
instDecl :: DocInstance DocName -> SubDecl
instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
- instHead ([], n, ts) = ppAppNameTypes n ts unicode qual
- instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode qual
+ instHead (n, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
<+> ppAppNameTypes n ts unicode qual
-
+ instHead (n, ts, TypeInst rhs) = keyword "type"
+ <+> ppAppNameTypes n ts unicode qual
+ <+> equals <+> ppType unicode qual rhs
+ instHead (n, ts, DataInst dd) = keyword "data"
+ <+> ppAppNameTypes n ts unicode qual
+ <+> ppShortDataDecl False True dd unicode qual
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
@@ -438,9 +445,8 @@ lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
-- TODO: print contexts
-ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool
- -> Qualification -> Html
-ppShortDataDecl summary _links _loc dataDecl unicode qual
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppShortDataDecl summary dataInst dataDecl unicode qual
| [] <- cons = dataHeader
@@ -455,7 +461,9 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual
+++ shortSubDecls (map doGADTConstr cons)
where
- dataHeader = ppDataHeader summary dataDecl unicode qual
+ dataHeader
+ | dataInst = noHtml
+ | otherwise = ppDataHeader summary dataDecl unicode qual
doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
@@ -469,7 +477,7 @@ ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
Qualification -> Html
ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
- | summary = ppShortDataDecl summary links loc dataDecl unicode qual
+ | summary = ppShortDataDecl summary False dataDecl unicode qual
| otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
where
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 4584fd82..dbc043be 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -29,6 +29,7 @@ module Haddock.Backends.Xhtml.Layout (
subArguments,
subAssociatedTypes,
subConstructors,
+ subEquations,
subFields,
subInstances,
subMethods,
@@ -165,6 +166,10 @@ subFields :: Qualification -> [SubDecl] -> Html
subFields qual = divSubDecls "fields" "Fields" . subDlist qual
+subEquations :: Qualification -> [SubDecl] -> Html
+subEquations qual = divSubDecls "equations" "Equations" . subTable qual
+
+
subInstances :: Qualification -> String -> [SubDecl] -> Html
subInstances qual nm = maybe noHtml wrap . instTable
where
--
cgit v1.2.3