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

13 files changed, 867 insertions, 60 deletions

diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index e0202ed6..62b370bb 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -23,12 +23,14 @@ import Control.Arrow
 import Data.Foldable hiding (concatMap)
 import Data.Traversable
 
-import HsSyn
-import SrcLoc
 import Outputable
 import Name
 import Packages
 import Module
+import RdrName (GlobalRdrEnv)
+import HscTypes
+import LazyUniqFM
+import GHC
 
 
 moduleString :: Module -> String
@@ -56,6 +58,13 @@ mkModuleNoPackage :: String -> Module
 mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str)
 
 
+lookupLoadedHomeModuleGRE  :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv)
+lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env ->
+  case lookupUFM (hsc_HPT hsc_env) mod_name of
+    Just mod_info      -> return (mi_globals (hm_iface mod_info))
+    _not_a_home_module -> return Nothing
+
+
 instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where
   ppr m = ppr (Map.toList m)
 
diff --git a/src/Haddock/HsDoc.hs b/src/Haddock/HsDoc.hs
new file mode 100644
index 00000000..489873a7
--- /dev/null
+++ b/src/Haddock/HsDoc.hs
@@ -0,0 +1,73 @@
+module Haddock.HsDoc (
+  docAppend,
+  docParagraph
+  ) where
+
+#if __GLASGOW_HASKELL__ <= 610
+
+import HsDoc -- just re-export
+
+#else
+
+import Haddock.Types
+
+import Data.Char (isSpace)
+
+
+-- used to make parsing easier; we group the list items later
+docAppend :: HsDoc id -> HsDoc id -> HsDoc id
+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 (DocDefList ds1) (DocDefList ds2)
+  = DocDefList (ds1++ds2)
+docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d)
+  = DocAppend (DocDefList (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 :: HsDoc id -> HsDoc id
+docParagraph (DocMonospaced p)
+  = DocCodeBlock (docCodeBlock p)
+docParagraph (DocAppend (DocString s1) (DocMonospaced p))
+  | all isSpace s1
+  = DocCodeBlock (docCodeBlock p)
+docParagraph (DocAppend (DocString s1)
+    (DocAppend (DocMonospaced p) (DocString s2)))
+  | all isSpace s1 && all isSpace s2
+  = DocCodeBlock (docCodeBlock p)
+docParagraph (DocAppend (DocMonospaced p) (DocString s2))
+  | all isSpace s2
+  = DocCodeBlock (docCodeBlock p)
+docParagraph p
+  = DocParagraph p
+
+
+-- Drop trailing whitespace from @..@ code blocks.  Otherwise this:
+--
+--    -- @
+--    -- foo
+--    -- @
+--
+-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML
+-- gives an extra vertical space after the code block.  The single space
+-- on the final line seems to trigger the extra vertical space.
+--
+docCodeBlock :: HsDoc id -> HsDoc id
+docCodeBlock (DocString s)
+  = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)
+docCodeBlock (DocAppend l r)
+  = DocAppend l (docCodeBlock r)
+docCodeBlock d = d
+
+#endif
+
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index 7bcd91d6..7ba2467e 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -180,8 +180,7 @@ mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule {
   ghcModule         = mdl,
   ghcFilename       = file,
   ghcMbDocOpts      = mbOpts,
-  ghcHaddockModInfo = info,
-  ghcMbDoc          = mbDoc,
+  ghcMbDocHdr       = mbDocHdr,
   ghcGroup          = group_,
   ghcMbExports      = mbExports,
   ghcExportedNames  = modInfoExports modInfo,
@@ -191,7 +190,12 @@ mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule {
 }
   where
     mbOpts = haddockOptions dynflags
+#if __GLASGOW_HASKELL__ >= 611
+    (group_, _, mbExports, mbDocHdr) = renamed
+#else
     (group_, _, mbExports, mbDoc, info) = renamed
+    mbDocHdr = (info, mbDoc)
+#endif
     (_, renamed, _, modInfo) = checkedMod
 
 
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)
diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs
index d76f9883..d6054b66 100644
--- a/src/Haddock/ModuleTree.hs
+++ b/src/Haddock/ModuleTree.hs
@@ -12,7 +12,9 @@
 
 module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
 
-import GHC           ( HsDoc, Name )
+import Haddock.Types ( HsDoc )
+
+import GHC           ( Name )
 import Module        ( Module, moduleNameString, moduleName, modulePackageId )
 #if __GLASGOW_HASKELL__ >= 609
 import Module (packageIdString)
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index c860976f..494699e5 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -15,7 +15,16 @@
 -- important types are defined here, like 'Interface' and 'DocName'.
 -----------------------------------------------------------------------------
 
-module Haddock.Types where
+module Haddock.Types (
+  module Haddock.Types
+-- avoid duplicate-export warnings, use the conditional to only
+-- mention things not defined in this module:
+#if __GLASGOW_HASKELL__ >= 611
+  , HsDocString, LHsDocString
+#else
+  , HsDoc(..), LHsDoc, HaddockModInfo(..), emptyHaddockModInfo
+#endif
+ ) where
 
 
 import Control.Exception
@@ -29,6 +38,10 @@ import Name
 type Decl = LHsDecl Name
 type Doc  = HsDoc Name
 
+#if __GLASGOW_HASKELL__ <= 610
+type HsDocString = HsDoc Name
+type LHsDocString = Located HsDocString
+#endif
 
 -- | A declaration that may have documentation, including its subordinates,
 -- which may also have documentation
@@ -113,6 +126,11 @@ type InstIfaceMap  = Map Module InstalledInterface
 type DocMap        = Map Name (HsDoc DocName)
 type LinkEnv       = Map Name Module
 
+#if __GLASGOW_HASKELL__ >= 611
+type GhcDocHdr = Maybe LHsDocString
+#else
+type GhcDocHdr = (HaddockModInfo Name, Maybe (HsDoc Name))
+#endif
 
 -- | This structure holds the module information we get from GHC's 
 -- type checking phase
@@ -120,8 +138,7 @@ data GhcModule = GhcModule {
    ghcModule         :: Module,
    ghcFilename       :: FilePath,
    ghcMbDocOpts      :: Maybe String,
-   ghcHaddockModInfo :: HaddockModInfo Name,
-   ghcMbDoc          :: Maybe (HsDoc Name),
+   ghcMbDocHdr       :: GhcDocHdr,
    ghcGroup          :: HsGroup Name,
    ghcMbExports      :: Maybe [LIE Name],
    ghcExportedNames  :: [Name],
@@ -239,6 +256,28 @@ toInstalledIface interface = InstalledInterface {
 }
 
 
+#if __GLASGOW_HASKELL__ >= 611
+data HsDoc id
+  = DocEmpty
+  | DocAppend (HsDoc id) (HsDoc id)
+  | DocString String
+  | DocParagraph (HsDoc id)
+  | DocIdentifier [id]
+  | DocModule String
+  | DocEmphasis (HsDoc id)
+  | DocMonospaced (HsDoc id)
+  | DocUnorderedList [HsDoc id]
+  | DocOrderedList [HsDoc id]
+  | DocDefList [(HsDoc id, HsDoc id)]
+  | DocCodeBlock (HsDoc id)
+  | DocURL String
+  | DocPic String
+  | DocAName String
+  deriving (Eq, Show)
+
+type LHsDoc id = Located (HsDoc id)
+#endif
+
 data DocMarkup id a = Markup {
   markupEmpty         :: a,
   markupString        :: String -> a,
@@ -257,6 +296,23 @@ data DocMarkup id a = Markup {
   markupPic           :: String -> a
 }
 
+#if __GLASGOW_HASKELL__ >= 611
+data HaddockModInfo name = HaddockModInfo {
+        hmi_description :: Maybe (HsDoc name),
+        hmi_portability :: Maybe String,
+        hmi_stability   :: Maybe String,
+        hmi_maintainer  :: Maybe String
+}
+
+emptyHaddockModInfo :: HaddockModInfo a
+emptyHaddockModInfo = HaddockModInfo {
+        hmi_description = Nothing,
+        hmi_portability = Nothing,
+        hmi_stability   = Nothing,
+        hmi_maintainer  = Nothing
+}
+#endif
+
 
 -- A monad which collects error messages, locally defined to avoid a dep on mtl
 
diff --git a/src/Main.hs b/src/Main.hs
index 465ebfd8..8d6db877 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -22,6 +22,8 @@ module Main (main) where
 import Haddock.Backends.Html
 import Haddock.Backends.Hoogle
 import Haddock.Interface
+import Haddock.Interface.Lex
+import Haddock.Interface.Parse
 import Haddock.Types
 import Haddock.Version
 import Haddock.InterfaceFile
@@ -469,9 +471,9 @@ getPrologue flags =
     [] -> return Nothing
     [filename] -> do
       str <- readFile filename
-      case parseHaddockComment str of
-        Left err -> throwE err
-        Right doc -> return (Just doc)
+      case parseHaddockParagraphs (tokenise str) of
+        Nothing -> throwE "parsing haddock prologue failed"
+        Just doc -> return (Just doc)
     _otherwise -> throwE "multiple -p/--prologue options"