diff options
| -rw-r--r-- | src/HaddockHtml.hs | 28 | ||||
| -rw-r--r-- | src/HsParser.ly | 26 | ||||
| -rw-r--r-- | src/Main.hs | 2 |
3 files changed, 34 insertions, 22 deletions
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 7f05d42f..06ff5db2 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -17,6 +17,7 @@ import FiniteMap import List ( sortBy ) import Char ( toUpper, toLower ) import Monad ( when ) +import IOExts import Html import qualified Html @@ -461,15 +462,14 @@ keepDecl _ = False -- ----------------------------------------------------------------------------- -- Data & newtype declarations -ppShortDataDecl doc_map summary is_newty +ppShortDataDecl :: Bool -> Bool -> HsDecl -> Html +ppShortDataDecl summary is_newty (HsDataDecl loc ctx nm args [con] drv) = - declBox ( -- single constructor special case - ppHsDataHeader summary is_newty nm args - <+> equals <+> ppShortConstr summary con - ) -ppShortDataDecl doc_map summary is_newty + ppHsDataHeader summary is_newty nm args + <+> equals <+> ppShortConstr summary con +ppShortDataDecl summary is_newty (HsDataDecl loc ctx nm args cons drv) = - declBox << vanillaTable << ( + vanillaTable << ( aboves ( (declBox (ppHsDataHeader summary is_newty nm args) : zipWith do_constr ('=':repeat '|') cons @@ -488,8 +488,9 @@ ppHsDataDecl doc_map summary is_newty (HsDataDecl loc ctx nm args [] drv) = -- The rest of the cases: ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv) - | summary || (isNothing doc && all constr_has_no_doc cons) - = ppShortDataDecl doc_map summary is_newty decl + | summary || no_constr_docs + = declWithDoc summary (lookupFM doc_map nm) + (ppShortDataDecl summary is_newty decl) | otherwise = td << vanillaTable << (header </> datadoc </> constrs) @@ -512,10 +513,15 @@ ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv) Just c = declMainBinder decl doc = lookupFM doc_map c + no_constr_docs = all constr_has_no_doc cons + constr_has_no_doc (HsConDecl _ nm _ _) = isNothing (lookupFM doc_map nm) - constr_has_no_doc (HsRecDecl _ nm _ _) - = isNothing (lookupFM doc_map nm) + constr_has_no_doc (HsRecDecl _ nm fields _) + = isNothing (lookupFM doc_map nm) && all field_has_no_doc fields + + field_has_no_doc (HsFieldDecl nms _ _) + = trace (show nms ++ show (map (isNothing . lookupFM doc_map) nms)) $ all isNothing (map (lookupFM doc_map) nms) ppShortConstr :: Bool -> HsConDecl -> Html diff --git a/src/HsParser.ly b/src/HsParser.ly index bae26ce6..fa0059b8 100644 --- a/src/HsParser.ly +++ b/src/HsParser.ly @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- -$Id: HsParser.ly,v 1.5 2002/04/26 11:18:57 simonmar Exp $ +$Id: HsParser.ly,v 1.6 2002/04/29 15:28:54 simonmar Exp $ (c) Simon Marlow, Sven Panne 1997-2000 @@ -16,6 +16,7 @@ ToDo: Differentiate between record updates and labeled construction. > { > module HsParser (parse) where > +> import Monad > import HsSyn > import HsParseMonad > import HsLexer @@ -442,17 +443,21 @@ Datatype declarations > | constr { [$1] } > constr :: { HsConDecl } -> : srcloc scontype maybe_doc -> { HsConDecl $1 (fst $2) (snd $2) $3 } -> | srcloc sbtype conop sbtype maybe_doc -> { HsConDecl $1 $3 [$2,$4] $5 } -> | srcloc con '{' fielddecls '}' maybe_doc -> { HsRecDecl $1 $2 $4 $6 } - -> maybe_doc :: { Maybe String } +> : srcloc maybe_docnext scontype maybe_docprev +> { HsConDecl $1 (fst $3) (snd $3) ($2 `mplus` $4) } +> | srcloc maybe_docnext sbtype conop sbtype maybe_docprev +> { HsConDecl $1 $4 [$3,$5] ($2 `mplus` $6) } +> | srcloc maybe_docnext con '{' fielddecls '}' maybe_docprev +> { HsRecDecl $1 $3 $5 ($2 `mplus` $7) } + +> maybe_docprev :: { Maybe String } > : DOCPREV { Just $1 } > | {- empty -} { Nothing } +> maybe_docnext :: { Maybe String } +> : DOCNEXT { Just $1 } +> | {- empty -} { Nothing } + > scontype :: { (HsName, [HsBangType]) } > : btype {% splitTyConApp $1 `thenP` \(c,ts) -> > returnP (toVarHsName c, @@ -481,7 +486,8 @@ Datatype declarations > | {- empty -} { [] } > fielddecl :: { HsFieldDecl } -> : vars '::' stype { HsFieldDecl (reverse $1) $3 Nothing } +> : maybe_docnext vars '::' stype maybe_docprev +> { HsFieldDecl (reverse $2) $4 ($1 `mplus` $5) } > stype :: { HsBangType } > : ctype { HsUnBangedTy $1 } diff --git a/src/Main.hs b/src/Main.hs index dd7aac64..9873d2f8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -445,7 +445,7 @@ collect name doc_so_far (decl:ds) = Nothing -> collect name (doc_so_far ++ str) ds Just n -> finishedDoc n doc_so_far (collect Nothing str ds) - HsDocCommentPrev str -> collect name (doc_so_far++str) ds + HsDocCommentPrev str -> collect name (doc_so_far ++ str) ds _other -> docsFromDecl decl ++ |