From ab45e736f6a4c720c3c69f4d3fccdd293a298806 Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Wed, 2 Jul 2008 22:01:38 +0000
Subject: More support for type families and associated types Now we just need
to render the instances
---
src/Haddock/Backends/Html.hs | 119 +++++++++++++++++++++++-----------------
src/Haddock/Interface/Create.hs | 4 +-
2 files changed, 73 insertions(+), 50 deletions(-)
(limited to 'src/Haddock')
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 0fbf8760..5940f8bb 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -30,7 +30,7 @@ import Control.Exception ( bracket )
import Control.Monad ( when, unless )
import Data.Char ( isUpper, toUpper )
import Data.List ( sortBy )
-import Data.Maybe ( fromJust, isJust, mapMaybe, fromMaybe )
+import Data.Maybe
import Foreign.Marshal.Alloc ( allocaBytes )
import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile )
import Data.Map ( Map )
@@ -664,7 +664,7 @@ doDecl summary links x (L loc d) mbDoc instances docMap = doDecl d
ppFunSig summary links loc mbDoc (docNameOrig n) t
doDecl (ForD d) = ppFor summary links loc mbDoc d
- doTyClD d0@(TyFamily {}) = ppTyFamily summary links x loc mbDoc d0
+ doTyClD d0@(TyFamily {}) = ppTyFam summary False links loc mbDoc d0
doTyClD d0@(TyData {}) = ppDataDecl summary links instances x loc mbDoc d0
doTyClD d0@(TySynonym {}) = ppTySyn summary links loc mbDoc d0
doTyClD d0@(ClassDecl {}) = ppClassDecl summary links instances x loc mbDoc docMap d0
@@ -758,12 +758,17 @@ ppTyNames = map ppTyName
--------------------------------------------------------------------------------
-ppTyFamHeader :: Bool -> TyClDecl DocName -> Html
-ppTyFamHeader summary decl =
+ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Html
+ppTyFamHeader summary associated decl =
(case tcdFlavour decl of
- TypeFamily -> keyword "type family"
- DataFamily -> keyword "data family") <+>
+ TypeFamily
+ | associated -> keyword "type"
+ | otherwise -> keyword "type family"
+ DataFamily
+ | associated -> keyword "data"
+ | otherwise -> keyword "data family"
+ ) <+>
ppTyClBinderWithVars summary decl <+>
@@ -772,21 +777,22 @@ ppTyFamHeader summary decl =
Nothing -> empty
-ppTyFamily :: Bool -> LinksInfo -> Name -> SrcSpan -> Maybe (HsDoc DocName) ->
+ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->
TyClDecl DocName -> HtmlTable
-ppTyFamily summary links name loc mbDoc decl
+ppTyFam summary associated links loc mbDoc decl
| summary = declWithDoc summary links loc name mbDoc
- (ppShortTyFamilyDecl summary links loc mbDoc decl)
+ (ppTyFamHeader True associated decl)
- | otherwise
- = (if validTable then (</>) else const) header $
- tda [theclass "body"] << vanillaTable << (
- doc </>
- instancesBit
- )
+ | associated, isJust mbDoc = header </> bodyBox << doc
+ | associated = header
+ | null instances, isNothing mbDoc = header
+ | otherwise = header </> bodyBox << (doc </> instancesBit)
+
where
- header = topDeclBox links loc name (ppTyFamHeader summary decl)
+ name = docNameOrig . tcdName $ decl
+
+ header = topDeclBox links loc name (ppTyFamHeader summary associated decl)
doc = case mbDoc of
Just d -> ndocBox (docToHtml d)
@@ -805,14 +811,22 @@ ppTyFamily summary links name loc mbDoc decl
)
)
+ -- TODO: get the instances
instances = []
- validTable = isJust mbDoc || not (null instances)
+--------------------------------------------------------------------------------
+-- Associated Types
+--------------------------------------------------------------------------------
+
-ppShortTyFamilyDecl :: Bool -> LinksInfo -> SrcSpan ->
- Maybe (HsDoc DocName) -> TyClDecl DocName -> Html
-ppShortTyFamilyDecl summary links loc mbDoc decl = empty
+ppAssocType :: Bool -> LinksInfo -> DocMap -> LTyClDecl DocName -> HtmlTable
+ppAssocType summ links docMap (L loc decl) =
+ case decl of
+ TyFamily {} -> ppTyFam summ True links loc doc decl
+ TySynonym {} -> ppTySyn summ links loc doc decl
+ where
+ doc = Map.lookup (docNameOrig $ tcdName decl) docMap
--------------------------------------------------------------------------------
@@ -854,9 +868,9 @@ ppTypeApp n ts@(t1:t2:rest) ppDN ppT
ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
-- Contexts
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
ppLContext = ppContext . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc
@@ -886,8 +900,10 @@ ppPred (HsIParam (IPName n) t)
= toHtml "?" +++ ppDocName n <+> dcolon <+> ppLType t
--- -----------------------------------------------------------------------------
+-------------------------------------------------------------------------------
-- Class declarations
+-------------------------------------------------------------------------------
+
ppClassHdr summ lctxt n tvs fds =
keyword "class"
@@ -908,33 +924,31 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
then (if summary then declBox else topDeclBox links loc nm) hdr
else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where")
</>
- (tda [theclass "body"] <<
- vanillaTable <<
- aboves ([ ppAT summary at | L _ at <- ats ] ++
- [ ppFunSig summary links loc mbDoc n typ
- | L _ (TypeSig (L _ fname) (L _ typ)) <- sigs
- , let n = docNameOrig fname, let mbDoc = Map.lookup n docMap ])
- )
+ (
+ bodyBox <<
+ aboves
+ (
+ map (ppAssocType summary links docMap) ats ++
+
+ [ ppFunSig summary links loc mbDoc n typ
+ | L _ (TypeSig (L _ fname) (L _ typ)) <- sigs
+ , let n = docNameOrig fname, let mbDoc = Map.lookup n docMap ]
+
+ )
+ )
where
hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds
nm = docNameOrig . unLoc $ lname
- ppAT summary at = case at of
- TyData {} -> topDeclBox links loc nm (ppDataHeader summary at)
- _ -> error "associated type synonyms or type families not supported yet"
--- we skip ATs for now
+
ppClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> SrcSpan ->
Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName ->
HtmlTable
ppClassDecl summary links instances orig_c loc mbDoc docMap
- decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ _ _)
+ decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _)
| summary = ppShortClassDecl summary links decl loc docMap
- | otherwise
- = classheader </>
- tda [theclass "body"] << vanillaTable << (
- classdoc </> methodsBit </> instancesBit
- )
+ | otherwise = classheader </> bodyBox << (classdoc </> body </> instancesBit)
where
classheader
| null lsigs = topDeclBox links loc nm hdr
@@ -949,15 +963,18 @@ ppClassDecl summary links instances orig_c loc mbDoc docMap
Nothing -> Html.emptyTable
Just d -> ndocBox (docToHtml d)
- methodsBit
- | null lsigs = Html.emptyTable
- | otherwise =
- s8 </> methHdr </>
- tda [theclass "body"] << vanillaTable << (
- abovesSep s8 [ ppFunSig summary links loc mbDoc (docNameOrig n) typ
- | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
- , let mbDoc = Map.lookup (docNameOrig n) docMap ]
- )
+ body
+ | null lsigs, null ats = Html.emptyTable
+ | null ats = s8 </> methHdr </> bodyBox << methodTable
+ | otherwise = s8 </> atHdr </> bodyBox << atTable </>
+ s8 </> methHdr </> bodyBox << methodTable
+
+ methodTable =
+ abovesSep s8 [ ppFunSig summary links loc doc (docNameOrig n) typ
+ | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
+ , let doc = Map.lookup (docNameOrig n) docMap ]
+
+ atTable = abovesSep s8 $ map (ppAssocType summary links docMap) ats
instId = collapseId nm
instancesBit
@@ -1599,6 +1616,9 @@ maybeRDocBox (Just ldoc) = rdocBox (docToHtml (unLoc ldoc))
topButBox :: Html -> HtmlTable
topButBox html = tda [theclass "topbut"] << html
+bodyBox :: Html -> HtmlTable
+bodyBox html = tda [theclass "body"] << vanillaTable << html
+
-- a vanilla table has width 100%, no border, no padding, no spacing
-- a narrow table is the same but without width 100%.
vanillaTable, narrowTable :: Html -> Html
@@ -1613,6 +1633,7 @@ spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0]
constrHdr, methHdr :: HtmlTable
constrHdr = tda [ theclass "section4" ] << toHtml "Constructors"
methHdr = tda [ theclass "section4" ] << toHtml "Methods"
+atHdr = tda [ theclass "section4" ] << toHtml "Associated Types"
instHdr :: String -> HtmlTable
instHdr id =
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index d2e616cc..1b6721e0 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -151,7 +151,7 @@ sortByLoc = map unLoc . sortBy (comparing getLoc)
-- | Get all the entities in a class. The entities are sorted by their
-- SrcLoc.
-getClassEntities tcd = sortByLoc (docs ++ meths ++ sigs)
+getClassEntities tcd = sortByLoc (docs ++ meths ++ sigs ++ ats)
where
docs = [ L l (DocEntity d) | L l d <- tcdDocs tcd ]
@@ -163,6 +163,8 @@ getClassEntities tcd = sortByLoc (docs ++ meths ++ sigs)
-- TODO: fixities
sigs = [ L l $ DeclEntity name | L l (TypeSig (L _ name) _) <- tcdSigs tcd ]
+ ats = [ L l $ DeclEntity name | L l at <- tcdATs tcd
+ , let L _ name = tcdLName at ]
-- | Get all the top level entities in a module. The entities are sorted by
-- their SrcLoc.
--
cgit v1.2.3