From bd7eb8c45d4d03af5f3bb80538e6dd00353e075b Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 15 Jul 2002 10:14:31 +0000
Subject: [haddock @ 2002-07-15 10:14:30 by simonmar] Be a bit more liberal in
 the kind of commenting styles we allow, as suggested by Malcolm Wallace. 
 Mostly this consists of allowing doc comments either side of a separator
 token.

In an export list, a section heading is now allowed before the comma,
as well as after it.  eg.

 	module M where (
	    T(..)
	  -- * a section heading
	  , f
	  -- * another section heading
	  , g
        )

In record fields, doc comments are allowed anywhere (previously a
doc-next was allowed only after the comma, and a doc-before was
allowed only before the comma).  eg.

	data R = C {
		-- | describes 'f'
		  f :: Int
		-- | describes 'g'
		, g :: Int
		}
---
 src/HaddockUtil.hs | 19 +++++++++++++++++++
 src/HsParser.ly    | 23 +++++++++++++----------
 2 files changed, 32 insertions(+), 10 deletions(-)

diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index 3e7660bb..80800559 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -10,6 +10,7 @@ module HaddockUtil (
   -- * Misc utilities
   nameOfQName, collectNames, declBinders, declMainBinder, declSubBinders, 
   splitTyConApp, restrictTo, declDoc, parseModuleHeader, freeTyCons, unbang,
+  addFieldDoc, addFieldDocs, addConDoc, addConDocs,
 
   -- * Filename utilities
   basename, dirname, splitFilename3, 
@@ -33,6 +34,7 @@ import System
 import RegexString
 import Binary
 import IOExts
+import Monad
 
 -- -----------------------------------------------------------------------------
 -- Some Utilities
@@ -95,6 +97,23 @@ freeTyCons ty = go ty []
 	go (HsTyVar v) r = r
 	go (HsTyDoc t _) r = go t r
 
+-- -----------------------------------------------------------------------------
+-- Adding documentation to record fields (used in parsing).
+
+addFieldDoc (HsFieldDecl ns ty doc1) doc2 = 
+   HsFieldDecl ns ty (doc1 `mplus` doc2)
+
+addFieldDocs [] doc = []
+addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
+
+addConDoc (HsConDecl pos nm tvs ctxt typeList doc1) doc2 = 
+   HsConDecl pos nm tvs ctxt typeList (doc1 `mplus` doc2)
+addConDoc (HsRecDecl pos nm tvs ctxt fields doc1) doc2=
+   HsRecDecl pos nm tvs ctxt fields (doc1 `mplus` doc2)
+
+addConDocs [] doc = []
+addConDocs (x:xs) doc = addConDoc x doc : xs
+
 -- ---------------------------------------------------------------------------
 -- Making abstract declarations
 
diff --git a/src/HsParser.ly b/src/HsParser.ly
index 5ec370b2..9a9435b5 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
-$Id: HsParser.ly,v 1.14 2002/06/20 12:38:07 simonmar Exp $
+$Id: HsParser.ly,v 1.15 2002/07/15 10:14:31 simonmar Exp $
 
 (c) Simon Marlow, Sven Panne 1997-2002
 
@@ -23,7 +23,7 @@ ToDo: Differentiate between record updates and labeled construction.
 > import HsParseUtils
 > import HaddockLex 	hiding (Token)
 > import HaddockParse
-> import HaddockUtil	( parseModuleHeader )
+> import HaddockUtil 	hiding (splitTyConApp)
 > import Char 		( isSpace )
 > }
 
@@ -189,15 +189,16 @@ The Export List
 
 > exportlist :: { [HsExportSpec] }
 >	:  export ',' exportlist		{ $1 : $3 }
->	|  docgroup exportlist			{ $1 : $2 }
->	|  docnamed exportlist			{ HsEDocNamed (fst $1) : $2 }
->	|  docnext  exportlist			{ HsEDoc $1 : $2 }
+>	|  export exp_doc ',' exportlist	{ $1 : $2 : $4 }
+>	|  exp_doc exportlist			{ $1 : $2 }
 > 	|  ',' exportlist			{ $2 }
 >	|  export				{ [$1] }
 > 	|  {- empty -}				{ [] }
 
-> docgroup :: { HsExportSpec }
+> exp_doc :: { HsExportSpec }
 > 	: docsection			{ case $1 of { (i,s) -> HsEGroup i s } }
+>	| docnamed			{ HsEDocNamed (fst $1) }
+>	| docnext			{ HsEDoc $1 }
 
 > export :: { HsExportSpec }
 > 	:  qvar					{ HsEVar $1 }
@@ -299,7 +300,7 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux.
 >		{ HsTypeDecl $3 (fst $2) (snd $2) $5 Nothing }
 >	| 'data' ctype srcloc constrs deriving
 >		{% checkDataHeader $2 `thenP` \(cs,c,t) ->
->		   returnP (HsDataDecl $3 cs c t (reverse $4) $5 Nothing) }
+>		   returnP (HsDataDecl $3 cs c t $4 $5 Nothing) }
 >	| 'newtype' ctype srcloc '=' constr deriving
 >		{% checkDataHeader $2 `thenP` \(cs,c,t) ->
 >		   returnP (HsNewTypeDecl $3 cs c t $5 $6 Nothing) }
@@ -458,10 +459,11 @@ Datatype declarations
 
 > constrs :: { [HsConDecl] }
 > 	  : {- empty; a GHC extension -}  { [] }
-> 	  | '=' constrs1                  { $2 }
+> 	  | maybe_docnext '=' constrs1    { addConDocs $3 $1 }
 
 > constrs1 :: { [HsConDecl] }
->	: constrs1 '|' constr		{ $3 : $1 }
+>	: constr maybe_docnext '|' maybe_docprev constrs1
+>			{ addConDoc $1 $4 : addConDocs $5 $2 }
 >	| constr			{ [$1] }
 
 > constr :: { HsConDecl }
@@ -504,7 +506,8 @@ Datatype declarations
 >	| '!' atype			{ HsBangedTy   $2 }
 
 > fielddecls :: { [HsFieldDecl] }
->	: fielddecl ',' fielddecls	{ $1 : $3 }
+>	: fielddecl maybe_docnext ',' maybe_docprev fielddecls
+>		{ addFieldDoc $1 $4 : addFieldDocs $5 $2 }
 >	| ',' fielddecls		{ $2 }
 >	| fielddecl			{ [$1] }
 >	| {- empty -}			{ [] }
-- 
cgit v1.2.3