From 0f21c474382af69bb7dac214d6c225218240e033 Mon Sep 17 00:00:00 2001
From: Max Bolingbroke <batterseapower@hotmail.com>
Date: Tue, 6 Sep 2011 09:13:59 +0100
Subject: Ignore associated type defaults (just as we ignore default methods)
---
src/Haddock/Backends/LaTeX.hs | 6 +++---
src/Haddock/Backends/Xhtml/Decl.hs | 4 ++--
src/Haddock/Convert.hs | 13 ++++++++++---
src/Haddock/Interface/Rename.hs | 5 +++--
4 files changed, 18 insertions(+), 10 deletions(-)
(limited to 'src/Haddock')
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 27f6bd5e..a6e1bcdc 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -473,7 +473,7 @@ ppClassDecl :: [DocInstance DocName] -> SrcSpan
-> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocName -> Bool -> LaTeX
ppClassDecl instances loc mbDoc subdocs
- (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode
+ (ClassDecl lctxt lname ltyvars lfds lsigs _ ats at_defs _) unicode
= declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$
instancesBit
where
@@ -486,8 +486,8 @@ ppClassDecl instances loc mbDoc subdocs
body = catMaybes [fmap docToLaTeX mbDoc, body_]
body_
- | null lsigs, null ats = Nothing
- | null ats = Just methodTable
+ | null lsigs, null ats, null at_defs = Nothing
+ | null ats, null at_defs = Just methodTable
--- | otherwise = atTable $$ methodTable
| otherwise = error "LaTeX.ppClassDecl"
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index add926ab..16e32b7e 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -352,7 +352,7 @@ ppFds fds unicode qual =
ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
-> [(DocName, DocForDecl DocName)] -> Bool -> Qualification
-> Html
-ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
+ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) loc
subdocs unicode qual =
if null sigs && null ats
then (if summary then id else topDeclElem links loc [nm]) hdr
@@ -381,7 +381,7 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
-> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocName -> Bool -> Qualification -> Html
ppClassDecl summary links instances loc mbDoc subdocs
- decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode qual
+ decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) unicode qual
| summary = ppShortClassDecl summary links decl loc subdocs unicode qual
| otherwise = classheader +++ maybeDocSection qual mbDoc
+++ atBit +++ methodBit +++ instancesBit
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 34de6775..81435a6e 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -68,14 +68,21 @@ tyThingToLHsDecl t = noLoc $ case t of
(map (noLoc . synifyIdSig DeleteTopLevelQuantification)
(classMethods cl))
emptyBag --ignore default method definitions, they don't affect signature
- (map synifyClassAT (classATs cl))
+ ats
+ (concat at_defss)
[] --we don't have any docs at this point
+ where (ats, at_defss) = unzip $ map synifyClassAT (classATItems cl)
-- class associated-types are a subset of TyCon
-- (mainly only type/data-families)
-synifyClassAT :: TyCon -> LTyClDecl Name
-synifyClassAT = noLoc . synifyTyCon
+synifyClassAT :: ClassATItem -> (LTyClDecl Name, [LTyClDecl Name])
+synifyClassAT (tc, _mb_defs) = (noLoc (synifyTyCon tc), [])
+ -- ignore the mb_defs since we ignore default methods
+
+synifyATDefault :: TyCon -> LTyClDecl Name
+synifyATDefault tc = noLoc (synifyAxiom ax)
+ where Just ax = tyConFamilyCoercion_maybe tc
synifyAxiom :: CoAxiom -> TyClDecl Name
synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs })
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 2d5c899a..70520028 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -351,15 +351,16 @@ renameTyClD d = case d of
typats' <- mapM (mapM renameLType) typats
return (TySynonym lname' ltyvars' typats' ltype')
- ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats _ -> do
+ ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats at_defs _ -> do
lcontext' <- renameLContext lcontext
lname' <- renameL lname
ltyvars' <- mapM renameLTyVarBndr ltyvars
lfundeps' <- mapM renameLFunDep lfundeps
lsigs' <- mapM renameLSig lsigs
ats' <- mapM renameLTyClD ats
+ at_defs' <- mapM renameLTyClD at_defs
-- we don't need the default methods or the already collected doc entities
- return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' [])
+ return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' at_defs' [])
where
renameLCon (L loc con) = return . L loc =<< renameCon con
--
cgit v1.2.3