[haddock @ 2002-04-29 15:28:54 by simonmar]

Allow '-- |' style annotations on constructors and record fields.

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 ++