From e0718f203f2448ba2029e70d14aed075860b7fac Mon Sep 17 00:00:00 2001 From: nand 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 --- src/Haddock/Backends/LaTeX.hs | 16 ++++++++------ src/Haddock/Backends/Xhtml.hs | 1 + src/Haddock/Backends/Xhtml/Decl.hs | 42 +++++++++++++++++++++--------------- src/Haddock/Backends/Xhtml/Layout.hs | 5 +++++ 4 files changed, 40 insertions(+), 24 deletions(-) (limited to 'src/Haddock/Backends') diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 94adc558..2185340b 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -284,7 +284,7 @@ ppDecl :: LHsDecl DocName ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode TyClD d@(DataDecl {}) - -> ppDataDecl instances subdocs loc doc d unicode + -> ppDataDecl instances subdocs loc (Just doc) d unicode TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now -- TyClD d@(TySynonym {}) @@ -560,9 +560,11 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead ppInstHead :: Bool -> InstHead DocName -> LaTeX -ppInstHead unicode ([], n, ts) = ppAppNameTypes n ts unicode -ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode - +ppInstHead unicode (n, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ts unicode +ppInstHead unicode (n, ts, TypeInst rhs) = keyword "type" + <+> ppAppNameTypes n ts unicode <+> equals <+> ppType unicode rhs +ppInstHead _unicode (_n, _ts, DataInst _dd) = + error "data instances not supported by --latex yet" lookupAnySubdoc :: (Eq name1) => name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 @@ -577,8 +579,8 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of ppDataDecl :: [DocInstance DocName] -> - [(DocName, DocForDecl DocName)] -> - SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> + [(DocName, DocForDecl DocName)] -> SrcSpan -> + Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> LaTeX ppDataDecl instances subdocs _loc doc dataDecl unicode @@ -590,7 +592,7 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode cons = dd_cons (tcdDataDefn dataDecl) resTy = (con_res . unLoc . head) cons - body = catMaybes [constrBit, documentationToLaTeX doc] + body = catMaybes [constrBit, doc >>= documentationToLaTeX] (whereBit, leaders) | null cons = (empty,[]) diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 3168c7b0..53b106a2 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -648,6 +648,7 @@ numberSectionHeadings = go 1 processExport :: Bool -> LinksInfo -> Bool -> Qualification -> ExportItem DocName -> Maybe Html +processExport _ _ _ _ (ExportDecl (L _ (InstD _)) _ _ _) = Nothing -- Hide empty instances processExport summary _ _ qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc processExport summary links unicode qual (ExportDecl decl doc subdocs insts) 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