[haddock @ 2002-05-15 13:03:01 by simonmar]

Reworking of the internals to support documenting function arguments
(the Most Wanted new feature by the punters).

The old method of keeping parsed documentation in a Name -> Doc
mapping wasn't going to cut it for anntations on type components,
where there's no name to attach the documentation to, so I've moved to
storing all the documentation in the abstract syntax.  Previously some
of the documentation was left in the abstract syntax by the parser,
but was later extracted into the mapping.

In order to avoid having to parameterise the abstract syntax over the
type of documentation stored in it, we have to parse the documentation
at the same time as we parse the Haskell source (well, I suppose we
could store 'Either String Doc' in the HsSyn, but that's clunky).  One
upshot is that documentation is now parsed eagerly, and documentation
parse errors are fatal (but have better line numbers in the error
message).

The new story simplifies matters for the code that processes the
source modules, because we don't have to maintain the extra Name->Doc
mapping, and it should improve efficiency a little too.

New features:

  - Function arguments and return values can now have doc annotations.

  - If you refer to a qualified name in a doc string, eg. 'IO.putStr',
    then Haddock will emit a hyperlink even if the identifier is not
    in scope, so you don't have to make sure everything referred to
    from the documentation is imported.

  - several bugs & minor infelicities fixed.

10 files changed, 678 insertions, 664 deletions

diff --git a/src/HaddockDB.hs b/src/HaddockDB.hs
index a2a4a8e7..ebd0ccb2 100644
--- a/src/HaddockDB.hs
+++ b/src/HaddockDB.hs
@@ -6,7 +6,7 @@
 
 module HaddockDB (ppDocBook) where
 
-import HaddockTypes hiding (Doc)
+import HaddockTypes
 import HaddockUtil
 
 import HsSyn
@@ -16,6 +16,8 @@ import FiniteMap
 -----------------------------------------------------------------------------
 -- Printing the results in DocBook format
 
+ppDocBook = error "not working"
+{-
 ppDocBook :: FilePath -> [(Module, Interface)] -> String
 ppDocBook odir mods = render (ppIfaces mods)
 
@@ -55,22 +57,22 @@ ppIfaces mods
 	$$ text "</varlistentry>"
      do_export _ _ = empty
 
-     do_decl (HsTypeSig _ [nm] ty) 
+     do_decl (HsTypeSig _ [nm] ty _) 
 	=  ppHsName nm <> text " :: " <> ppHsType ty
-     do_decl (HsTypeDecl _ nm args ty)
+     do_decl (HsTypeDecl _ nm args ty _)
 	=  hsep ([text "type", ppHsName nm ]
 		 ++ map ppHsName args 
 		 ++ [equals, ppHsType ty])
-     do_decl (HsNewTypeDecl loc ctx nm args con drv)
+     do_decl (HsNewTypeDecl loc ctx nm args con drv _)
 	= hsep ([text "data", ppHsName nm] -- data, not newtype
 		++ map ppHsName args
 		) <+> equals <+> ppHsConstr con -- ToDo: derivings
-     do_decl (HsDataDecl loc ctx nm args cons drv)
+     do_decl (HsDataDecl loc ctx nm args cons drv _)
 	= hsep ([text "data", {-ToDo: context-}ppHsName nm]
 	        ++ map ppHsName args)
             <+> vcat (zipWith (<+>) (equals : repeat (char '|'))
                                     (map ppHsConstr cons))
-     do_decl (HsClassDecl loc ty fds decl)
+     do_decl (HsClassDecl loc ty fds decl _)
 	= hsep [text "class", ppHsType ty]
      do_decl decl
 	= empty
@@ -158,3 +160,4 @@ ubxParenList :: [Doc] -> Doc
 ubxParenList = ubxparens . fsep . punctuate comma
 
 ubxparens p = text "(#" <> p <> text "#)"
+-}
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 2bd6b102..01d01d69 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -12,12 +12,13 @@ import HaddockTypes
 import HaddockUtil
 import HsSyn
 
+import IO
 import Maybe	( fromJust, isNothing, isJust )
 import FiniteMap
 import List 	( sortBy )
 import Char	( toUpper, toLower )
 import Monad	( when )
---import IOExts
+import IOExts
 
 import Html
 import qualified Html
@@ -79,8 +80,7 @@ src_button source_url mod file
   | Just u <- source_url = 
 	let src_url = if (last u == '/') then u ++ file else u ++ '/':file
 	in
-	(tda [theclass "topbut", nowrap] <<
-  	   anchor ! [href src_url] << toHtml "Source code")
+	topButBox (anchor ! [href src_url] << toHtml "Source code")
   | otherwise =
 	Html.emptyTable
   
@@ -88,16 +88,15 @@ src_button source_url mod file
 parent_button mod = 
   case span (/= '.') (reverse mod) of
    (m, '.':rest) -> 
-       (tda [theclass "topbut", nowrap] <<
+       topButBox (
   	 anchor ! [href (moduleHtmlFile (reverse rest))] << toHtml "Parent")
    _ -> 
 	Html.emptyTable
 
-contentsButton = tda [theclass "topbut", nowrap] <<
-  	 	    anchor ! [href contentsHtmlFile] << toHtml "Contents"
+contentsButton = topButBox (anchor ! [href contentsHtmlFile] << 
+				toHtml "Contents")
 
-indexButton = tda [theclass "topbut", nowrap] <<
-  	 	    anchor ! [href indexHtmlFile] << toHtml "Index"
+indexButton = topButBox (anchor ! [href indexHtmlFile] << toHtml "Index")
 
 simpleHeader title = 
   (tda [theclass "topbar"] << 
@@ -319,10 +318,8 @@ ifaceToHtml mod iface
 	(contents </> description </> synopsis </> maybe_hr </> body)
   where 
 	exports = numberSectionHeadings (iface_exports iface)
-	doc_map = iface_name_docs iface
 
-	has_doc (ExportDecl d)
-	 | Just x <- declMainBinder d = isJust (lookupFM doc_map x)
+	has_doc (ExportDecl d) = isJust (declDoc d)
 	has_doc (ExportModule _) = False
 	has_doc _ = True
 
@@ -344,14 +341,14 @@ ifaceToHtml mod iface
 	  = (tda [theclass "section1"] << toHtml "Synopsis") </>
             (tda [width "100%", theclass "synopsis"] << 
   	      table ! [width "100%", cellpadding 0, cellspacing 8, border 0] << 
-  	        aboves (map (processExport doc_map True)  exports))
+  	        aboves (map (processExport True)  exports))
 
 	maybe_hr
 	     | not (no_doc_at_all),  ExportGroup 1 _ _ <- head exports
 		 = td << hr
 	     | otherwise  = Html.emptyTable
 
-	body = aboves (map (processExport doc_map False) exports)
+	body = aboves (map (processExport False) exports)
 
 ppModuleContents :: [ExportItem] -> HtmlTable
 ppModuleContents exports
@@ -386,16 +383,16 @@ numberSectionHeadings exports = go 1 exports
 	go n (other:es)
 	  = other : go n es
 
-processExport :: FiniteMap HsName Doc -> Bool -> ExportItem -> HtmlTable
-processExport doc_map summary (ExportGroup lev id doc)
+processExport :: Bool -> ExportItem -> HtmlTable
+processExport summary (ExportGroup lev id doc)
   | summary   = Html.emptyTable
   | otherwise = ppDocGroup lev (anchor ! [name id] << markup htmlMarkup doc)
-processExport doc_map summary (ExportDecl decl)
-  = doDecl doc_map summary decl
-processExport doc_map summary (ExportDoc doc)
+processExport summary (ExportDecl decl)
+  = doDecl summary decl
+processExport summary (ExportDoc doc)
   | summary = Html.emptyTable
   | otherwise = docBox (markup htmlMarkup doc)
-processExport doc_map summary (ExportModule (Module mod))
+processExport summary (ExportModule (Module mod))
   = declBox (toHtml "module" <+> ppHsModule mod)
 
 ppDocGroup lev doc
@@ -415,43 +412,36 @@ declWithDoc False (Just doc) html_decl =
 	    vanillaTable << 
 		(declBox html_decl </> docBox (markup htmlMarkup doc))
 
-doDecl :: FiniteMap HsName Doc -> Bool -> HsDecl -> HtmlTable
-doDecl doc_map summary decl = do_decl decl
+doDecl :: Bool -> HsDecl -> HtmlTable
+doDecl summary decl = do_decl decl
   where
-     doc | Just n <- declMainBinder decl  =  lookupFM doc_map n
-	 | otherwise = Nothing
+     do_decl (HsTypeSig _ [nm] ty doc) 
+	= ppFunSig summary nm ty doc
 
-     do_decl (HsTypeSig _ [nm] ty) = 
-	declWithDoc summary doc (ppTypeSig summary nm ty)
-
-     do_decl (HsTypeSig _ nms ty) 
-	= declWithDoc summary doc (
-	    vanillaTable << aboves (map do_one nms))
-	where do_one nm = declBox (ppTypeSig summary nm ty)
-
-     do_decl (HsForeignImport _ _ _ _ n ty)
+     do_decl (HsForeignImport _ _ _ _ n ty doc)
 	= declWithDoc summary doc (ppTypeSig summary n ty)
 
-     do_decl (HsTypeDecl _ nm args ty)
+     do_decl (HsTypeDecl _ nm args ty doc)
 	= declWithDoc summary doc (
 	      hsep ([keyword "type", ppHsBinder summary nm]
 		 ++ map ppHsName args) <+> equals <+> ppHsType ty)
 
-     do_decl (HsNewTypeDecl loc ctx nm args con drv)
-	= ppHsDataDecl doc_map summary True{-is newtype-}
-		(HsDataDecl loc ctx nm args [con] drv)
+     do_decl (HsNewTypeDecl loc ctx nm args con drv doc)
+	= ppHsDataDecl summary True{-is newtype-}
+		(HsDataDecl loc ctx nm args [con] drv doc)
 	  -- print it as a single-constructor datatype
 
-     do_decl decl@(HsDataDecl loc ctx nm args cons drv) 
-	= ppHsDataDecl doc_map summary False{-not newtype-} decl
+     do_decl decl@(HsDataDecl loc ctx nm args cons drv doc)
+	= ppHsDataDecl summary False{-not newtype-} decl
 
-     do_decl decl@(HsClassDecl _ _ _ _)
-	= ppHsClassDecl doc_map summary decl
+     do_decl decl@(HsClassDecl _ _ _ _ _)
+	= ppHsClassDecl summary decl
 
-     do_decl (HsDocGroup lev str) 
-	= if summary then Html.emptyTable else ppDocGroup lev str
+     do_decl (HsDocGroup loc lev str)
+	= if summary then Html.emptyTable 
+		     else ppDocGroup lev (markup htmlMarkup str)
 
-     do_decl _ = error (show decl)
+     do_decl _ = error ("do_decl: " ++ show decl)
 
 
 ppTypeSig summary nm ty = ppHsBinder summary nm <+> toHtml "::" <+> ppHsType ty
@@ -469,11 +459,11 @@ keepDecl _ = False
 
 ppShortDataDecl :: Bool -> Bool -> HsDecl -> Html
 ppShortDataDecl summary is_newty 
-	(HsDataDecl loc ctx nm args [con] drv) =
+	(HsDataDecl loc ctx nm args [con] drv _doc) =
    ppHsDataHeader summary is_newty nm args      
      <+> equals <+> ppShortConstr summary con
 ppShortDataDecl summary is_newty
-	(HsDataDecl loc ctx nm args cons drv) = 
+	(HsDataDecl loc ctx nm args cons drv _doc) = 
    vanillaTable << (
      aboves (
 	(declBox (ppHsDataHeader summary is_newty nm args) :
@@ -486,16 +476,14 @@ ppShortDataDecl summary is_newty
 
 -- First, the abstract case:
 
-ppHsDataDecl doc_map summary is_newty (HsDataDecl loc ctx nm args [] drv) = 
-   declWithDoc summary (lookupFM doc_map nm)
-     (ppHsDataHeader summary is_newty nm args)
+ppHsDataDecl summary is_newty (HsDataDecl loc ctx nm args [] drv doc) = 
+   declWithDoc summary doc (ppHsDataHeader summary is_newty nm args)
 
 -- The rest of the cases:
 
-ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv)
+ppHsDataDecl summary is_newty decl@(HsDataDecl loc ctx nm args cons drv doc)
   | summary || no_constr_docs
-	= declWithDoc summary (lookupFM doc_map nm)
-     		(ppShortDataDecl summary is_newty decl)
+	= declWithDoc summary doc (ppShortDataDecl summary is_newty decl)
 
   | otherwise
         = td << vanillaTable << (header </> datadoc </> constrs)
@@ -516,20 +504,17 @@ ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv)
 			aboves (constr_hdr : map do_constr cons)
            	  )
 
-	do_constr con = ppHsFullConstr doc_map con
-
-	Just c = declMainBinder decl
-	doc = lookupFM doc_map c
+	do_constr con = ppHsFullConstr con
 
 	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 _ _ fields _)
-	   = isNothing (lookupFM doc_map nm) && all field_has_no_doc fields
+	constr_has_no_doc (HsConDecl _ nm _ _ _ doc) 
+	   = isNothing doc
+	constr_has_no_doc (HsRecDecl _ nm _ _ fields doc)
+	   = isNothing doc && all field_has_no_doc fields
 
- 	field_has_no_doc (HsFieldDecl nms _ _)
-	   = all isNothing (map (lookupFM doc_map) nms)
+ 	field_has_no_doc (HsFieldDecl nms _ doc)
+	   = isNothing doc
 
 
 ppShortConstr :: Bool -> HsConDecl -> Html
@@ -548,14 +533,12 @@ ppHsConstrHdr tvs ctxt
    +++
    (if null ctxt then noHtml else ppHsContext ctxt <+> toHtml "=> ")
 
-ppHsFullConstr doc_map (HsConDecl pos nm tvs ctxt typeList _maybe_doc) = 
+ppHsFullConstr (HsConDecl pos nm tvs ctxt typeList doc) = 
      declWithDoc False doc (
 	hsep ((ppHsConstrHdr tvs ctxt +++ 
 		ppHsBinder False nm) : map ppHsBangType typeList)
       )
-   where
-     doc = lookupFM doc_map nm
-ppHsFullConstr doc_map (HsRecDecl pos nm tvs ctxt fields maybe_doc) =
+ppHsFullConstr (HsRecDecl pos nm tvs ctxt fields doc) =
    td << vanillaTable << (
      case doc of
        Nothing  -> aboves [hdr, fields_html]
@@ -571,10 +554,8 @@ ppHsFullConstr doc_map (HsRecDecl pos nm tvs ctxt fields maybe_doc) =
 	fields_html = 
 	   td << 
 	      table ! [width "100%", cellpadding 0, cellspacing 8] << (
-		   aboves (map (ppFullField doc_map)
-				   (concat (map expandField fields)))
+		   aboves (map ppFullField (concat (map expandField fields)))
 		)
-        doc = lookupFM doc_map nm
 
 
 ppShortField summary (HsFieldDecl ns ty _doc) 
@@ -583,11 +564,11 @@ ppShortField summary (HsFieldDecl ns ty _doc)
 	    <+> toHtml "::" <+> ppHsBangType ty
    )
 
-ppFullField doc_map (HsFieldDecl [n] ty _doc) 
-  = declWithDoc False (lookupFM doc_map n) (
+ppFullField (HsFieldDecl [n] ty doc) 
+  = declWithDoc False doc (
 	ppHsBinder False n <+> toHtml "::" <+> ppHsBangType ty
     )
-ppFullField _ _ = error "ppFullField"
+ppFullField _ = error "ppFullField"
 
 expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]
 
@@ -610,16 +591,16 @@ ppClassHdr ty fds =
 	fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+>
 			       hsep (map ppHsName vars2)
 
-ppShortClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls) = 
+ppShortClassDecl summary decl@(HsClassDecl loc ty fds decls doc) = 
   if null decls
     then declBox hdr
     else td << (
 	  vanillaTable << (
            declBox (hdr <+> keyword "where")
 	    </> 
-           tda [theclass "cbody"] << (
+           tda [theclass "body"] << (
 	    vanillaTable << (
-	       aboves (map (doDecl doc_map summary) (filter keepDecl decls))
+	       aboves (map (doDecl summary) (filter keepDecl decls))
            ))
          ))
    where
@@ -627,15 +608,14 @@ ppShortClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls) =
 	hdr | not summary = linkTarget c +++ ppClassHdr ty fds
 	    | otherwise   = ppClassHdr ty fds
 
-ppHsClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls)
+ppHsClassDecl summary decl@(HsClassDecl loc ty fds decls doc)
   |  summary || (isNothing doc && all decl_has_no_doc kept_decls)
-	= ppShortClassDecl doc_map summary decl
+	= ppShortClassDecl summary decl
 
   | otherwise
         = td << vanillaTable << (header </> classdoc </> body)
 
    where 
-	doc    = lookupFM doc_map c
 	Just c = declMainBinder decl
 
 	header
@@ -654,14 +634,56 @@ ppHsClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls)
 	   | otherwise  = 
 		td << table ! [width "100%", cellpadding 0, cellspacing 8] << (
 			meth_hdr </>
-	       		aboves (map (doDecl doc_map False) kept_decls)
+	       		aboves (map (doDecl False) kept_decls)
            	      )
 
 	kept_decls = filter keepDecl decls
 
-        decl_has_no_doc decl
-	 | Just b <- declMainBinder decl = isNothing (lookupFM doc_map b)
-	 | otherwise = True
+        decl_has_no_doc decl = isNothing (declDoc decl)
+
+-- -----------------------------------------------------------------------------
+-- Type signatures
+
+ppFunSig summary nm ty doc
+  | summary || no_arg_docs ty = 
+      declWithDoc summary doc (ppTypeSig summary nm ty)
+
+  | otherwise   = 
+      td << vanillaTable << (
+	declBox (ppHsBinder False nm) </>
+	(tda [theclass "body"] << narrowTable <<  (
+	   (if (isJust doc) 
+		then ndocBox (markup htmlMarkup (fromJust doc))
+		else Html.emptyTable)  </>
+	   do_args True ty
+	 ))
+     )
+  where
+	no_arg_docs (HsForAllType _ _ ty) = no_arg_docs ty
+	no_arg_docs (HsTyFun (HsTyDoc _ _) _) = False
+	no_arg_docs (HsTyFun _ r) = no_arg_docs r
+	no_arg_docs (HsTyDoc _ _) = False
+ 	no_arg_docs _ = True
+
+	do_args :: Bool -> HsType -> HtmlTable
+	do_args first (HsForAllType maybe_tvs ctxt ty)
+	  = declBox (leader first <+> ppHsForAll maybe_tvs ctxt) </> 
+	    do_args False ty
+	do_args first (HsTyFun (HsTyDoc ty doc) r)
+	  = (declBox (leader first <+> ppHsBType ty) <-> 
+	     rdocBox (markup htmlMarkup doc)) </>
+	    do_args False r
+	do_args first (HsTyFun ty r)
+	  = (declBox (leader first <+> ppHsBType ty) <->
+	     rdocBox noHtml) </>
+	    do_args False r
+	do_args first (HsTyDoc ty doc)
+	  = (declBox (leader first <+> ppHsBType ty) <-> 
+	     rdocBox (markup htmlMarkup doc))
+	do_args first _ = declBox (leader first <+> ppHsBType ty)
+
+	leader True  = toHtml "::"
+	leader False = toHtml "->"
 
 -- -----------------------------------------------------------------------------
 -- Types and contexts
@@ -671,15 +693,19 @@ ppHsContext []      = empty
 ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> 
 					 hsep (map ppHsAType b)) context)
 
+ppHsForAll Nothing context = 
+  hsep [ ppHsContext context, toHtml "=>" ]
+ppHsForAll (Just tvs) [] = 
+  hsep (keyword "forall" : map ppHsName tvs ++ [toHtml "."])
+ppHsForAll (Just tvs) context =
+  hsep (keyword "forall" : map ppHsName tvs ++ 
+	  [toHtml ".", ppHsContext context, toHtml "=>"])
+
 ppHsType :: HsType -> Html
-ppHsType (HsForAllType Nothing context htype) =
-     hsep [ ppHsContext context, toHtml "=>", ppHsType htype]
-ppHsType (HsForAllType (Just tvs) [] htype) =
-     hsep (keyword "forall" : map ppHsName tvs ++ toHtml "." : [ppHsType htype])
-ppHsType (HsForAllType (Just tvs) context htype) =
-     hsep (keyword "forall" : map ppHsName tvs ++ toHtml "." : 
-	   ppHsContext context : toHtml "=>" : [ppHsType htype])
+ppHsType (HsForAllType maybe_tvs context htype) =
+  ppHsForAll maybe_tvs context <+> ppHsType htype
 ppHsType (HsTyFun a b) = hsep [ppHsBType a, toHtml "->", ppHsType b]
+ppHsType (HsTyDoc ty doc) = ppHsBType ty
 ppHsType t = ppHsBType t
 
 ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
@@ -751,7 +777,7 @@ htmlMarkup = Markup {
   markupEmpty	      = toHtml "",
   markupString        = toHtml,
   markupAppend        = (+++),
-  markupIdentifier    = ppHsQName,
+  markupIdentifier    = ppHsQName . head,
   markupModule        = ppHsModule,
   markupEmphasis      = emphasize . toHtml,
   markupMonospaced    = tt . toHtml,
@@ -800,10 +826,26 @@ ubxparens p = toHtml "(#" +++ p +++ toHtml "#)"
 
 text   = strAttr "TEXT"
 
+-- a box for displaying code
 declBox :: Html -> HtmlTable
 declBox html = tda [theclass "decl"] << html
 
+-- a box for displaying documentation, 
+-- indented and with a little padding at the top
 docBox :: Html -> HtmlTable
 docBox html = tda [theclass "doc"] << html
 
+-- a box for displaying documentation, not indented.
+ndocBox :: Html -> HtmlTable
+ndocBox html = tda [theclass "ndoc"] << html
+
+-- a box for displaying documentation, padded on the left a little
+rdocBox :: Html -> HtmlTable
+rdocBox html = tda [theclass "rdoc"] << html
+
+-- a box for the buttons at the top of the page
+topButBox html = tda [theclass "topbut"] << html
+
 vanillaTable = table ! [width "100%", cellpadding 0, cellspacing 0, border 0]
+
+narrowTable = table ! [cellpadding 0, cellspacing 0, border 0]
diff --git a/src/HaddockParse.y b/src/HaddockParse.y
index 789f0d94..37ceff4f 100644
--- a/src/HaddockParse.y
+++ b/src/HaddockParse.y
@@ -2,7 +2,9 @@
 module HaddockParse (parseParas, parseString) where
 
 import HaddockLex
-import HaddockTypes
+import HsSyn
+import HsLexer hiding (Token)
+import HsParseMonad
 }
 
 %tokentype { Token }
@@ -26,48 +28,48 @@ import HaddockTypes
 
 %%
 
-doc	:: { ParsedDoc }
+doc	:: { Doc }
 	: apara PARA doc	{ docAppend $1 $3 }
 	| PARA doc 		{ $2 }
 	| apara			{ $1 }
 	| {- empty -}		{ DocEmpty }
 
-apara	:: { ParsedDoc }
+apara	:: { Doc }
 	: ulpara		{ DocUnorderedList [$1] }
 	| olpara		{ DocOrderedList [$1] }
 	| para			{ $1 }
 
-ulpara  :: { ParsedDoc }
+ulpara  :: { Doc }
 	: '*' para		{ $2 }
 
-olpara  :: { ParsedDoc } 
+olpara  :: { Doc } 
 	: '(n)' para		{ $2 }
 
-para    :: { ParsedDoc }
+para    :: { Doc }
 	: seq			{ docParagraph $1 }
 	| codepara		{ DocCodeBlock $1 }
 
-codepara :: { ParsedDoc }
+codepara :: { Doc }
 	: '>' seq codepara	{ docAppend $2 $3 }
 	| '>' seq		{ $2 }
 
-seq	:: { ParsedDoc }
+seq	:: { Doc }
 	: elem seq		{ docAppend $1 $2 }
 	| elem			{ $1 }
 
-elem	:: { ParsedDoc }
+elem	:: { Doc }
 	: elem1			{ $1 }
 	| '@' seq1 '@'		{ DocMonospaced $2 }
 
-seq1	:: { ParsedDoc }
+seq1	:: { Doc }
 	: elem1 seq1		{ docAppend $1 $2 }
 	| elem1			{ $1 }
 
-elem1	:: { ParsedDoc }
+elem1	:: { Doc }
 	: STRING		{ DocString $1 }
 	| '/' STRING '/'	{ DocEmphasis (DocString $2) }
 	| URL			{ DocURL $1 }
-	| squo STRING squo	{ DocIdentifier $2 }
+	| squo STRING squo	{ DocIdentifier (strToHsQNames $2) }
 	| DQUO STRING DQUO	{ DocModule $2 }
 
 squo :: { () }
@@ -86,4 +88,29 @@ instance Monad (Either String) where
 	Left  l >>= _ = Left l
 	Right r >>= k = k r
 	fail msg      = Left msg
+
+strToHsQNames :: String -> [ HsQName ]
+strToHsQNames str
+ = case lexer (\t -> returnP t) str (SrcLoc 1 1) 1 1 [] of
+	Ok _ (VarId str)
+		-> [ UnQual (HsVarName (HsIdent str)) ]
+        Ok _ (QVarId (mod,str))
+		-> [ Qual (Module mod) (HsVarName (HsIdent str)) ]
+	Ok _ (ConId str)
+		-> [ UnQual (HsTyClsName (HsIdent str)),
+		     UnQual (HsVarName (HsIdent str)) ]
+        Ok _ (QConId (mod,str))
+		-> [ Qual (Module mod) (HsTyClsName (HsIdent str)),
+		     Qual (Module mod) (HsVarName (HsIdent str)) ]
+        Ok _ (VarSym str)
+		-> [ UnQual (HsVarName (HsSymbol str)) ]
+        Ok _ (ConSym str)
+		-> [ UnQual (HsTyClsName (HsSymbol str)),
+		     UnQual (HsVarName (HsSymbol str)) ]
+        Ok _ (QVarSym (mod,str))
+		-> [ Qual (Module mod) (HsVarName (HsSymbol str)) ]
+        Ok _ (QConSym (mod,str))
+		-> [ Qual (Module mod) (HsTyClsName (HsSymbol str)),
+		     Qual (Module mod) (HsVarName (HsSymbol str)) ]
+	other -> []
 }
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index 59d71bd5..02085e2e 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -10,7 +10,7 @@ module HaddockRename (
 	renameExportList, 
 	renameDecl,
 	renameExportItems,
-	renameDoc, resolveDoc,
+	renameDoc,
   ) where
 
 import HaddockTypes
@@ -64,37 +64,47 @@ renameExportList spec = mapM renameExport spec
     renameExport (HsEVar x) = lookupRn HsEVar x
     renameExport (HsEAbs x) = lookupRn HsEAbs x
     renameExport (HsEThingAll x) = lookupRn HsEThingAll x
-    renameExport (HsEThingWith x cs)
-	= do cs' <- mapM (lookupRn id) cs
-	     lookupRn (\x' -> HsEThingWith x' cs') x
+    renameExport (HsEThingWith x cs) = do
+	cs' <- mapM (lookupRn id) cs
+	lookupRn (\x' -> HsEThingWith x' cs') x
     renameExport (HsEModuleContents m) = return (HsEModuleContents m)
-    renameExport (HsEGroup lev str) = return (HsEGroup lev str)
-    renameExport (HsEDoc str) = return (HsEDoc str)
+    renameExport (HsEGroup lev doc) = do
+	doc <- renameDoc doc
+	return (HsEGroup lev doc)
+    renameExport (HsEDoc doc) = do
+	doc <- renameDoc doc
+	return (HsEDoc doc)
     renameExport (HsEDocNamed str) = return (HsEDocNamed str)
 
 
 renameDecl :: HsDecl -> RnM HsDecl
 renameDecl decl
   = case decl of
-	HsTypeDecl loc t args ty -> do
+	HsTypeDecl loc t args ty doc -> do
 	    ty <- renameType ty
-	    return (HsTypeDecl loc t args ty)
-	HsDataDecl loc ctx t args cons drv -> do
+	    doc <- renameMaybeDoc doc
+	    return (HsTypeDecl loc t args ty doc)
+	HsDataDecl loc ctx t args cons drv doc -> do
 	    cons <- mapM renameConDecl cons
-	    return (HsDataDecl loc ctx t args cons drv)
-        HsNewTypeDecl loc ctx t args con drv -> do
+	    doc <- renameMaybeDoc doc
+	    return (HsDataDecl loc ctx t args cons drv doc)
+        HsNewTypeDecl loc ctx t args con drv doc -> do
 	    con <- renameConDecl con
-	    return (HsNewTypeDecl loc ctx t args con drv)
-        HsClassDecl loc qt fds decls -> do
+	    doc <- renameMaybeDoc doc
+	    return (HsNewTypeDecl loc ctx t args con drv doc)
+        HsClassDecl loc qt fds decls doc -> do
 	    qt <- renameClassHead qt
 	    decls <- mapM renameDecl decls
-	    return (HsClassDecl loc qt fds decls)
-	HsTypeSig loc fs qt -> do
+	    doc <- renameMaybeDoc doc
+	    return (HsClassDecl loc qt fds decls doc)
+	HsTypeSig loc fs qt doc -> do
 	    qt <- renameType qt
-	    return (HsTypeSig loc fs qt)
-	HsForeignImport loc cc safe ent n ty -> do
+	    doc <- renameMaybeDoc doc
+	    return (HsTypeSig loc fs qt doc)
+	HsForeignImport loc cc safe ent n ty doc -> do
 	    ty <- renameType ty
-	    return (HsForeignImport loc cc safe ent n ty)
+	    doc <- renameMaybeDoc doc
+	    return (HsForeignImport loc cc safe ent n ty doc)
 	_ -> 
 	    return decl
 
@@ -104,15 +114,18 @@ renameClassHead (HsForAllType tvs ctx ty) = do
 renameClassHead ty = do
   return ty
 
-renameConDecl (HsConDecl loc nm tvs ctxt tys maybe_doc) = do
+renameConDecl (HsConDecl loc nm tvs ctxt tys doc) = do
   tys <- mapM renameBangTy tys
-  return (HsConDecl loc nm tvs ctxt tys maybe_doc)
-renameConDecl (HsRecDecl loc nm tvs ctxt fields maybe_doc) = do
+  doc <- renameMaybeDoc doc
+  return (HsConDecl loc nm tvs ctxt tys doc)
+renameConDecl (HsRecDecl loc nm tvs ctxt fields doc) = do
   fields <- mapM renameField fields
-  return (HsRecDecl loc nm tvs ctxt fields maybe_doc)
+  doc <- renameMaybeDoc doc
+  return (HsRecDecl loc nm tvs ctxt fields doc)
 
 renameField (HsFieldDecl ns ty doc) = do 
   ty <- renameBangTy ty
+  doc <- renameMaybeDoc doc
   return (HsFieldDecl ns ty doc)
 
 renameBangTy (HsBangedTy ty)   = HsBangedTy   `liftM` renameType ty
@@ -141,19 +154,23 @@ renameType (HsTyVar nm) =
   return (HsTyVar nm)
 renameType (HsTyCon nm) =
   lookupRn HsTyCon nm
+renameType (HsTyDoc ty doc) = do
+  ty <- renameType ty
+  doc <- renameDoc doc
+  return (HsTyDoc ty doc)
 
 -- -----------------------------------------------------------------------------
 -- Renaming documentation
 
 -- Renaming documentation is done by "marking it up" from ordinary Doc
 -- into (Rn Doc), which can then be renamed with runRn.
-markupRename :: DocMarkup HsQName (RnM Doc)
+markupRename :: DocMarkup [HsQName] (RnM Doc)
 markupRename = Markup {
   markupEmpty         = return DocEmpty,
   markupString        = return . DocString,
   markupParagraph     = liftM DocParagraph,
   markupAppend        = liftM2 DocAppend,
-  markupIdentifier    = lookupRn DocIdentifier,
+  markupIdentifier    = lookupForDoc,
   markupModule        = return . DocModule,
   markupEmphasis      = liftM DocEmphasis,
   markupMonospaced    = liftM DocMonospaced,
@@ -165,31 +182,32 @@ markupRename = Markup {
 
 renameDoc = markup markupRename
 
-markupResolveDoc :: DocMarkup String (GenRnM String Doc)
-markupResolveDoc = Markup {
-  markupEmpty         = return DocEmpty,
-  markupString        = return . DocString,
-  markupParagraph     = liftM DocParagraph,
-  markupAppend        = liftM2 DocAppend,
-  markupIdentifier    = lookupIdString,
-  markupModule        = return . DocModule,
-  markupEmphasis      = liftM DocEmphasis,
-  markupMonospaced    = liftM DocMonospaced,
-  markupUnorderedList = liftM DocUnorderedList . sequence,
-  markupOrderedList   = liftM DocOrderedList . sequence,
-  markupCodeBlock     = liftM DocCodeBlock,
-  markupURL	      = return . DocURL
-  }
-
-resolveDoc = markup markupResolveDoc
+renameMaybeDoc Nothing = return Nothing
+renameMaybeDoc (Just doc) = Just `liftM` renameDoc doc
 
-lookupIdString :: String -> GenRnM String Doc
-lookupIdString str = do
-  fn <- getLookupRn
-  case fn str of
-	Nothing -> return (DocString str)
-	Just n  -> return (DocIdentifier n)
+-- ---------------------------------------------------------------------------
+-- Looking up names in documentation
 
+lookupForDoc :: [HsQName] -> RnM Doc
+lookupForDoc qns = do
+  lkp <- getLookupRn
+  case [ n | Just n <- map lkp qns ] of
+	ns@(_:_) -> return (DocIdentifier ns)
+	[] -> -- if we were given a qualified name, but there's nothing
+	      -- matching that name in scope, then just assume its existence
+	      -- (this means you can use qualified names in doc strings wihout
+	      -- worrying about whether the entity is in scope).
+	      let quals = filter isQualified qns in
+	      if (not (null quals)) then
+		return (DocIdentifier quals)
+	      else
+		-- no qualified names: just replace this name with its
+		-- string representation.
+		return (DocString (show (head qns)))
+ where
+   isQualified (Qual m i) = True
+   isQualified _ = False
+   
 -- -----------------------------------------------------------------------------
 
 renameExportItems items = mapM rn items
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index 5af102d4..9c957dd5 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -6,20 +6,14 @@
 
 module HaddockTypes (
   -- * Module interfaces
-  NameEnv, Interface(..), ModuleInfo(..), ExportItem(..), ModuleMap,
+  NameEnv, Interface(..), ExportItem(..), ModuleMap,
   DocOption(..),
 
-  -- * User documentation strings
-  DocString, GenDoc(..), Doc, ParsedDoc, DocMarkup(..),
-  markup, mapIdent, 
-  docAppend, docParagraph,
  ) where
 
 import FiniteMap
 import HsSyn
 
-import Char (isSpace)
-
 -- ---------------------------------------------------------------------------
 -- Describing a module interface
 
@@ -45,11 +39,6 @@ data Interface
 		-- restricted to only those bits exported.
 		-- the map key is the "main name" of the decl.
 
-	iface_name_docs :: FiniteMap HsName Doc,
-		-- ^ maps names exported by this module to documentation.
-		-- Includes not just "main names" but names of constructors,
-		-- record fields, etc.
-
 	iface_info :: Maybe ModuleInfo,
 		-- ^ information from the module header
 
@@ -60,11 +49,6 @@ data Interface
 		-- ^ module-wide doc options
   }
 
-data ModuleInfo = ModuleInfo
-	{ portability :: String,
-	  stability   :: String,
-	  maintainer  :: String }
-
 data DocOption = OptHide | OptPrune | OptIgnoreExports 
   deriving (Eq)
 
@@ -72,7 +56,7 @@ type DocString = String
 
 data ExportItem 
   = ExportDecl
-	HsDecl		-- a declaration
+	HsDecl		-- a declaration (with doc annotations)
 
   | ExportGroup		-- a section heading
 	Int		-- section level (1, 2, 3, ... )
@@ -87,104 +71,3 @@ data ExportItem
 
 type ModuleMap = FiniteMap Module Interface
 
--- -----------------------------------------------------------------------------
--- Doc strings and formatting
-
-data GenDoc id
-  = DocEmpty 
-  | DocAppend (GenDoc id) (GenDoc id)
-  | DocString String
-  | DocParagraph (GenDoc id)
-  | DocIdentifier id
-  | DocModule String
-  | DocEmphasis (GenDoc id)
-  | DocMonospaced (GenDoc id)
-  | DocUnorderedList [GenDoc id]
-  | DocOrderedList [GenDoc id]
-  | DocCodeBlock (GenDoc id)
-  | DocURL String
-
-type Doc = GenDoc HsQName
-type ParsedDoc = GenDoc String
-
--- | DocMarkup is a set of instructions for marking up documentation.
--- In fact, it's really just a mapping from 'GenDoc' to some other
--- type [a], where [a] is usually the type of the output (HTML, say).
-
-data DocMarkup id a = Markup {
-  markupEmpty         :: a,
-  markupString        :: String -> a,
-  markupParagraph     :: a -> a,
-  markupAppend        :: a -> a -> a,
-  markupIdentifier    :: id -> a,
-  markupModule        :: String -> a,
-  markupEmphasis      :: a -> a,
-  markupMonospaced    :: a -> a,
-  markupUnorderedList :: [a] -> a,
-  markupOrderedList   :: [a] -> a,
-  markupCodeBlock     :: a -> a,
-  markupURL	      :: String -> a
-  }
-
-markup :: DocMarkup id a -> GenDoc id -> a
-markup m DocEmpty		= markupEmpty m
-markup m (DocAppend d1 d2)	= markupAppend m (markup m d1) (markup m d2)
-markup m (DocString s)		= markupString m s
-markup m (DocParagraph d)	= markupParagraph m (markup m d)
-markup m (DocIdentifier i)	= markupIdentifier m i
-markup m (DocModule mod)	= markupModule m mod
-markup m (DocEmphasis d)	= markupEmphasis m (markup m d)
-markup m (DocMonospaced d)	= markupMonospaced m (markup m d)
-markup m (DocUnorderedList ds)	= markupUnorderedList m (map (markup m) ds)
-markup m (DocOrderedList ds)	= markupOrderedList m (map (markup m) ds)
-markup m (DocCodeBlock d)	= markupCodeBlock m (markup m d)
-markup m (DocURL url)		= markupURL m url
-
--- | Since marking up is just a matter of mapping 'Doc' into some
--- other type, we can \'rename\' documentation by marking up 'Doc' into
--- the same thing, modifying only the identifiers embedded in it.
-mapIdent f = Markup {
-  markupEmpty         = DocEmpty,
-  markupString        = DocString,
-  markupParagraph     = DocParagraph,
-  markupAppend        = DocAppend,
-  markupIdentifier    = f,
-  markupModule        = DocModule,
-  markupEmphasis      = DocEmphasis,
-  markupMonospaced    = DocMonospaced,
-  markupUnorderedList = DocUnorderedList,
-  markupOrderedList   = DocOrderedList,
-  markupCodeBlock     = DocCodeBlock,
-  markupURL	      = DocURL
-  }
-
--- -----------------------------------------------------------------------------
--- ** Smart constructors
-
--- used to make parsing easier; we group the list items later
-docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) 
-  = DocUnorderedList (ds1++ds2)
-docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
-  = DocAppend (DocUnorderedList (ds1++ds2)) d
-docAppend (DocOrderedList ds1) (DocOrderedList ds2) 
-  = DocOrderedList (ds1++ds2)
-docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
-  = DocAppend (DocOrderedList (ds1++ds2)) d
-docAppend DocEmpty d = d
-docAppend d DocEmpty = d
-docAppend d1 d2 
-  = DocAppend d1 d2
-
--- again to make parsing easier - we spot a paragraph whose only item
--- is a DocMonospaced and make it into a DocCodeBlock
-docParagraph (DocMonospaced p)
-  = DocCodeBlock p
-docParagraph (DocAppend (DocString s1) (DocMonospaced p))
-  | all isSpace s1
-  = DocCodeBlock p
-docParagraph (DocAppend (DocString s1)
-		(DocAppend (DocMonospaced p) (DocString s2)))
-  | all isSpace s1 && all isSpace s2
-  = DocCodeBlock p
-docParagraph p
-  = DocParagraph p
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index ef209f98..58033edc 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -9,7 +9,7 @@ module HaddockUtil (
 
   -- * Misc utilities
   nameOfQName, collectNames, declBinders, declMainBinder, splitTyConApp,
-  restrictTo,
+  restrictTo, declDoc, parseModuleHeader,
 
   -- * Filename utilities
   basename, dirname, splitFilename3, 
@@ -25,6 +25,7 @@ import HsSyn
 import List	( intersect )
 import IO	( hPutStr, stderr )
 import System
+import RegexString
 
 -- -----------------------------------------------------------------------------
 -- Some Utilities
@@ -38,25 +39,25 @@ collectNames ds = concat (map declBinders ds)
 declMainBinder :: HsDecl -> Maybe HsName
 declMainBinder d = 
    case d of
-     HsTypeDecl _ n _ _          -> Just n
-     HsDataDecl _ _ n _ cons _   -> Just n
-     HsNewTypeDecl _ _ n _ _ _   -> Just n
-     HsClassDecl _ qt _ decls    -> Just (exQtNm qt)
-     HsTypeSig _ [n] _           -> Just n
-     HsTypeSig _ ns _            -> error "declMainBinder"
-     HsForeignImport _ _ _ _ n _ -> Just n
-     _                           -> Nothing
+     HsTypeDecl _ n _ _ _          -> Just n
+     HsDataDecl _ _ n _ cons _ _   -> Just n
+     HsNewTypeDecl _ _ n _ _ _  _  -> Just n
+     HsClassDecl _ qt _ decls _    -> Just (exQtNm qt)
+     HsTypeSig _ [n] _ _           -> Just n
+     HsTypeSig _ ns _ _            -> error "declMainBinder"
+     HsForeignImport _ _ _ _ n _ _ -> Just n
+     _                             -> Nothing
 
 declBinders :: HsDecl -> [HsName]
 declBinders d =
    case d of
-     HsTypeDecl _ n _ _          -> [n]
-     HsDataDecl _ _ n _ cons _   -> n : concat (map conDeclBinders cons)
-     HsNewTypeDecl _ _ n _ con _ -> n : conDeclBinders con
-     HsClassDecl _ qt _ decls    -> exQtNm qt : collectNames decls
-     HsTypeSig _ ns _            -> ns
-     HsForeignImport _ _ _ _ n _ -> [n]
-     _                           -> []
+     HsTypeDecl _ n _ _ _          -> [n]
+     HsDataDecl _ _ n _ cons _ _   -> n : concat (map conDeclBinders cons)
+     HsNewTypeDecl _ _ n _ con _ _ -> n : conDeclBinders con
+     HsClassDecl _ qt _ decls _    -> exQtNm qt : collectNames decls
+     HsTypeSig _ ns _ _            -> ns
+     HsForeignImport _ _ _ _ n _ _ -> [n]
+     _                             -> []
 
 conDeclBinders (HsConDecl _ n _ _ _ _) = [n]
 conDeclBinders (HsRecDecl _ n _ _ fields _) = 
@@ -67,7 +68,7 @@ fieldDeclBinders (HsFieldDecl ns _ _) = ns
 exQtNm (HsForAllType _ _ t) = nameOfQName (fst (splitTyConApp t))
 exQtNm t = nameOfQName (fst (splitTyConApp t))
 
-splitTyConApp :: HsType -> (HsQName,[HsType])
+splitTyConApp :: HsType -> (HsQName, [HsType])
 splitTyConApp t = split t []
  where
 	split :: HsType -> [HsType] -> (HsQName,[HsType])
@@ -80,12 +81,12 @@ splitTyConApp t = split t []
 
 restrictTo :: [HsName] -> HsDecl -> HsDecl
 restrictTo names decl = case decl of
-     HsDataDecl loc ctxt n xs cons drv -> 
-	HsDataDecl loc ctxt n xs (restrictCons names cons) drv
-     HsNewTypeDecl loc ctxt n xs con drv ->
-	HsDataDecl loc ctxt n xs (restrictCons names [con]) drv	
-     HsClassDecl loc qt fds decls  ->
-	HsClassDecl loc qt fds (restrictDecls names decls)
+     HsDataDecl loc ctxt n xs cons drv doc -> 
+	HsDataDecl loc ctxt n xs (restrictCons names cons) drv doc
+     HsNewTypeDecl loc ctxt n xs con drv doc ->
+	HsDataDecl loc ctxt n xs (restrictCons names [con]) drv	doc
+     HsClassDecl loc qt fds decls doc ->
+	HsClassDecl loc qt fds (restrictDecls names decls) doc
      _ -> decl
    
 restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl]
@@ -100,6 +101,52 @@ restrictDecls names decls = filter keep decls
 	-- ToDo: not really correct
 
 -- -----------------------------------------------------------------------------
+-- Extract documentation from a declaration
+
+declDoc (HsTypeDecl _ _ _ _ d)          = d
+declDoc (HsDataDecl _ _ _ _ _ _ d)      = d
+declDoc (HsNewTypeDecl _ _ _ _ _ _ d)   = d
+declDoc (HsClassDecl _ _ _ _ d)         = d
+declDoc (HsTypeSig _ _ _ d)             = d
+declDoc (HsForeignImport _ _ _ _ _ _ d) = d
+declDoc _ = Nothing
+
+-- -----------------------------------------------------------------------------
+-- Parsing module headers
+
+parseModuleHeader :: String -> (String, Maybe ModuleInfo)
+parseModuleHeader str =
+  case matchRegexAll moduleHeaderRE str of
+	Just (before, match, after, _, (_:_:_:s1:s2:s3:_)) -> 
+	   (after, Just (ModuleInfo { 
+				 portability = s3,
+				 stability   = s2,
+				 maintainer  = s1 }))
+	_other -> (str, Nothing)
+
+moduleHeaderRE = mkRegexWithOpts
+			 "^([ \t\n]*Module[ \t]*:.*\n)?\ 
+			  \([ \t\n]*Copyright[ \t]*:.*\n)?\ 
+			  \([ \t\n]*License[ \t]*:.*\n)?\ 
+			  \[ \t\n]*Maintainer[ \t]*:(.*)\n\ 
+			  \[ \t\n]*Stability[ \t]*:(.*)\n\ 
+			  \[ \t\n]*Portability[ \t]*:([^\n]*)\n"
+		True -- match "\n" with "."
+		False -- not case sensitive
+	-- All fields except the last (Portability) may be multi-line.
+	-- This is so that the portability field doesn't swallow up the
+	-- rest of the module documentation - we might want to revist
+	-- this at some point (perhaps have a separator between the 
+	-- portability field and the module documentation?).
+
+#if __GLASGOW_HASKELL__ < 500
+mkRegexWithOpts :: String -> Bool -> Bool -> Regex
+mkRegexWithOpts s single_line case_sensitive
+      = unsafePerformIO (re_compile_pattern (packString s) 
+                              single_line case_sensitive)
+#endif
+
+-- -----------------------------------------------------------------------------
 -- Filename mangling functions stolen from GHC's main/DriverUtil.lhs.
 
 type Suffix = String
@@ -159,3 +206,4 @@ mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
 mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
 mapMaybeM f Nothing = return Nothing
 mapMaybeM f (Just a) = f a >>= return . Just
+
diff --git a/src/HsLexer.lhs b/src/HsLexer.lhs
index 505e07f8..c6026b67 100644
--- a/src/HsLexer.lhs
+++ b/src/HsLexer.lhs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: HsLexer.lhs,v 1.8 2002/05/09 12:45:19 simonmar Exp $
+-- $Id: HsLexer.lhs,v 1.9 2002/05/15 13:03:02 simonmar Exp $
 --
 -- (c) The GHC Team, 1997-2000
 --
@@ -17,7 +17,7 @@ module HsLexer (Token(..), lexer, parseError,isSymbol) where
 
 import HsParseMonad
 import HsParseUtils
-import HsSyn(SrcLoc(..))
+import HsSyn
 
 import Numeric	( readHex, readOct )
 import Char
@@ -64,11 +64,11 @@ data Token
 	
 -- Documentation annotations
 
-	| DocCommentNext String		-- something beginning '-- |'
-	| DocCommentPrev String		-- something beginning '-- ^'
+	| DocCommentNext  String	-- something beginning '-- |'
+	| DocCommentPrev  String	-- something beginning '-- ^'
 	| DocCommentNamed String	-- something beginning '-- $'
-	| DocSection Int String		-- a section heading
-	| DocOptions String
+	| DocSection      Int String	-- a section heading
+	| DocOptions      String	-- attributes '-- #'
 
 -- Reserved operators
 
@@ -280,10 +280,9 @@ lexToken cont s loc y x =
    -- trace ("lexer: y="++show y++" x="++show x++"\n") $ 
    case s of
 	-- First the doc comments
-	'-':'-':' ':s -> do_doc s docComment
-
-	'{':'-':' ':s -> do_doc s nestedDocComment
-	'{':'-':s     -> do_doc s nestedDocComment
+	'-':'-':' ':s -> do_doc s False
+	'{':'-':' ':s -> do_doc s True
+	'{':'-':s     -> do_doc s True
 
         -- Next the special symbols
         '(':'#':s -> forward 2 LeftUT s
@@ -346,16 +345,21 @@ lexToken cont s loc y x =
 
   where forward n t s = cont t s loc y (x+n)
 
-	do_doc ('|':s) f = f DocCommentNext  cont s loc y x
-	do_doc ('/':s) f = f DocCommentNext  cont s loc y x
-	do_doc ('^':s) f = f DocCommentPrev  cont s loc y x
-	do_doc ('$':s) f = f DocCommentNamed cont s loc y x
-	do_doc ('#':s) f = f DocOptions      cont s loc y x
-	do_doc ('*':s) f = section 1 s
+	-- this is all terribly ugly, sorry :(
+	do_doc ('|':s) nested  = multi nested DocCommentNext  cont s loc y x
+	do_doc ('/':s) nested  = multi nested DocCommentNext  cont s loc y x
+	do_doc ('^':s) nested  = multi nested DocCommentPrev  cont s loc y x
+	do_doc ('$':s) nested  = multi nested DocCommentNamed cont s loc y x
+	do_doc ('#':s) nested  = multi nested DocOptions      cont s loc y x
+	do_doc ('*':s) nested  = section 1 s
 	  where section n ('*':s) = section (n+1) s
-		section n s = f (DocSection n) cont s loc y x
+		section n s 
+		  | nested = nestedDocComment (DocSection n) cont s loc y x
+		  | otherwise = oneLineDocComment (DocSection n) cont s loc y x
 	do_doc _ _ = error "Internal error: HsLexer.do_doc"
 
+multi True  = nestedDocComment
+multi False = multiLineDocComment
 
 afterNum cont i ('#':s) loc y x = cont (PrimInt i) s loc y (x+1)
 afterNum cont i s loc y x = cont (IntTok i) s loc y x
@@ -593,10 +597,13 @@ nestedDocComment f cont s loc y x = go f cont "" y x s
       c:s       -> go f cont (c:acc) y (x+1) s
       []        -> error "Internal error: nestedComment"
 
+oneLineDocComment f cont s loc y x
+  = cont (f line) rest loc y x -- continue with the newline char
+  where (line, rest) = break (== '\n') s
 
-docComment f cont s loc y x 
-  = let (s', comment, y') = slurpExtraCommentLines s [] y in
-    cont (f comment) s' loc y' x  -- continue with the newline char
+multiLineDocComment f cont s loc y x 
+  = cont (f comment) s' loc y' x -- continue with the newline char
+  where (s', comment, y') = slurpExtraCommentLines s [] y
     
 slurpExtraCommentLines s lines y
   = case rest of
diff --git a/src/HsParser.ly b/src/HsParser.ly
index b2d4eea6..9b47f117 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -1,7 +1,7 @@
 -----------------------------------------------------------------------------
-$Id: HsParser.ly,v 1.10 2002/05/09 12:43:06 simonmar Exp $
+$Id: HsParser.ly,v 1.11 2002/05/15 13:03:02 simonmar Exp $
 
-(c) Simon Marlow, Sven Panne 1997-2000
+(c) Simon Marlow, Sven Panne 1997-2002
 
 Haskell grammar.
 -----------------------------------------------------------------------------
@@ -21,14 +21,10 @@ ToDo: Differentiate between record updates and labeled construction.
 > import HsParseMonad
 > import HsLexer
 > import HsParseUtils
-> 
-> #ifdef __HUGS__
-> {-
-> #endif
-> import GlaExts
-> #ifdef __HUGS__
-> -}
-> #endif
+> import HaddockLex 	hiding (Token)
+> import HaddockParse
+> import HaddockUtil	( parseModuleHeader )
+> import Char 		( isSpace )
 > }
 
 -----------------------------------------------------------------------------
@@ -71,7 +67,7 @@ Docs
 >	DOCNEXT    { DocCommentNext $$ }
 >	DOCPREV    { DocCommentPrev $$ }
 >	DOCNAMED   { DocCommentNamed $$ }
->	DOCGROUP   { DocSection _ _ }
+>	DOCSECTION { DocSection _ _ }
 >	DOCOPTIONS { DocOptions $$ }
 
 Symbols
@@ -153,18 +149,19 @@ Module Header
 
 > module :: { HsModule }
 > 	: optdoc 'module' modid maybeexports 'where' body
->	    { HsModule $3 $4 (reverse (fst $6)) (reverse (snd $6)) 
->		(fst $1) (snd $1) }
+>	    { case $1 of { (opts,info,doc) ->
+>	      HsModule $3 $4 (reverse (fst $6)) (reverse (snd $6)) 
+>		opts info doc } }
 >	| body
 >	    { HsModule main_mod Nothing (reverse (fst $1)) (reverse (snd $1))
->		Nothing Nothing }
+>		Nothing Nothing Nothing }
 
-> optdoc :: { (Maybe String, Maybe String) }
->	: DOCNEXT					{ (Nothing, Just $1) }
->	| DOCOPTIONS					{ (Just $1, Nothing) }
->	| DOCOPTIONS DOCNEXT 				{ (Just $1, Just $2) }
->	| DOCNEXT DOCOPTIONS 				{ (Just $2, Just $1) }
->	| {- empty -}					{ (Nothing, Nothing) }
+> optdoc :: { (Maybe String, Maybe ModuleInfo, Maybe Doc) }
+>	: moduleheader			{ (Nothing, fst $1, snd $1) }
+>	| DOCOPTIONS			{ (Just $1, Nothing, Nothing) }
+>	| DOCOPTIONS moduleheader	{ (Just $1, fst $2, snd $2) }
+>	| moduleheader DOCOPTIONS	{ (Just $2, fst $1, snd $1) }
+>	| {- empty -}			{ (Nothing, Nothing, Nothing) }
 
 > body :: { ([HsImportDecl],[HsDecl]) }
 >	:  '{' bodyaux '}'				{ $2 }
@@ -193,14 +190,14 @@ The Export List
 > exportlist :: { [HsExportSpec] }
 >	:  export ',' exportlist		{ $1 : $3 }
 >	|  docgroup exportlist			{ $1 : $2 }
->	|  DOCNAMED exportlist			{ HsEDocNamed $1 : $2 }
->	|  DOCNEXT  exportlist			{ HsEDoc $1 : $2 }
+>	|  docnamed exportlist			{ HsEDocNamed (fst $1) : $2 }
+>	|  docnext  exportlist			{ HsEDoc $1 : $2 }
 > 	|  ',' exportlist			{ $2 }
 >	|  export				{ [$1] }
 > 	|  {- empty -}				{ [] }
 
 > docgroup :: { HsExportSpec }
-> 	: DOCGROUP	{ case $1 of { DocSection i s -> HsEGroup i s } }
+> 	: docsection			{ case $1 of { (i,s) -> HsEGroup i s } }
 
 > export :: { HsExportSpec }
 > 	:  qvar					{ HsEVar $1 }
@@ -299,19 +296,19 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux.
 
 > topdecl :: { HsDecl }
 >	: 'type' simpletype srcloc '=' ctype
->			{ HsTypeDecl $3 (fst $2) (snd $2) $5 }
+>		{ 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) }
+>		{% checkDataHeader $2 `thenP` \(cs,c,t) ->
+>		   returnP (HsDataDecl $3 cs c t (reverse $4) $5 Nothing) }
 >	| 'newtype' ctype srcloc '=' constr deriving
->			{% checkDataHeader $2 `thenP` \(cs,c,t) ->
->			   returnP (HsNewTypeDecl $3 cs c t $5 $6) }
+>		{% checkDataHeader $2 `thenP` \(cs,c,t) ->
+>		   returnP (HsNewTypeDecl $3 cs c t $5 $6 Nothing) }
 >	| 'class' srcloc ctype fds optcbody
->			{ HsClassDecl $2 $3 $4 $5}
+>		{ HsClassDecl $2 $3 $4 $5 Nothing}
 >	| 'instance' srcloc ctype optvaldefs
->			{ HsInstDecl $2 $3 $4 }
+>		{ HsInstDecl $2 $3 $4 }
 >	| 'default' srcloc '(' typelist ')'
->			{ HsDefaultDecl $2 $4 }
+>		{ HsDefaultDecl $2 $4 }
 >	| 'foreign' fdecl { $2 }
 >       | decl		{ $1 }
 
@@ -329,21 +326,21 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux.
 >	| decl				{ [$1] }
 
 > decl :: { HsDecl }
->	: signdecl			{ $1 }
->	| fixdecl			{ $1 }
->	| valdef			{ $1 }
->	| DOCNEXT			{ HsDocCommentNext $1 }
->	| DOCPREV			{ HsDocCommentPrev $1 }
->	| DOCNAMED			{ HsDocCommentNamed $1 }
->	| DOCGROUP			{ case $1 of { DocSection i s -> 
->							HsDocGroup i s } }
+>	: signdecl		{ $1 }
+>	| fixdecl		{ $1 }
+>	| valdef		{ $1 }
+>	| srcloc docnext	{ HsDocCommentNext $1 $2 }
+>	| srcloc docprev	{ HsDocCommentPrev $1 $2 }
+>	| srcloc docnamed	{ case $2 of { (n,s) -> 
+>					HsDocCommentNamed $1 n s } }
+>	| srcloc docsection	{ case $2 of { (i,s) -> HsDocGroup $1 i s } }
 
 > decllist :: { [HsDecl] }
 >	: '{' decls '}'			{ $2 }
 >	|     layout_on  decls close	{ $2 }
 
 > signdecl :: { HsDecl }
->	: vars srcloc '::' ctype	{ HsTypeSig $2 (reverse $1) $4 }
+>	: vars srcloc '::' ctypedoc	{ HsTypeSig $2 (reverse $1) $4 Nothing }
 
 ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var
 instead of qvar, we get another shift/reduce-conflict. Consider the
@@ -366,9 +363,9 @@ Foreign Declarations
 
 > fdecl :: { HsDecl }
 > fdecl : srcloc 'import' callconv safety fspec
->	  { case $5 of (spec,nm,ty) -> HsForeignImport $1 $3 $4 spec nm ty }
+>	  { case $5 of (spec,nm,ty) -> HsForeignImport $1 $3 $4 spec nm ty Nothing }
 > 	| srcloc 'import' callconv fspec
->	  { case $4 of (spec,nm,ty) -> HsForeignImport $1 $3 HsFISafe spec nm ty }
+>	  { case $4 of (spec,nm,ty) -> HsForeignImport $1 $3 HsFISafe spec nm ty Nothing }
 > 	| srcloc 'export' callconv fspec
 >	  { case $4 of (spec,nm,ty) -> HsForeignExport $1 $3 spec nm ty }
 
@@ -383,14 +380,22 @@ Foreign Declarations
 > 	  | 'threadsafe'		{ HsFIThreadSafe  }
 
 > fspec :: { (String, HsName, HsType) }
-> 	 : STRING varid '::' ctype      { ($1, $2, $4) }
-> 	 |        varid '::' ctype      { ("", $1, $3) }
+> 	 : STRING varid '::' ctypedoc   { ($1, $2, $4) }
+> 	 |        varid '::' ctypedoc   { ("", $1, $3) }
 
 -----------------------------------------------------------------------------
 Types
 
+> doctype :: { HsType }
+>	: tydoc '->' doctype		{ HsTyFun $1 $3 }
+>	| tydoc				{ $1 }
+
+> tydoc :: { HsType }
+> 	: btype				{ $1 }
+>	| btype docprev			{ HsTyDoc $1 $2 }
+
 > type :: { HsType }
->	: btype '->' type		{ HsTyFun $1 $3 }
+> 	: btype '->' type		{ HsTyFun $1 $3 }
 >	| btype				{ $1 }
 
 > btype :: { HsType }
@@ -429,6 +434,11 @@ C a, or (C1 a, C2 b, ... Cn z) and convert it into a context.  Blaach!
 >	| context '=>' type		{ mkHsForAllType Nothing $1 $3 }
 >	| type				{ $1 }
 
+> ctypedoc :: { HsType }
+>	: 'forall' tyvars '.' ctypedoc	{ mkHsForAllType (Just $2) [] $4 }
+>	| context '=>' doctype		{ mkHsForAllType Nothing $1 $3 }
+>	| doctype			{ $1 }
+
 > context :: { HsContext }
 > 	: btype				{% checkContext $1 }
 
@@ -472,14 +482,6 @@ Datatype declarations
 > 	: scontype 				{ $1 }
 >	| sbtype conop sbtype			{ ($2, [$1,$3]) }
 
-> 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,
@@ -927,6 +929,45 @@ Miscellaneous (mostly renamings)
 >	: varid_no_forall	{ $1 }
 
 -----------------------------------------------------------------------------
+Documentation comments
+
+> docnext :: { Doc }
+>	: DOCNEXT	{% case parseParas (tokenise $1) of {
+>				Left  err -> parseError err;
+>				Right doc -> returnP doc } }
+
+> docprev :: { Doc }
+>	: DOCPREV	{% case parseParas (tokenise $1) of {
+>				Left  err -> parseError err;
+>				Right doc -> returnP doc } }
+
+> docnamed :: { (String,Doc) }
+>	: DOCNAMED	{% let (name,rest) = break isSpace $1 in
+>			   case parseParas (tokenise rest) of {
+>				Left  err -> parseError err;
+>				Right doc -> returnP (name,doc) } }
+
+> docsection :: { (Int,Doc) }
+> 	: DOCSECTION	{% case $1 of { DocSection n s -> 
+>			   case parseString (tokenise s) of {
+>				Left err -> parseError err;
+>				Right doc -> returnP (n, doc) } } }
+
+> maybe_docprev :: { Maybe Doc }
+> 	: docprev			{ Just $1 }
+>	| {- empty -}			{ Nothing }
+
+> maybe_docnext :: { Maybe Doc }
+> 	: docnext			{ Just $1 }
+>	| {- empty -}			{ Nothing }
+
+> moduleheader :: { (Maybe ModuleInfo, Maybe Doc) }
+>	: DOCNEXT 	{% let (str, info) = parseModuleHeader $1 in
+>			   case parseParas (tokenise str) of {
+>				Left  err -> parseError err;
+>				Right doc -> returnP (info, Just doc); } }
+
+-----------------------------------------------------------------------------
 
 > {
 > happyError = parseError "Parse error"
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index 069143f9..ecd2b0ce 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.8 2002/05/09 10:35:00 simonmar Exp $
+% $Id: HsSyn.lhs,v 1.9 2002/05/15 13:03:02 simonmar Exp $
 %
 % (c) The GHC Team, 1997-2002
 %
@@ -10,7 +10,7 @@
 \begin{code}
 module HsSyn (
     SrcLoc(..), Module(..), HsQName(..), HsName(..), HsIdentifier(..),
-    HsModule(..), HsExportSpec(..),
+    HsModule(..), HsExportSpec(..),  ModuleInfo(..),
     HsImportDecl(..), HsImportSpec(..), HsAssoc(..),
     HsDecl(..), HsMatch(..), HsConDecl(..), HsFieldDecl(..), 
     HsBangType(..), HsRhs(..),
@@ -28,8 +28,13 @@ module HsSyn (
     stdcall_name, ccall_name, dotnet_name,
     unit_tycon_name, fun_tycon_name, list_tycon_name, tuple_tycon_name,
     unit_tycon, fun_tycon, list_tycon, tuple_tycon,
+
+    GenDoc(..), Doc, DocMarkup(..),
+    markup, mapIdent, 
+    docAppend, docParagraph,
   ) where
 
+import Char (isSpace)
 
 data SrcLoc = SrcLoc Int Int -- (Line, Indentation)
   deriving (Eq,Ord,Show)
@@ -72,8 +77,15 @@ instance Show HsIdentifier where
 
 data HsModule = HsModule Module (Maybe [HsExportSpec])
                         [HsImportDecl] [HsDecl] 
-			(Maybe String)	-- the doc options
-			(Maybe String)	-- the module doc
+			(Maybe String)		-- the doc options
+			(Maybe ModuleInfo)	-- the info (portability etc.)
+			(Maybe Doc)		-- the module doc
+  deriving Show
+
+data ModuleInfo = ModuleInfo
+	{ portability :: String,
+	  stability   :: String,
+	  maintainer  :: String }
   deriving Show
 
 -- Export/Import Specifications
@@ -84,8 +96,8 @@ data HsExportSpec
 	 | HsEThingAll HsQName			-- T(..)
 	 | HsEThingWith HsQName [HsQName]	-- T(C_1,...,C_n)
 	 | HsEModuleContents Module		-- module M   (not for imports)
-	 | HsEGroup Int String			-- a doc section heading
-	 | HsEDoc String			-- some documentation
+	 | HsEGroup Int Doc			-- a doc section heading
+	 | HsEDoc Doc				-- some documentation
 	 | HsEDocNamed String			-- a reference to named doc
   deriving (Eq,Show)
 
@@ -120,22 +132,37 @@ data HsCallConv
   deriving (Eq,Show)
 
 data HsDecl
-	 = HsTypeDecl	 SrcLoc HsName [HsName] HsType
-	 | HsDataDecl	 SrcLoc HsContext HsName [HsName] [HsConDecl] [HsQName]
-	 | HsInfixDecl   SrcLoc HsAssoc Int [HsName]
-	 | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName]
-	 | HsClassDecl	 SrcLoc HsType [HsFunDep] [HsDecl]
-	 | HsInstDecl	 SrcLoc HsType [HsDecl]
-	 | HsDefaultDecl SrcLoc [HsType]
-	 | HsTypeSig	 SrcLoc [HsName] HsType
-	 | HsFunBind     [HsMatch]
-	 | HsPatBind	 SrcLoc HsPat HsRhs {-where-} [HsDecl]
-	 | HsForeignImport SrcLoc HsCallConv HsFISafety String HsName HsType
-	 | HsForeignExport SrcLoc HsCallConv String HsName HsType
-	 | HsDocCommentNext String	-- a documentation annotation
-	 | HsDocCommentPrev String	-- a documentation annotation
-	 | HsDocCommentNamed String	-- a documentation annotation
-	 | HsDocGroup    Int String	-- a documentation group
+  = HsTypeDecl SrcLoc HsName [HsName] HsType (Maybe Doc)
+ 
+  | HsDataDecl SrcLoc HsContext HsName [HsName] [HsConDecl] [HsQName]
+ 		  (Maybe Doc)
+ 
+  | HsInfixDecl SrcLoc HsAssoc Int [HsName]
+ 
+  | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName]
+ 		  (Maybe Doc)
+ 
+  | HsClassDecl SrcLoc HsType [HsFunDep] [HsDecl] (Maybe Doc)
+ 
+  | HsInstDecl SrcLoc HsType [HsDecl]
+ 
+  | HsDefaultDecl SrcLoc [HsType]
+ 
+  | HsTypeSig SrcLoc [HsName] HsType (Maybe Doc)
+ 
+  | HsFunBind [HsMatch]
+ 
+  | HsPatBind SrcLoc HsPat HsRhs {-where-} [HsDecl]
+ 
+  | HsForeignImport SrcLoc HsCallConv HsFISafety String HsName HsType
+ 		    (Maybe Doc)
+ 
+  | HsForeignExport SrcLoc HsCallConv String HsName HsType
+ 
+  | HsDocCommentNext  SrcLoc Doc	-- a documentation annotation
+  | HsDocCommentPrev  SrcLoc Doc	-- a documentation annotation
+  | HsDocCommentNamed SrcLoc String Doc	-- a documentation annotation
+  | HsDocGroup        SrcLoc Int Doc	-- a documentation group
   deriving (Eq,Show)
 
 data HsMatch 
@@ -143,12 +170,12 @@ data HsMatch
   deriving (Eq,Show)
 
 data HsConDecl
-     = HsConDecl SrcLoc HsName [HsName] HsContext [HsBangType] (Maybe String)
-     | HsRecDecl SrcLoc HsName [HsName] HsContext [HsFieldDecl] (Maybe String)
+     = HsConDecl SrcLoc HsName [HsName] HsContext [HsBangType] (Maybe Doc)
+     | HsRecDecl SrcLoc HsName [HsName] HsContext [HsFieldDecl] (Maybe Doc)
   deriving (Eq,Show)
 
 data HsFieldDecl
-	= HsFieldDecl [HsName] HsBangType (Maybe String)
+	= HsFieldDecl [HsName] HsBangType (Maybe Doc)
   deriving (Eq,Show)
 
 data HsBangType
@@ -172,6 +199,7 @@ data HsType
 	 | HsTyApp   HsType HsType
 	 | HsTyVar   HsName
 	 | HsTyCon   HsQName
+	 | HsTyDoc   HsType Doc
   deriving (Eq,Show)
 
 type HsFunDep  = ([HsName], [HsName])
@@ -317,4 +345,106 @@ unit_tycon	      = HsTyCon unit_tycon_name
 fun_tycon	      = HsTyCon fun_tycon_name
 list_tycon	      = HsTyCon list_tycon_name
 tuple_tycon i	      = HsTyCon (tuple_tycon_name i)
+
+-- -----------------------------------------------------------------------------
+-- Doc strings and formatting
+
+data GenDoc id
+  = DocEmpty 
+  | DocAppend (GenDoc id) (GenDoc id)
+  | DocString String
+  | DocParagraph (GenDoc id)
+  | DocIdentifier id
+  | DocModule String
+  | DocEmphasis (GenDoc id)
+  | DocMonospaced (GenDoc id)
+  | DocUnorderedList [GenDoc id]
+  | DocOrderedList [GenDoc id]
+  | DocCodeBlock (GenDoc id)
+  | DocURL String
+  deriving (Eq, Show)
+
+type Doc = GenDoc [HsQName]
+
+-- | DocMarkup is a set of instructions for marking up documentation.
+-- In fact, it's really just a mapping from 'GenDoc' to some other
+-- type [a], where [a] is usually the type of the output (HTML, say).
+
+data DocMarkup id a = Markup {
+  markupEmpty         :: a,
+  markupString        :: String -> a,
+  markupParagraph     :: a -> a,
+  markupAppend        :: a -> a -> a,
+  markupIdentifier    :: id -> a,
+  markupModule        :: String -> a,
+  markupEmphasis      :: a -> a,
+  markupMonospaced    :: a -> a,
+  markupUnorderedList :: [a] -> a,
+  markupOrderedList   :: [a] -> a,
+  markupCodeBlock     :: a -> a,
+  markupURL	      :: String -> a
+  }
+
+markup :: DocMarkup id a -> GenDoc id -> a
+markup m DocEmpty		= markupEmpty m
+markup m (DocAppend d1 d2)	= markupAppend m (markup m d1) (markup m d2)
+markup m (DocString s)		= markupString m s
+markup m (DocParagraph d)	= markupParagraph m (markup m d)
+markup m (DocIdentifier i)	= markupIdentifier m i
+markup m (DocModule mod)	= markupModule m mod
+markup m (DocEmphasis d)	= markupEmphasis m (markup m d)
+markup m (DocMonospaced d)	= markupMonospaced m (markup m d)
+markup m (DocUnorderedList ds)	= markupUnorderedList m (map (markup m) ds)
+markup m (DocOrderedList ds)	= markupOrderedList m (map (markup m) ds)
+markup m (DocCodeBlock d)	= markupCodeBlock m (markup m d)
+markup m (DocURL url)		= markupURL m url
+
+-- | Since marking up is just a matter of mapping 'Doc' into some
+-- other type, we can \'rename\' documentation by marking up 'Doc' into
+-- the same thing, modifying only the identifiers embedded in it.
+mapIdent f = Markup {
+  markupEmpty         = DocEmpty,
+  markupString        = DocString,
+  markupParagraph     = DocParagraph,
+  markupAppend        = DocAppend,
+  markupIdentifier    = f,
+  markupModule        = DocModule,
+  markupEmphasis      = DocEmphasis,
+  markupMonospaced    = DocMonospaced,
+  markupUnorderedList = DocUnorderedList,
+  markupOrderedList   = DocOrderedList,
+  markupCodeBlock     = DocCodeBlock,
+  markupURL	      = DocURL
+  }
+
+-- -----------------------------------------------------------------------------
+-- ** Smart constructors
+
+-- used to make parsing easier; we group the list items later
+docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) 
+  = DocUnorderedList (ds1++ds2)
+docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
+  = DocAppend (DocUnorderedList (ds1++ds2)) d
+docAppend (DocOrderedList ds1) (DocOrderedList ds2) 
+  = DocOrderedList (ds1++ds2)
+docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
+  = DocAppend (DocOrderedList (ds1++ds2)) d
+docAppend DocEmpty d = d
+docAppend d DocEmpty = d
+docAppend d1 d2 
+  = DocAppend d1 d2
+
+-- again to make parsing easier - we spot a paragraph whose only item
+-- is a DocMonospaced and make it into a DocCodeBlock
+docParagraph (DocMonospaced p)
+  = DocCodeBlock p
+docParagraph (DocAppend (DocString s1) (DocMonospaced p))
+  | all isSpace s1
+  = DocCodeBlock p
+docParagraph (DocAppend (DocString s1)
+		(DocAppend (DocMonospaced p) (DocString s2)))
+  | all isSpace s1 && all isSpace s2
+  = DocCodeBlock p
+docParagraph p
+  = DocParagraph p
 \end{code}
diff --git a/src/Main.hs b/src/Main.hs
index 7a2ad007..96425a46 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -8,14 +8,12 @@ module Main (main) where
 
 import HaddockRename
 import HaddockParse
-import HaddockLex
-import HaddockDB
+--import HaddockDB   -- not compiling
 import HaddockHtml
 import HaddockTypes
 import HaddockUtil
 import Digraph
 
-import HsLexer hiding (Token)
 import HsParser
 import HsParseMonad
 import HsSyn
@@ -25,8 +23,7 @@ import FiniteMap
 
 --import Pretty
 
-import RegexString
-import Maybe	( maybeToList )
+import Maybe	( isJust, maybeToList )
 import List	( nub )
 import Monad	( when )
 import Char	( isSpace )
@@ -126,8 +123,8 @@ run flags files = do
   module_map <- loop emptyFM sorted_mods files
   let mod_ifaces = fmToList module_map
 
-  when (Flag_DocBook `elem` flags) $
-    putStr (ppDocBook odir mod_ifaces)
+--  when (Flag_DocBook `elem` flags) $
+--    putStr (ppDocBook odir mod_ifaces)
 
   when (Flag_Html `elem` flags) $
     ppHtml title source_url mod_ifaces odir css_file libdir
@@ -155,7 +152,7 @@ mkInterface
 	      )
 
 mkInterface mod_map filename 
-	(HsModule mod exps imps decls maybe_opts maybe_doc) = do  
+	(HsModule mod exps imps decls maybe_opts maybe_info maybe_doc) = do  
 
   -- Process the options, if available
   options <- case maybe_opts of
@@ -163,13 +160,17 @@ mkInterface mod_map filename
 		Nothing      -> return []
 
   let
-     locally_defined_names = collectNames decls
+     -- first, attach documentation to declarations
+     annotated_decls = collectDoc decls
+
+     -- now find the defined names
+     locally_defined_names = collectNames annotated_decls
 
      qual_local_names   = map (Qual mod) locally_defined_names
      unqual_local_names = map UnQual     locally_defined_names
 
      local_env = listToFM (zip unqual_local_names qual_local_names ++
-			  zip qual_local_names   qual_local_names)
+			   zip qual_local_names   qual_local_names)
 	 -- both qualified and unqualifed names are in scope for local things
 
      -- build the orig_env, which maps names to *original* names (so we can
@@ -184,7 +185,7 @@ mkInterface mod_map filename
 	= runRnFM orig_env (mapMaybeM renameExportList exps)
 
      (orig_decls, missing_names2)
-	= runRnFM orig_env (mapM renameDecl decls)
+	= runRnFM orig_env (mapM renameDecl annotated_decls)
 
      orig_decl_map :: FiniteMap HsName HsDecl
      orig_decl_map = listToFM [ (n,d) | d <- orig_decls, n <- declBinders d ]
@@ -194,45 +195,9 @@ mkInterface mod_map filename
 			locally_defined_names orig_exports
 			orig_decl_map options
 
-  -- Parse the module header
-  (module_doc, maybe_info, missing_names_doc1) <-
-       case maybe_doc of
-	 Nothing  -> return (Nothing, Nothing, [])
-	 Just doc -> do
-	    let (doc1, maybe_info) = parseModuleHeader doc
-	    (doc2,ns) <- formatDocString mod (lookupForDoc import_env) doc1
-	    return (Just doc2, maybe_info, ns)
-
   let
      final_decls = concat (map expandDecl orig_decls)
 
-     -- match documentation to names, and resolve identifiers in the 
-     -- documentation
-     local_docstrings :: [(HsName,DocString)]
-     local_docstrings = collectDoc final_decls
-
-     formatLocalDoc (n,doc) = do
-	doc' <- formatDocString mod (lookupForDoc orig_env) doc
-	return (n,doc')
-
-  local_docs_formatted <- mapM formatLocalDoc local_docstrings
-
-  let
-     local_docs :: [(HsName,Doc)]		-- with *original* names
-     local_docs = [ (n,doc) | (n,(doc,_)) <- local_docs_formatted ]
-
-     -- collect the list of names which we couldn't resolve in the documentation
-     missing_names_doc2 = concat [ ns | (n,(doc,ns)) <- local_docs_formatted ]
-
-     -- get the documentation associated with entities exported from this module
-     -- ToDo: we should really store the documentation in both orig and imported
-     -- forms, like the export items.
-     doc_map :: FiniteMap HsName Doc	-- with *imported* names
-     doc_map = listToFM 
-       [ (nameOfQName n, doc)
-       | n <- exported_names,
-         Just doc <- [lookupDoc mod_map mod local_docs import_env n] ]
-
      decl_map :: FiniteMap HsName HsDecl
      decl_map = listToFM [ (n,d) | d <- final_decls, n <- declBinders d ]
 
@@ -244,23 +209,21 @@ mkInterface mod_map filename
      -- prune the export list to just those declarations that have
      -- documentation, if the 'prune' option is on.
      pruned_export_list
-	| OptPrune `elem` options = pruneExportItems doc_map orig_export_list
+	| OptPrune `elem` options = pruneExportItems orig_export_list
 	| otherwise = orig_export_list
 
      -- rename names in the exported declarations to point to things that
      -- are closer, or maybe even exported by, the current module.
-     (renamed_export_list, missing_names3)
+     (renamed_export_list, _missing_names3)
         = runRnFM import_env (renameExportItems pruned_export_list)
 
      name_env = listToFM [ (nameOfQName n, n) | n <- exported_names ]
 
   -- report any names we couldn't find/resolve
 
-  let missing_names_doc = missing_names_doc1 ++ missing_names_doc2
-      missing_names = missing_names1 ++ missing_names2
+  let missing_names = missing_names1 ++ missing_names2
 			 --ignore missing_names3 for now,
-
-      name_strings = nub (map show missing_names ++ missing_names_doc)
+      name_strings = nub (map show missing_names)
 
   when (not (null name_strings)) $
 	  tell ["Warning: in module " ++ show mod ++ 
@@ -269,40 +232,18 @@ mkInterface mod_map filename
 		]
 
   return (mod, Interface { 
-		   iface_filename = filename,
-		   iface_env = name_env,
-		   iface_exports = renamed_export_list,
+		   iface_filename     = filename,
+		   iface_env          = name_env,
+		   iface_exports      = renamed_export_list,
 		   iface_orig_exports = pruned_export_list,
-		   iface_decls =  decl_map,
-		   iface_info = maybe_info,
-		   iface_name_docs   = doc_map,
-		   iface_doc         = module_doc,
-		   iface_options     = options
+		   iface_decls        = decl_map,
+		   iface_info	      = maybe_info,
+		   iface_doc          = maybe_doc,
+		   iface_options      = options
 		}
       	  )
 
 -- -----------------------------------------------------------------------------
--- Find the documentation for a particular name, and rename the
--- original identifiers embedded in it to imported names.
-
-lookupDoc :: ModuleMap -> Module -> [(HsName,Doc)]
-	-> FiniteMap HsQName HsQName -> HsQName -> Maybe Doc
-lookupDoc mod_map this_mod local_doc env name
-  = case name of
-	UnQual n -> Nothing
-	Qual mod n
-	  | mod == this_mod -> 
-		fst (runRnFM env (mapMaybeM renameDoc (lookup n local_doc)))
-		-- ToDo: report missing names
-	  | otherwise       -> 
-		case lookupFM mod_map mod of
-		   Nothing -> Nothing
-		   Just iface -> 
-			fst (runRnFM env (mapMaybeM renameDoc
-				     (lookupFM (iface_name_docs iface) n)))
-		-- ToDo: report missing names
-
--- -----------------------------------------------------------------------------
 -- Build the list of items that will become the documentation, from the
 -- export list.  At the same time we rename *original* names in the declarations
 -- to *imported* names.
@@ -327,8 +268,8 @@ mkExportItems mod_map mod env decl_map decls options maybe_exps
 
     lookupExport (HsEVar x) 
 	| Just decl <- findDecl x
-	= let decl' | HsTypeSig loc ns ty <- decl
-			= HsTypeSig loc [nameOfQName x] ty
+	= let decl' | HsTypeSig loc ns ty doc <- decl
+			= HsTypeSig loc [nameOfQName x] ty doc
 		    | otherwise
 		  	= decl
 	  in
@@ -344,21 +285,15 @@ mkExportItems mod_map mod env decl_map decls options maybe_exps
 	| Just decl <- findDecl t
 	= return [ ExportDecl (restrictTo (map nameOfQName cs) decl) ]
     lookupExport (HsEModuleContents m) = fullContentsOf m
-    lookupExport (HsEGroup lev str)
-	= do (doc, _names) <- formatDocHeading mod (lookupForDoc env) str
-	     return [ ExportGroup lev "" doc ]
-	  -- ToDo: report the unresolved names
-    lookupExport (HsEDoc str)
-	= do (doc, _names) <- formatDocString mod (lookupForDoc env) str
-	     return [ ExportDoc doc ]
-	-- ToDo: report the unresolved names
+    lookupExport (HsEGroup lev doc)
+	= return [ ExportGroup lev "" doc ]
+    lookupExport (HsEDoc doc)
+	= return [ ExportDoc doc ]
     lookupExport (HsEDocNamed str)
 	= do r <- findNamedDoc str decls
 	     case r of
 		Nothing -> return []
-		Just found -> do
-		  (doc, _nms) <- formatDocString mod (lookupForDoc env) found
-	  	  return [ ExportDoc doc ]
+		Just found -> return [ ExportDoc found ]
 	
     lookupExport _ = return [] -- didn't find it?
 
@@ -385,12 +320,10 @@ mkExportItems mod_map mod env decl_map decls options maybe_exps
 
 fullContentsOfThisModule mod decls env = 
   mapM mkExportItem (filter keepDecl decls)
-  where mkExportItem (HsDocGroup lev str) = do
-	   (doc, _names) <- formatDocHeading mod (lookupForDoc env) str
+  where mkExportItem (HsDocGroup loc lev doc) =
 	   return (ExportGroup lev "" doc)
-	   -- ToDo: report the unresolved names
-	mkExportItem decl = return (ExportDecl decl)
-
+	mkExportItem decl = 
+	   return (ExportDecl decl)
 
 keepDecl HsTypeSig{}     = True
 keepDecl HsTypeDecl{}    = True
@@ -403,9 +336,9 @@ keepDecl _ = False
 -- -----------------------------------------------------------------------------
 -- Pruning
 
-pruneExportItems :: FiniteMap HsName Doc -> [ExportItem] -> [ExportItem]
-pruneExportItems doc_map items = filter has_doc items
-  where has_doc (ExportDecl d) | Just n <- declMainBinder d = n `elemFM` doc_map
+pruneExportItems :: [ExportItem] -> [ExportItem]
+pruneExportItems items = filter has_doc items
+  where has_doc (ExportDecl d) = isJust (declDoc d)
 	has_doc _ = True
 
 -- -----------------------------------------------------------------------------
@@ -487,190 +420,72 @@ buildEnv mod_map this_mod exported_names (HsImportDecl _ mod qual maybe_as _)
 -- Expand multiple type signatures
 
 expandDecl :: HsDecl -> [HsDecl]
-expandDecl (HsTypeSig loc fs qt) = [ HsTypeSig loc [f] qt | f <- fs ]
-expandDecl (HsClassDecl loc ty fds decls)
-  = [ HsClassDecl loc ty fds (concat (map expandDecl decls)) ]
+expandDecl (HsTypeSig loc fs qt doc) = [ HsTypeSig loc [f] qt doc | f <- fs ]
+expandDecl (HsClassDecl loc ty fds decls doc)
+  = [ HsClassDecl loc ty fds (concat (map expandDecl decls)) doc ]
 expandDecl d = [ d ]
 
 -----------------------------------------------------------------------------
--- Collecting documentation and associating it with declarations
+-- Collecting documentation and attach it to the right declarations
 
-collectDoc :: [HsDecl] -> [(HsName, DocString)]
-collectDoc decls = collect Nothing "" decls
+collectDoc :: [HsDecl] -> [HsDecl]
+collectDoc decls = collect Nothing DocEmpty decls
 
-collect name doc_so_far [] = 
-   case name of
+collect d doc_so_far [] = 
+   case d of
 	Nothing -> []
-	Just n  -> finishedDoc n doc_so_far []
+	Just d  -> finishedDoc d doc_so_far []
 
-collect name doc_so_far (decl:ds) = 
+collect d doc_so_far (decl:ds) = 
    case decl of
-      HsDocCommentNext str -> 
-	case name of
-	   Nothing -> collect name (doc_so_far ++ str) ds
-	   Just n  -> finishedDoc n doc_so_far (collect Nothing str ds)
+      HsDocCommentNext loc str -> 
+	case d of
+	   Nothing -> collect d (docAppend doc_so_far str) ds
+	   Just d  -> finishedDoc d doc_so_far (collect Nothing str ds)
 
-      HsDocCommentPrev str -> collect name (doc_so_far ++ str) ds
+      HsDocCommentPrev loc str -> collect d (docAppend doc_so_far str) ds
 
       _other -> 
-	docsFromDecl decl ++
-	case name of
-	    Nothing -> collect bndr doc_so_far ds
-	    Just n  -> finishedDoc n doc_so_far (collect bndr "" ds)
-        where 
-	    bndr = declMainBinder decl
-
-finishedDoc n s rest | all isSpace s = rest
- 	             | otherwise     = (n,s) : rest
-
--- look inside a declaration and get docs for the bits
--- (constructors, record fields, class methods)
-docsFromDecl :: HsDecl -> [(HsName, DocString)]
-docsFromDecl (HsDataDecl loc ctxt nm tvs cons drvs)
-  = concat (map docsFromConDecl cons)
-docsFromDecl (HsNewTypeDecl loc ctxt nm tvs con drvs)
-  = docsFromConDecl con
-docsFromDecl (HsClassDecl loc ty fds decls)
-  = collect Nothing "" decls
-docsFromDecl _
-  = []
-
-docsFromConDecl :: HsConDecl -> [(HsName, DocString)]
-docsFromConDecl (HsConDecl loc nm tvs ctxt tys (Just doc))
-  = finishedDoc nm doc []
-docsFromConDecl (HsRecDecl loc nm tvs ctxt fields (Just doc))
-  = finishedDoc nm doc (foldr docsFromField [] fields)
-docsFromConDecl (HsRecDecl loc nm tvs ctxt fields Nothing)
-  = foldr docsFromField [] fields
-docsFromConDecl _ 
-  = []
-
-docsFromField (HsFieldDecl nms ty (Just doc)) rest
-  = foldr (\n -> finishedDoc n doc) rest nms
-docsFromField (HsFieldDecl nms ty Nothing) rest
-  = rest
-
------------------------------------------------------------------------------
--- formatting is done in two stages.  Firstly we partially apply
--- formatDocString to the lookup function and the DocString to get a
--- markup-independent string.  Finally the back ends apply the markup
--- description to this function to get the marked-up text.
-
--- this one formats a heading
-formatDocHeading :: Module -> (String -> Maybe HsQName) -> DocString
-  -> ErrMsgM (Doc,[String])
-formatDocHeading mod lookup string = format mod parseString lookup string
-
--- this one formats a sequence of paragraphs
-formatDocString :: Module -> (String -> Maybe HsQName) -> DocString
-  -> ErrMsgM (Doc,[String])
-formatDocString mod lookup string = format mod parseParas lookup string
-
-format 	:: Module			--  for error messages only
-	-> ([Token] -> Either String ParsedDoc)
-	-> (String -> Maybe HsQName)
-	-> DocString
-       	-> ErrMsgM (Doc, [String])
-format mod parse lookup string
-  = case parse (tokenise string) of
-	Left error -> do 	
-	  tell ["Warning: in " ++ show mod ++
-		", parse error in doc string beginning:\n\ 
-		\    " ++ take 40 string]
-	  return (DocEmpty, [])
-	Right doc -> 
-	  return (runRn lookup (resolveDoc doc))
-
--- ---------------------------------------------------------------------------
--- Looking up names in documentation
-
-lookupForDoc :: FiniteMap HsQName HsQName -> (String -> Maybe HsQName)
-lookupForDoc fm str
-  = case [ n | Just n <- map (lookupFM fm) (strToHsQNames str) ] of
-	(n:_) -> Just n
-	[] -> Nothing
- 
-strToHsQNames :: String -> [ HsQName ]
-strToHsQNames str
- = case lexer (\t -> returnP t) str (SrcLoc 1 1) 1 1 [] of
-	Ok _ (VarId str)
-		-> [ UnQual (HsVarName (HsIdent str)) ]
-        Ok _ (QVarId (mod,str))
-		-> [ Qual (Module mod) (HsVarName (HsIdent str)) ]
-	Ok _ (ConId str)
-		-> [ UnQual (HsTyClsName (HsIdent str)),
-		     UnQual (HsVarName (HsIdent str)) ]
-        Ok _ (QConId (mod,str))
-		-> [ Qual (Module mod) (HsTyClsName (HsIdent str)),
-		     Qual (Module mod) (HsVarName (HsIdent str)) ]
-        Ok _ (VarSym str)
-		-> [ UnQual (HsVarName (HsSymbol str)) ]
-        Ok _ (ConSym str)
-		-> [ UnQual (HsTyClsName (HsSymbol str)),
-		     UnQual (HsVarName (HsSymbol str)) ]
-        Ok _ (QVarSym (mod,str))
-		-> [ Qual (Module mod) (HsVarName (HsSymbol str)) ]
-        Ok _ (QConSym (mod,str))
-		-> [ Qual (Module mod) (HsTyClsName (HsSymbol str)),
-		     Qual (Module mod) (HsVarName (HsSymbol str)) ]
-	other -> []
-
--- -----------------------------------------------------------------------------
--- Parsing module headers
-
-parseModuleHeader :: String -> (String, Maybe ModuleInfo)
-parseModuleHeader str =
-  case matchRegexAll moduleHeaderRE str of
-	Just (before, match, after, _, (_:_:_:s1:s2:s3:_)) -> 
-	   (after, Just (ModuleInfo { 
-				 portability = s3,
-				 stability   = s2,
-				 maintainer  = s1 }))
-	_other -> (str, Nothing)
-
-moduleHeaderRE = mkRegexWithOpts
-			 "^([ \t\n]*Module[ \t]*:.*\n)?\ 
-			  \([ \t\n]*Copyright[ \t]*:.*\n)?\ 
-			  \([ \t\n]*License[ \t]*:.*\n)?\ 
-			  \[ \t\n]*Maintainer[ \t]*:(.*)\n\ 
-			  \[ \t\n]*Stability[ \t]*:(.*)\n\ 
-			  \[ \t\n]*Portability[ \t]*:([^\n]*)\n"
-		True -- match "\n" with "."
-		False -- not case sensitive
-	-- All fields except the last (Portability) may be multi-line.
-	-- This is so that the portability field doesn't swallow up the
-	-- rest of the module documentation - we might want to revist
-	-- this at some point (perhaps have a separator between the 
-	-- portability field and the module documentation?).
-
-#if __GLASGOW_HASKELL__ < 500
-mkRegexWithOpts :: String -> Bool -> Bool -> Regex
-mkRegexWithOpts s single_line case_sensitive
-      = unsafePerformIO (re_compile_pattern (packString s) 
-                              single_line case_sensitive)
-#endif
+	let decl' = collectInDecl decl in
+	case d of
+	    Nothing -> collect (Just decl') doc_so_far ds
+	    Just d  -> finishedDoc d doc_so_far (collect (Just decl') DocEmpty ds)
+
+finishedDoc d DocEmpty rest = d : rest
+finishedDoc d doc rest = d' : rest
+ where d' = 
+	 case d of
+	  HsTypeDecl loc n ns ty _ -> 
+		HsTypeDecl loc n ns ty (Just doc)
+	  HsDataDecl loc ctxt n ns cons drv _ -> 
+		HsDataDecl loc ctxt n ns cons drv (Just doc)
+	  HsNewTypeDecl loc ctxt n ns con drv _ -> 
+		HsNewTypeDecl loc ctxt n ns con drv (Just doc)
+	  HsClassDecl loc ty fds meths _ -> 
+		HsClassDecl loc ty fds meths (Just doc)
+	  HsTypeSig loc ns ty _ -> 
+		HsTypeSig loc ns ty (Just doc)
+	  HsForeignImport loc cc sf str n ty _ ->
+		HsForeignImport loc cc sf str n ty (Just doc)
+	  _other -> d
+
+collectInDecl (HsClassDecl loc ty fds meths doc)
+  = HsClassDecl loc ty fds (collect Nothing DocEmpty meths) doc
+collectInDecl decl
+  = decl
 
 -- -----------------------------------------------------------------------------
 -- Named documentation
 
-findNamedDoc :: String -> [HsDecl] -> ErrMsgM (Maybe String)
-findNamedDoc str decls = 
-  case matchRegex docNameRE str of
-     Just (name:_) -> search decls
+findNamedDoc :: String -> [HsDecl] -> ErrMsgM (Maybe Doc)
+findNamedDoc name decls = search decls
 	where search [] = do
 		tell ["Cannot find documentation for: $" ++ name]
 		return Nothing
-	      search (HsDocCommentNamed str : rest) = 
-		case matchRegexAll docNameRE str of
-		   Just (_, _, after, _, name':_)
-			| name == name' -> return (Just after)
-		   _otherwise -> search rest
+	      search (HsDocCommentNamed loc name' doc : rest) 
+			| name == name' = return (Just doc)
+		   	| otherwise = search rest
 	      search (_other_decl : rest) = search rest
-     _other -> do
-	tell ["Invalid documentation name: $" ++ str]
-	return Nothing
-
-docNameRE = mkRegex "[ \t]*([A-Za-z0-9_]*)"
 
 -- -----------------------------------------------------------------------------
 -- Haddock options embedded in the source file
@@ -702,13 +517,13 @@ sortModules hsmodules = mapM for_each_scc sccs
 
 	edges :: [(HsModule, Module, [Module])]
 	edges = [ (hsmod, mod, [ imp | HsImportDecl _ imp _ _ _ <- impdecls ]) 
-		| hsmod@(HsModule mod _ impdecls _ _ _) <- hsmodules
+		| hsmod@(HsModule mod _ impdecls _ _ _ _) <- hsmodules
 		]
 
 	for_each_scc (AcyclicSCC hsmodule) = return hsmodule
 	for_each_scc (CyclicSCC  hsmodules) = 
 	   dieMsg ("modules are recursive: " ++ 
-		   unwords (map show [ mod | HsModule mod _ _ _ _ _ 
+		   unwords (map show [ mod | HsModule mod _ _ _ _ _ _
 						<- hsmodules ]))
 
 -- -----------------------------------------------------------------------------