diff options
Diffstat (limited to 'src/Haddock/Backends/Xhtml/Decl.hs')
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 62 |
1 files changed, 32 insertions, 30 deletions
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 59be34f7..db39ccca 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -39,10 +39,9 @@ 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 d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode qual - TyClD d@(TyDecl{ tcdTyDefn = defn }) - | isHsDataDefn defn -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual - | otherwise -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual + TyClD (FamDecl d) -> ppTyFam summ False links 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 SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual @@ -115,8 +114,8 @@ ppFor _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTySyn summary links loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars - , tcdTyDefn = TySynonym { td_synRhs = ltype } }) +ppTySyn summary links loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdRhs = ltype }) unicode qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full, hdr, spaceHtml +++ equals) unicode qual @@ -145,10 +144,10 @@ ppTyName name -------------------------------------------------------------------------------- -ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTyFamHeader summary associated decl unicode qual = - - (case tcdFlavour decl of +ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Bool -> Qualification -> Html +ppTyFamHeader summary associated d@(FamilyDecl { fdFlavour = flav + , fdKindSig = mkind }) unicode qual = + (case flav of TypeFamily | associated -> keyword "type" | otherwise -> keyword "type family" @@ -157,22 +156,22 @@ ppTyFamHeader summary associated decl unicode qual = | otherwise -> keyword "data family" ) <+> - ppTyClBinderWithVars summary decl <+> + ppFamDeclBinderWithVars summary d <+> - case tcdKindSig decl of + case mkind of Just kind -> dcolon unicode <+> ppLKind unicode qual kind Nothing -> noHtml ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName -> - TyClDecl DocName -> Bool -> Qualification -> Html + FamilyDecl DocName -> Bool -> Qualification -> Html ppTyFam summary associated links loc doc decl unicode qual | summary = ppTyFamHeader True associated decl unicode qual | otherwise = header_ +++ docSection qual doc +++ instancesBit where - docname = tcdName decl + docname = unLoc $ fdLName decl header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual) @@ -187,23 +186,25 @@ ppTyFam summary associated links loc doc decl unicode qual -------------------------------------------------------------------------------- -ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool +ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName -> Bool -> Qualification -> Html ppAssocType summ links doc (L loc decl) unicode qual = - case decl of - TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode qual - _ -> error "declaration type not supported by ppAssocType" + ppTyFam summ True links loc (fst doc) decl unicode qual -------------------------------------------------------------------------------- -- * TyClDecl helpers -------------------------------------------------------------------------------- +-- | Print a type family and its variables +ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html +ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = + ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs) --- | Print a type family / newtype / data / class binder and its variables -ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> Html -ppTyClBinderWithVars summ decl = - ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl) +-- | Print a newtype / data binder and its variables +ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html +ppDataBinderWithVars summ decl = + ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl) -------------------------------------------------------------------------------- @@ -303,7 +304,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t +++ shortSubDecls ( [ ppAssocType summary links doc at unicode qual | at <- ats - , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ + , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ -- ToDo: add associated type defaults @@ -336,14 +337,14 @@ ppClassDecl summary links instances loc d subdocs | null lsigs = topDeclElem links loc [nm] (hdr unicode qual) | otherwise = topDeclElem links loc [nm] (hdr unicode qual <+> keyword "where") - nm = unLoc $ tcdLName decl + nm = tcdName decl hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds -- ToDo: add assocatied typ defaults atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode qual | at <- ats - , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] + , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] methodBit = subMethods [ ppFunSig summary links loc doc names typ unicode qual | L _ (TypeSig lnames (L _ typ)) <- lsigs @@ -401,7 +402,7 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual - cons = td_cons (tcdTyDefn dataDecl) + cons = dd_cons (tcdDataDefn dataDecl) resTy = (con_res . unLoc . head) cons @@ -415,8 +416,8 @@ ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit where - docname = unLoc . tcdLName $ dataDecl - cons = td_cons (tcdTyDefn dataDecl) + docname = tcdName dataDecl + cons = dd_cons (tcdDataDefn dataDecl) resTy = (con_res . unLoc . head) cons header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual @@ -570,14 +571,15 @@ ppShortField summary unicode qual (ConDeclField (L _ name) ltype _) -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html -ppDataHeader summary decl@(TyDecl { tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) +ppDataHeader summary decl@(DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd + , dd_ctxt = ctxt } }) unicode qual = -- newtype or data (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context ppLContext ctxt unicode qual <+> -- T a b c ..., or a :+: b - ppTyClBinderWithVars summary decl + ppDataBinderWithVars summary decl ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" |