Move doc parsing/lexing into Haddock for ghc>=6.11

7 files changed, 710 insertions, 49 deletions

diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 62960360..41028100 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -18,6 +18,7 @@ import Haddock.Options
 import Haddock.GhcUtils
 import Haddock.Utils
 import Haddock.Convert
+import Haddock.Interface.LexParseRn
 
 import qualified Data.Map as Map
 import Data.Map (Map)
@@ -29,6 +30,7 @@ import Control.Monad
 import GHC hiding (flags)
 import Name
 import Bag
+import RdrName (GlobalRdrEnv)
 
 
 -- | Process the data in the GhcModule to produce an interface.
@@ -40,24 +42,29 @@ createInterface ghcMod flags modMap instIfaceMap = do
 
   let mdl = ghcModule ghcMod
 
+  -- The pattern-match should not fail, because createInterface is only
+  -- done on loaded modules.
+  Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl)
+
   opts0 <- liftErrMsg $ mkDocOpts (ghcMbDocOpts ghcMod) flags mdl
   let opts
         | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
         | otherwise = opts0
 
-  let group_        = ghcGroup ghcMod
+  (info, mbDoc)    <- liftErrMsg $ lexParseRnHaddockModHeader
+                                       gre (ghcMbDocHdr ghcMod)
+  decls0           <- liftErrMsg $ declInfos gre (topDecls (ghcGroup ghcMod))
+  let decls         = filterOutInstances decls0
+      declMap       = mkDeclMap decls
       exports       = fmap (reverse . map unLoc) (ghcMbExports ghcMod)
       localNames    = ghcDefinedNames ghcMod
-      decls0        = declInfos . topDecls $ group_
-      decls         = filterOutInstances decls0
-      declMap       = mkDeclMap decls
       ignoreExps    = Flag_IgnoreAllExports `elem` flags
       exportedNames = ghcExportedNames ghcMod
       instances     = ghcInstances ghcMod
 
   liftErrMsg $ warnAboutFilteredDecls mdl decls0
 
-  exportItems <- mkExportItems modMap mdl (ghcExportedNames ghcMod) decls declMap
+  exportItems <- mkExportItems modMap mdl gre (ghcExportedNames ghcMod) decls declMap
                                opts exports ignoreExps instances instIfaceMap
 
   let visibleNames = mkVisibleNames exportItems opts
@@ -72,8 +79,8 @@ createInterface ghcMod flags modMap instIfaceMap = do
   return Interface {
     ifaceMod             = mdl,
     ifaceOrigFilename    = ghcFilename ghcMod,
-    ifaceInfo            = ghcHaddockModInfo ghcMod,
-    ifaceDoc             = ghcMbDoc ghcMod,
+    ifaceInfo            = info,
+    ifaceDoc             = mbDoc,
     ifaceRnDoc           = Nothing,
     ifaceOptions         = opts,
     ifaceLocals          = localNames,
@@ -139,17 +146,27 @@ mkDeclMap decls = Map.fromList . concat $
   , not (isDocD d), not (isInstD d) ]
 
 
-declInfos :: [(Decl, Maybe Doc)] -> [DeclInfo]
-declInfos decls = [ (parent, doc, subordinates d)
-                  | (parent@(L _ d), doc) <- decls]
+declInfos :: GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo]
+declInfos gre decls =
+  forM decls $ \(parent@(L _ d), mbDocString) -> do
+            mbDoc <- lexParseRnHaddockCommentList NormalHaddockComment
+                       gre mbDocString
 
+            let subsStringy = subordinates d
+            subs <- forM subsStringy $ \(subName, mbSubDocString) -> do
+                mbSubDoc <- lexParseRnHaddockCommentList NormalHaddockComment
+                              gre mbSubDocString
+                return (subName, mbSubDoc)
 
-subordinates :: HsDecl Name -> [(Name, Maybe Doc)]
+            return (parent, mbDoc, subs)
+
+
+subordinates :: HsDecl Name -> [(Name, MaybeDocStrings)]
 subordinates (TyClD d) = classDataSubs d
 subordinates _ = []
 
 
-classDataSubs :: TyClDecl Name -> [(Name, Maybe Doc)]
+classDataSubs :: TyClDecl Name -> [(Name, MaybeDocStrings)]
 classDataSubs decl
   | isClassDecl decl = classSubs
   | isDataDecl  decl = dataSubs
@@ -159,15 +176,16 @@ classDataSubs decl
     dataSubs  = constrs ++ fields   
       where
         cons    = map unL $ tcdCons decl
-        constrs = [ (unL $ con_name c, fmap unL $ con_doc c) | c <- cons ]
-        fields  = [ (unL n, fmap unL doc)
+        constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c)
+                  | c <- cons ]
+        fields  = [ (unL n, maybeToList $ fmap unL doc)
                   | RecCon flds <- map con_details cons
                   , ConDeclField n _ doc <- flds ]
 
 
 -- All the sub declarations of a class (that we handle), ordered by
 -- source location, with documentation attached if it exists. 
-classDecls :: TyClDecl Name -> [(Decl, Maybe Doc)]
+classDecls :: TyClDecl Name -> [(Decl, MaybeDocStrings)]
 classDecls = filterDecls . collectDocs . sortByLoc . declsFromClass
 
 
@@ -190,7 +208,7 @@ declName _ = error "unexpected argument to declName"
 
 -- | The top-level declarations of a module that we care about, 
 -- ordered by source location, with documentation attached if it exists.
-topDecls :: HsGroup Name -> [(Decl, Maybe Doc)] 
+topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)] 
 topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup
 
 
@@ -255,7 +273,7 @@ warnAboutFilteredDecls mdl decls = do
 
 
 -- | Filter out declarations that we don't handle in Haddock
-filterDecls :: [(Decl, Maybe Doc)] -> [(Decl, Maybe Doc)]
+filterDecls :: [(Decl, doc)] -> [(Decl, doc)]
 filterDecls decls = filter (isHandled . unL . fst) decls
   where
     isHandled (ForD (ForeignImport {})) = True
@@ -268,7 +286,7 @@ filterDecls decls = filter (isHandled . unL . fst) decls
 
 
 -- | Go through all class declarations and filter their sub-declarations
-filterClasses :: [(Decl, Maybe Doc)] -> [(Decl, Maybe Doc)]
+filterClasses :: [(Decl, doc)] -> [(Decl, doc)]
 filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x 
                       | x@(L loc d, doc) <- decls ]
   where
@@ -285,12 +303,25 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
 -- declaration.
 --------------------------------------------------------------------------------
 
+type MaybeDocStrings = [HsDocString]
+-- avoid [] because we're appending from the left (quadratic),
+-- and avoid adding another package dependency for haddock,
+-- so use the difference-list pattern
+type MaybeDocStringsFast = MaybeDocStrings -> MaybeDocStrings
+docStringEmpty :: MaybeDocStringsFast
+docStringEmpty = id
+docStringSingleton :: HsDocString -> MaybeDocStringsFast
+docStringSingleton = (:)
+docStringAppend :: MaybeDocStringsFast -> MaybeDocStringsFast -> MaybeDocStringsFast
+docStringAppend = (.)
+docStringToList :: MaybeDocStringsFast -> MaybeDocStrings
+docStringToList = ($ [])
 
 -- | Collect the docs and attach them to the right declaration.
-collectDocs :: [Decl] -> [(Decl, (Maybe Doc))]
-collectDocs = collect Nothing DocEmpty
+collectDocs :: [Decl] -> [(Decl, MaybeDocStrings)]
+collectDocs = collect Nothing docStringEmpty
 
-collect :: Maybe Decl -> Doc -> [Decl] -> [(Decl, (Maybe Doc))]
+collect :: Maybe Decl -> MaybeDocStringsFast -> [Decl] -> [(Decl, MaybeDocStrings)]
 collect d doc_so_far [] =
    case d of
         Nothing -> []
@@ -300,19 +331,24 @@ collect d doc_so_far (e:es) =
   case e of
     L _ (DocD (DocCommentNext str)) ->
       case d of
-        Nothing -> collect d (docAppend doc_so_far str) es
-        Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es)
+        Nothing -> collect d
+                     (docStringAppend doc_so_far (docStringSingleton str))
+                     es
+        Just d0 -> finishedDoc d0 doc_so_far (collect Nothing
+                     (docStringSingleton str)
+                     es)
 
-    L _ (DocD (DocCommentPrev str)) -> collect d (docAppend doc_so_far str) es
+    L _ (DocD (DocCommentPrev str)) -> collect d
+                     (docStringAppend doc_so_far (docStringSingleton str))
+                     es
 
     _ -> case d of
       Nothing -> collect (Just e) doc_so_far es
-      Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es)
+      Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) docStringEmpty es)
 
 
-finishedDoc :: Decl -> Doc -> [(Decl, (Maybe Doc))] -> [(Decl, (Maybe Doc))]
-finishedDoc d DocEmpty rest = (d, Nothing) : rest
-finishedDoc d doc rest | notDocDecl d = (d, Just doc) : rest
+finishedDoc :: Decl -> MaybeDocStringsFast -> [(Decl, MaybeDocStrings)] -> [(Decl, MaybeDocStrings)]
+finishedDoc d doc rest | notDocDecl d = (d, docStringToList doc) : rest
   where
     notDocDecl (L _ (DocD _)) = False
     notDocDecl _              = True
@@ -336,6 +372,7 @@ attachATs exports =
 mkExportItems
   :: ModuleMap
   -> Module			-- this module
+  -> GlobalRdrEnv
   -> [Name]			-- exported names (orig)
   -> [DeclInfo]
   -> Map Name DeclInfo             -- maps local names to declarations
@@ -346,7 +383,7 @@ mkExportItems
   -> InstIfaceMap
   -> ErrMsgGhc [ExportItem Name]
 
-mkExportItems modMap this_mod exported_names decls declMap
+mkExportItems modMap this_mod gre exported_names decls declMap
               opts maybe_exps ignore_all_exports _ instIfaceMap
   | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts
     = everything_local_exported
@@ -357,7 +394,7 @@ mkExportItems modMap this_mod exported_names decls declMap
 --    instances = [ d | d@(L _ decl, _, _) <- decls, isInstD decl ]
 
     everything_local_exported =  -- everything exported
-      return (fullContentsOfThisModule decls)
+      liftErrMsg $ fullContentsOfThisModule gre decls
    
 
     lookupExport (IEVar x) = declWith x
@@ -371,13 +408,22 @@ mkExportItems modMap this_mod exported_names decls declMap
     lookupExport (IEThingAll t)        = declWith t
     lookupExport (IEThingWith t _)     = declWith t
     lookupExport (IEModuleContents m)  = fullContentsOf m
-    lookupExport (IEGroup lev doc)     = return [ ExportGroup lev "" doc ]
-    lookupExport (IEDoc doc)           = return [ ExportDoc doc ] 
-    lookupExport (IEDocNamed str) = do
-      r <- liftErrMsg $ findNamedDoc str [ unL d | (d,_,_) <- decls ]
-      case r of
-        Nothing -> return []
-        Just found -> return [ ExportDoc found ]
+    lookupExport (IEGroup lev docStr)  = liftErrMsg $ do
+      ifDoc (lexParseRnHaddockComment DocSectionComment gre docStr)
+            (\doc -> return [ ExportGroup lev "" doc ])
+    lookupExport (IEDoc docStr)        = liftErrMsg $ do
+      ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr)
+            (\doc -> return [ ExportDoc doc ])
+    lookupExport (IEDocNamed str) = liftErrMsg $ do
+      ifDoc (findNamedDoc str [ unL d | (d,_,_) <- decls ])
+            (\docStr ->
+            ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr)
+                  (\doc -> return [ ExportDoc doc ]))
+
+    ifDoc :: (Monad m) => m (Maybe a) -> (a -> m [b]) -> m [b]
+    ifDoc parse finish = do
+      mbDoc <- parse
+      case mbDoc of Nothing -> return []; Just doc -> finish doc
 
     declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
     declWith t =
@@ -460,7 +506,7 @@ mkExportItems modMap this_mod exported_names decls declMap
     isExported n = n `elem` exported_names
 
     fullContentsOf modname
-	| m == this_mod = return (fullContentsOfThisModule decls)
+	| m == this_mod = liftErrMsg $ fullContentsOfThisModule gre decls
 	| otherwise = 
 	   case Map.lookup m modMap of
 	     Just iface
@@ -509,14 +555,16 @@ mkExportItems modMap this_mod exported_names decls declMap
 -- (For more information, see Trac #69)
 
 
-fullContentsOfThisModule :: [DeclInfo] -> [ExportItem Name]
-fullContentsOfThisModule decls = catMaybes (map mkExportItem decls)
+fullContentsOfThisModule :: GlobalRdrEnv -> [DeclInfo] -> ErrMsgM [ExportItem Name]
+fullContentsOfThisModule gre decls = liftM catMaybes $ mapM mkExportItem decls
   where
-    mkExportItem (L _ (DocD (DocGroup lev doc)), _, _) = Just $ ExportGroup lev "" doc
-    mkExportItem (L _ (DocD (DocCommentNamed _ doc)), _, _)   = Just $ ExportDoc doc
-    mkExportItem (decl, doc, subs) = Just $ ExportDecl decl doc subs []
-
---    mkExportItem _ = Nothing -- TODO: see if this is really needed
+    mkExportItem (L _ (DocD (DocGroup lev docStr)), _, _) = do
+        mbDoc <- lexParseRnHaddockComment DocSectionComment gre docStr
+        return $ fmap (\doc -> ExportGroup lev "" doc) mbDoc
+    mkExportItem (L _ (DocD (DocCommentNamed _ docStr)), _, _) = do
+        mbDoc <- lexParseRnHaddockComment NormalHaddockComment gre docStr
+        return $ fmap ExportDoc mbDoc
+    mkExportItem (decl, doc, subs) = return $ Just $ ExportDecl decl doc subs []
 
 
 -- | Sometimes the declaration we want to export is not the "main" declaration:
@@ -598,7 +646,7 @@ mkVisibleNames exports opts
 
 
 -- | Find a stand-alone documentation comment by its name
-findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe Doc)
+findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
 findNamedDoc name decls = search decls
   where
     search [] = do
diff --git a/src/Haddock/Interface/Lex.x b/src/Haddock/Interface/Lex.x
new file mode 100644
index 00000000..5f93084a
--- /dev/null
+++ b/src/Haddock/Interface/Lex.x
@@ -0,0 +1,171 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2002
+--
+-- This file was modified and integrated into GHC by David Waern 2006
+--
+
+{
+{-# OPTIONS -Wwarn -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
+module Haddock.Interface.Lex (
+	Token(..),
+	tokenise
+ ) where
+
+import Lexer hiding (Token)
+import Parser ( parseIdentifier )
+import StringBuffer
+import RdrName
+import SrcLoc
+import DynFlags
+
+import Data.Char
+import Numeric
+import System.IO.Unsafe
+}
+
+$ws    = $white # \n
+$digit = [0-9]
+$hexdigit = [0-9a-fA-F]
+$special =  [\"\@]
+$alphanum = [A-Za-z0-9]
+$ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
+
+:-
+
+-- beginning of a paragraph
+<0,para> {
+ $ws* \n		;
+ $ws* \>		{ begin birdtrack }
+ $ws* [\*\-]		{ token TokBullet `andBegin` string }
+ $ws* \[		{ token TokDefStart `andBegin` def }
+ $ws* \( $digit+ \) 	{ token TokNumber `andBegin` string }
+ $ws*			{ begin string }		
+}
+
+-- beginning of a line
+<line> {
+  $ws* \>		{ begin birdtrack }
+  $ws* \n		{ token TokPara `andBegin` para }
+  -- Here, we really want to be able to say
+  -- $ws* (\n | <eof>) 	{ token TokPara `andBegin` para}
+  -- because otherwise a trailing line of whitespace will result in 
+  -- a spurious TokString at the end of a docstring.  We don't have <eof>,
+  -- though (NOW I realise what it was for :-).  To get around this, we always
+  -- append \n to the end of a docstring.
+  () 			{ begin string }
+}
+
+<birdtrack> .*	\n?	{ strtokenNL TokBirdTrack `andBegin` line }
+
+<string,def> {
+  $special			{ strtoken $ \s -> TokSpecial (head s) }
+  \<\<.*\>\>                    { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) }
+  \<.*\>			{ strtoken $ \s -> TokURL (init (tail s)) }
+  \#.*\#			{ strtoken $ \s -> TokAName (init (tail s)) }
+  \/ [^\/]* \/                  { strtoken $ \s -> TokEmphasis (init (tail s)) }
+  [\'\`] $ident+ [\'\`]		{ ident }
+  \\ .				{ strtoken (TokString . tail) }
+  "&#" $digit+ \;		{ strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] }
+  "&#" [xX] $hexdigit+ \;	{ strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] }
+  -- allow special characters through if they don't fit one of the previous
+  -- patterns.
+  [\/\'\`\<\#\&\\]			{ strtoken TokString }
+  [^ $special \/ \< \# \n \'\` \& \\ \]]* \n { strtokenNL TokString `andBegin` line }
+  [^ $special \/ \< \# \n \'\` \& \\ \]]+    { strtoken TokString }
+}
+
+<def> {
+  \]				{ token TokDefEnd `andBegin` string }
+}
+
+-- ']' doesn't have any special meaning outside of the [...] at the beginning
+-- of a definition paragraph.
+<string> {
+  \]				{ strtoken TokString }
+}
+
+{
+data Token
+  = TokPara
+  | TokNumber
+  | TokBullet
+  | TokDefStart
+  | TokDefEnd
+  | TokSpecial Char
+  | TokIdent [RdrName]
+  | TokString String
+  | TokURL String
+  | TokPic String
+  | TokEmphasis String
+  | TokAName String
+  | TokBirdTrack String
+--  deriving Show
+
+-- -----------------------------------------------------------------------------
+-- Alex support stuff
+
+type StartCode = Int
+type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token]
+
+type AlexInput = (Char,String)
+
+alexGetChar (_, [])   = Nothing
+alexGetChar (_, c:cs) = Just (c, (c,cs))
+
+alexInputPrevChar (c,_) = c
+
+tokenise :: String -> [Token]
+tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks
+  where go inp@(_,str) sc =
+	  case alexScan inp sc of
+		AlexEOF -> []
+		AlexError _ -> error "lexical error"
+		AlexSkip  inp' _       -> go inp' sc
+		AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc)
+
+-- NB. we add a final \n to the string, (see comment in the beginning of line
+-- production above).
+eofHack str = str++"\n"
+
+andBegin  :: Action -> StartCode -> Action
+andBegin act new_sc = \str _ cont -> act str new_sc cont
+
+token :: Token -> Action
+token t = \_ sc cont -> t : cont sc
+
+strtoken, strtokenNL :: (String -> Token) -> Action
+strtoken t = \str sc cont -> t str : cont sc
+strtokenNL t = \str sc cont -> t (filter (/= '\r') str) : cont sc
+-- ^ We only want LF line endings in our internal doc string format, so we
+-- filter out all CRs.
+
+begin :: StartCode -> Action
+begin sc = \_ _ cont -> cont sc
+
+-- -----------------------------------------------------------------------------
+-- Lex a string as a Haskell identifier
+
+ident :: Action
+ident str sc cont = 
+  case strToHsQNames id of
+	Just names -> TokIdent names : cont sc
+	Nothing -> TokString str : cont sc
+ where id = init (tail str)
+
+strToHsQNames :: String -> Maybe [RdrName]
+strToHsQNames str0 = 
+  let buffer = unsafePerformIO (stringToStringBuffer str0)
+      pstate = mkPState buffer noSrcLoc defaultDynFlags
+      result = unP parseIdentifier pstate 
+  in case result of 
+       POk _ name -> Just [unLoc name] 
+       _ -> Nothing
+}
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
new file mode 100644
index 00000000..04464e77
--- /dev/null
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -0,0 +1,89 @@
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Interface.LexParseRn
+-- Copyright   :  (c) Isaac Dupree 2009,
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+
+module Haddock.Interface.LexParseRn (
+  HaddockCommentType(..),
+  lexParseRnHaddockComment,
+  lexParseRnHaddockCommentList,
+  lexParseRnMbHaddockComment,
+  lexParseRnHaddockModHeader
+  ) where
+
+import Haddock.Types
+
+import Data.Maybe
+
+#if __GLASGOW_HASKELL__ >= 611
+import Haddock.Interface.Lex
+import Haddock.Interface.Parse
+import Haddock.Interface.Rn
+import Haddock.Interface.ParseModuleHeader
+import Haddock.HsDoc
+import FastString
+#endif
+
+import GHC
+import RdrName
+
+data HaddockCommentType = NormalHaddockComment | DocSectionComment
+
+lexParseRnHaddockCommentList :: HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (HsDoc Name))
+lexParseRnHaddockCommentList hty gre docStrs = do
+  docMbs <- mapM (lexParseRnHaddockComment hty gre) docStrs
+  let docs = catMaybes docMbs
+  let doc = foldl docAppend DocEmpty docs
+  case doc of
+    DocEmpty -> return Nothing
+    _ -> return (Just doc)
+
+lexParseRnHaddockComment :: HaddockCommentType ->
+    GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (HsDoc Name))
+#if __GLASGOW_HASKELL__ >= 611
+lexParseRnHaddockComment hty gre (HsDocString fs) = do
+   let str = unpackFS fs
+   let toks = tokenise str
+   let parse = case hty of
+         NormalHaddockComment -> parseHaddockParagraphs
+         DocSectionComment -> parseHaddockString
+   case parse toks of
+     Nothing -> do
+       tell ["doc comment parse failed: "++str]
+       return Nothing
+     Just doc -> do
+       return (Just (rnHsDoc gre doc))
+#else
+lexParseRnHaddockComment _ _ doc = return (Just doc)
+#endif
+
+lexParseRnMbHaddockComment :: HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (HsDoc Name))
+lexParseRnMbHaddockComment _ _ Nothing = return Nothing
+lexParseRnMbHaddockComment hty gre (Just d) = lexParseRnHaddockComment hty gre d
+
+-- yes, you always get a HaddockModInfo though it might be empty
+lexParseRnHaddockModHeader :: GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (HsDoc Name))
+#if __GLASGOW_HASKELL__ >= 611
+lexParseRnHaddockModHeader gre mbStr = do
+  let failure = (emptyHaddockModInfo, Nothing)
+  case mbStr of
+    Nothing -> return failure
+    Just (L _ (HsDocString fs)) -> do
+      let str = unpackFS fs
+      case parseModuleHeader str of
+        Left mess -> do
+          tell ["haddock module header parse failed: " ++ mess]
+          return failure
+        Right (info, doc) ->
+          return (rnHaddockModInfo gre info, Just (rnHsDoc gre doc))
+#else
+lexParseRnHaddockModHeader _ hdr = return hdr
+#endif
+
diff --git a/src/Haddock/Interface/Parse.y b/src/Haddock/Interface/Parse.y
new file mode 100644
index 00000000..f420c8e4
--- /dev/null
+++ b/src/Haddock/Interface/Parse.y
@@ -0,0 +1,106 @@
+{
+{-# OPTIONS -Wwarn -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
+module Haddock.Interface.Parse (
+  parseHaddockParagraphs, 
+  parseHaddockString 
+) where
+
+import Haddock.Interface.Lex
+import Haddock.Types (HsDoc(..))
+import Haddock.HsDoc
+import HsSyn
+import RdrName
+}
+
+%expect 0
+
+%tokentype { Token }
+
+%token	'/'	{ TokSpecial '/' }
+	'@'	{ TokSpecial '@' }
+	'['     { TokDefStart }
+	']'     { TokDefEnd }
+	DQUO 	{ TokSpecial '\"' }
+	URL	{ TokURL $$ }
+	PIC     { TokPic $$ }
+	ANAME	{ TokAName $$ }
+	'/../'  { TokEmphasis $$ }
+	'-'	{ TokBullet }
+	'(n)'	{ TokNumber }
+	'>..'	{ TokBirdTrack $$ }
+	IDENT   { TokIdent $$ }
+	PARA    { TokPara }
+	STRING	{ TokString $$ }
+
+%monad { Maybe }
+
+%name parseHaddockParagraphs  doc
+%name parseHaddockString seq
+
+%%
+
+doc	:: { HsDoc RdrName }
+	: apara PARA doc	{ docAppend $1 $3 }
+	| PARA doc 		{ $2 }
+	| apara			{ $1 }
+	| {- empty -}		{ DocEmpty }
+
+apara	:: { HsDoc RdrName }
+	: ulpara		{ DocUnorderedList [$1] }
+	| olpara		{ DocOrderedList [$1] }
+        | defpara               { DocDefList [$1] }
+	| para			{ $1 }
+
+ulpara  :: { HsDoc RdrName }
+	: '-' para		{ $2 }
+
+olpara  :: { HsDoc RdrName } 
+	: '(n)' para		{ $2 }
+
+defpara :: { (HsDoc RdrName, HsDoc RdrName) }
+	: '[' seq ']' seq	{ ($2, $4) }
+
+para    :: { HsDoc RdrName }
+	: seq			{ docParagraph $1 }
+	| codepara		{ DocCodeBlock $1 }
+
+codepara :: { HsDoc RdrName }
+	: '>..' codepara	{ docAppend (DocString $1) $2 }
+	| '>..'			{ DocString $1 }
+
+seq	:: { HsDoc RdrName }
+	: elem seq		{ docAppend $1 $2 }
+	| elem			{ $1 }
+
+elem	:: { HsDoc RdrName }
+	: elem1			{ $1 }
+	| '@' seq1 '@'		{ DocMonospaced $2 }
+
+seq1	:: { HsDoc RdrName }
+	: PARA seq1             { docAppend (DocString "\n") $2 }
+	| elem1 seq1            { docAppend $1 $2 }
+	| elem1			{ $1 }
+
+elem1	:: { HsDoc RdrName }
+	: STRING		{ DocString $1 }
+	| '/../'                { DocEmphasis (DocString $1) }
+	| URL			{ DocURL $1 }
+	| PIC                   { DocPic $1 }
+	| ANAME			{ DocAName $1 }
+	| IDENT			{ DocIdentifier $1 }
+	| DQUO strings DQUO	{ DocModule $2 }
+
+strings  :: { String }
+	: STRING		{ $1 }
+	| STRING strings	{ $1 ++ $2 }
+
+{
+happyError :: [Token] -> Maybe a
+happyError toks = Nothing
+}
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
new file mode 100644
index 00000000..65bb8dd8
--- /dev/null
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -0,0 +1,158 @@
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Interface.ParseModuleHeader
+-- Copyright   :  (c) David Waern, Isaac Dupree 2009,
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+
+module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
+
+import Haddock.Types
+import Haddock.Interface.Lex
+import Haddock.Interface.Parse
+
+import RdrName
+
+import Data.Char
+
+-- -----------------------------------------------------------------------------
+-- Parsing module headers
+
+-- NB.  The headers must be given in the order Module, Description,
+-- Copyright, License, Maintainer, Stability, Portability, except that
+-- any or all may be omitted.
+parseModuleHeader :: String -> Either String (HaddockModInfo RdrName, HsDoc RdrName)
+parseModuleHeader str0 =
+   let
+      getKey :: String -> String -> (Maybe String,String)
+      getKey key str = case parseKey key str of
+         Nothing -> (Nothing,str)
+         Just (value,rest) -> (Just value,rest)
+
+      (_moduleOpt,str1) = getKey "Module" str0
+      (descriptionOpt,str2) = getKey "Description" str1
+      (_copyrightOpt,str3) = getKey "Copyright" str2
+      (_licenseOpt,str4) = getKey "License" str3
+      (_licenceOpt,str5) = getKey "Licence" str4
+      (maintainerOpt,str6) = getKey "Maintainer" str5
+      (stabilityOpt,str7) = getKey "Stability" str6
+      (portabilityOpt,str8) = getKey "Portability" str7
+
+      description1 :: Either String (Maybe (HsDoc RdrName))
+      description1 = case descriptionOpt of
+         Nothing -> Right Nothing
+         Just description -> case parseHaddockString . tokenise $ description of
+            Nothing -> Left ("Cannot parse Description: " ++ description)
+            Just doc -> Right (Just doc)
+   in
+      case description1 of
+         Left mess -> Left mess
+         Right docOpt -> case parseHaddockParagraphs . tokenise $ str8 of
+           Nothing -> Left "Cannot parse header documentation paragraphs"
+           Just doc -> Right (HaddockModInfo {
+            hmi_description = docOpt,
+            hmi_portability = portabilityOpt,
+            hmi_stability = stabilityOpt,
+            hmi_maintainer = maintainerOpt
+            }, doc)
+
+-- | This function is how we read keys.
+--
+-- all fields in the header are optional and have the form
+--
+-- [spaces1][field name][spaces] ":"
+--    [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
+-- where each [spaces2] should have [spaces1] as a prefix.
+--
+-- Thus for the key "Description",
+--
+-- > Description : this is a
+-- >    rather long
+-- >
+-- >    description
+-- >
+-- > The module comment starts here
+--
+-- the value will be "this is a .. description" and the rest will begin
+-- at "The module comment".
+parseKey :: String -> String -> Maybe (String,String)
+parseKey key toParse0 =
+   do
+      let
+         (spaces0,toParse1) = extractLeadingSpaces toParse0
+
+         indentation = spaces0
+      afterKey0 <- extractPrefix key toParse1
+      let
+         afterKey1 = extractLeadingSpaces afterKey0
+      afterColon0 <- case snd afterKey1 of
+         ':':afterColon -> return afterColon
+         _ -> Nothing
+      let
+         (_,afterColon1) = extractLeadingSpaces afterColon0
+
+      return (scanKey True indentation afterColon1)
+   where
+      scanKey :: Bool -> String -> String -> (String,String)
+      scanKey _       _           [] = ([],[])
+      scanKey isFirst indentation str =
+         let
+            (nextLine,rest1) = extractNextLine str
+
+            accept = isFirst || sufficientIndentation || allSpaces
+
+            sufficientIndentation = case extractPrefix indentation nextLine of
+               Just (c:_) | isSpace c -> True
+               _ -> False
+
+            allSpaces = case extractLeadingSpaces nextLine of
+               (_,[]) -> True
+               _ -> False
+         in
+            if accept
+               then
+                  let
+                     (scanned1,rest2) = scanKey False indentation rest1
+
+                     scanned2 = case scanned1 of
+                        "" -> if allSpaces then "" else nextLine
+                        _ -> nextLine ++ "\n" ++ scanned1
+                  in
+                     (scanned2,rest2)
+               else
+                  ([],str)
+
+      extractLeadingSpaces :: String -> (String,String)
+      extractLeadingSpaces [] = ([],[])
+      extractLeadingSpaces (s@(c:cs))
+         | isSpace c =
+            let
+               (spaces1,cs1) = extractLeadingSpaces cs
+            in
+               (c:spaces1,cs1)
+         | True = ([],s)
+
+      extractNextLine :: String -> (String,String)
+      extractNextLine [] = ([],[])
+      extractNextLine (c:cs)
+         | c == '\n' =
+            ([],cs)
+         | True =
+            let
+               (line,rest) = extractNextLine cs
+            in
+               (c:line,rest)
+
+      -- comparison is case-insensitive.
+      extractPrefix :: String -> String -> Maybe String
+      extractPrefix [] s = Just s
+      extractPrefix _ [] = Nothing
+      extractPrefix (c1:cs1) (c2:cs2)
+         | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
+         | True = Nothing
+
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 8145d63a..b377b4fb 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -144,6 +144,13 @@ renameExportItems = mapM renameExportItem
 renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName))
 renameMaybeDoc = mapM renameDoc
 
+#if __GLASGOW_HASKELL__ >= 611
+renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
+renameLDocHsSyn = return
+#else
+renameLDocHsSyn :: LHsDoc Name -> RnM (LHsDoc DocName)
+renameLDocHsSyn = renameLDoc
+#endif
 
 renameLDoc :: LHsDoc Name -> RnM (LHsDoc DocName)
 renameLDoc = mapM renameDoc
@@ -259,7 +266,7 @@ renameType t = case t of
 
   HsDocTy ty doc -> do
     ty' <- renameLType ty
-    doc' <- renameLDoc doc
+    doc' <- renameLDocHsSyn doc
     return (HsDocTy ty' doc')
 
   _ -> error "renameType"
@@ -363,7 +370,7 @@ renameTyClD d = case d of
       lcontext' <- renameLContext lcontext
       details'  <- renameDetails details
       restype'  <- renameResType restype
-      mbldoc'   <- mapM renameLDoc mbldoc
+      mbldoc'   <- mapM renameLDocHsSyn mbldoc
       return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
                    , con_details = details', con_res = restype', con_doc = mbldoc' })
 
@@ -377,7 +384,7 @@ renameTyClD d = case d of
     renameField (ConDeclField name t doc) = do
       name' <- renameL name
       t'   <- renameLType t
-      doc' <- mapM renameLDoc doc
+      doc' <- mapM renameLDocHsSyn doc
       return (ConDeclField name' t' doc')
 
     renameResType (ResTyH98) = return ResTyH98
diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs
new file mode 100644
index 00000000..c45b5042
--- /dev/null
+++ b/src/Haddock/Interface/Rn.hs
@@ -0,0 +1,82 @@
+
+module Haddock.Interface.Rn ( rnHsDoc, rnHaddockModInfo ) where
+
+import Haddock.Types
+
+import RnEnv       ( dataTcOccs )
+
+import RdrName     ( RdrName, gre_name, GlobalRdrEnv, lookupGRE_RdrName )
+import Name        ( Name )
+import Outputable  ( ppr, defaultUserStyle )
+
+rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name
+rnHaddockModInfo gre (HaddockModInfo desc port stab maint) =
+  HaddockModInfo (fmap (rnHsDoc gre) desc) port stab maint
+
+ids2string :: [RdrName] -> String
+ids2string []    = []
+ids2string (x:_) = show $ ppr x defaultUserStyle
+
+data Id x = Id {unId::x}
+instance Monad Id where (Id v)>>=f = f v; return = Id
+
+rnHsDoc :: GlobalRdrEnv -> HsDoc RdrName -> HsDoc Name
+rnHsDoc gre = unId . do_rn
+  where
+ do_rn doc_to_rn = case doc_to_rn of 
+  
+  DocEmpty -> return DocEmpty
+
+  DocAppend a b -> do
+    a' <- do_rn a 
+    b' <- do_rn b
+    return (DocAppend a' b')
+
+  DocString str -> return (DocString str)
+
+  DocParagraph doc -> do
+    doc' <- do_rn doc
+    return (DocParagraph doc')
+
+  DocIdentifier ids -> do
+    let choices = concatMap dataTcOccs ids
+    let gres = concatMap (\rdrName ->
+                 map gre_name (lookupGRE_RdrName rdrName gre)) choices
+    case gres of
+      [] -> return (DocString (ids2string ids))
+      ids' -> return (DocIdentifier ids')
+
+  DocModule str -> return (DocModule str)
+
+  DocEmphasis doc -> do
+    doc' <- do_rn doc
+    return (DocEmphasis doc')
+
+  DocMonospaced doc -> do
+    doc' <- do_rn doc 
+    return (DocMonospaced doc')
+ 
+  DocUnorderedList docs -> do
+    docs' <- mapM do_rn docs
+    return (DocUnorderedList docs')
+
+  DocOrderedList docs -> do
+    docs' <- mapM do_rn docs
+    return (DocOrderedList docs')
+
+  DocDefList list -> do
+    list' <- mapM (\(a,b) -> do
+      a' <- do_rn a
+      b' <- do_rn b
+      return (a', b')) list
+    return (DocDefList list')
+
+  DocCodeBlock doc -> do
+    doc' <- do_rn doc
+    return (DocCodeBlock doc')
+
+  DocURL str -> return (DocURL str)
+
+  DocPic str -> return (DocPic str)
+
+  DocAName str -> return (DocAName str)