1 files changed, 52 insertions, 50 deletions

diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index f70c5953..3ad9719e 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -1,4 +1,6 @@
------------------------------------------------------------------------------
+{-# OPTIONS_GHC -Wwarn #-}
+{-# LANGUAGE BangPatterns #-}
+  -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.LexParseRn
 -- Copyright   :  (c) Isaac Dupree 2009,
@@ -9,11 +11,10 @@
 -- Portability :  portable
 -----------------------------------------------------------------------------
 module Haddock.Interface.LexParseRn
-  ( HaddockCommentType(..)
-  , lexParseRnHaddockComment
-  , lexParseRnHaddockCommentList
-  , lexParseRnMbHaddockComment
-  , lexParseRnHaddockModHeader
+  ( processDocString
+  , processDocStringParas
+  , processDocStrings
+  , processModuleHeader
   ) where
 
 
@@ -24,6 +25,7 @@ import Haddock.Interface.ParseModuleHeader
 import Haddock.Doc
 
 import Control.Applicative
+import Data.List
 import Data.Maybe
 import FastString
 import GHC
@@ -33,64 +35,62 @@ import RdrName
 import RnEnv
 
 
-data HaddockCommentType = NormalHaddockComment | DocSectionComment
-
-
-lexParseRnHaddockCommentList :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
-lexParseRnHaddockCommentList dflags hty gre docStrs = do
-  docMbs <- mapM (lexParseRnHaddockComment dflags hty gre) docStrs
-  let docs = catMaybes docMbs
-  let doc = foldl docAppend DocEmpty docs
+processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
+processDocStrings dflags gre strs = do
+  docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs
+  let doc = foldl' docAppend DocEmpty docs
   case doc of
     DocEmpty -> return Nothing
     _ -> return (Just doc)
 
 
-lexParseRnHaddockComment :: DynFlags -> HaddockCommentType ->
-    GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
-lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
+processDocStringParas = process parseParas
+
+
+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
+processDocString = process parseString
+
+process :: ([LToken] -> Maybe (Doc RdrName))
+        -> DynFlags
+        -> GlobalRdrEnv
+        -> HsDocString
+        -> ErrMsgM (Maybe (Doc Name))
+process parse dflags gre (HsDocString fs) = do
    let str = unpackFS fs
-   let toks = tokenise dflags str (0,0) -- TODO: real position
-   let parse = case hty of
-         NormalHaddockComment -> parseParas
-         DocSectionComment -> parseString
+   let toks = tokenise dflags str (0,0)  -- TODO: real position
    case parse toks of
      Nothing -> do
-       tell ["doc comment parse failed: "++str]
+       tell [ "doc comment parse failed: " ++ str ]
        return Nothing
-     Just doc -> return (Just (rename gre doc))
-
+     Just doc -> return (Just (rename dflags gre doc))
 
-lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name))
-lexParseRnMbHaddockComment _ _ _ Nothing = return Nothing
-lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment dflags hty gre d
 
+processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
+                    -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
+processModuleHeader dflags gre safety mayStr = do
+  (hmi, doc) <-
+    case mayStr of
 
--- yes, you always get a HaddockModInfo though it might be empty
-lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
-lexParseRnHaddockModHeader dflags gre mbStr = do
-  (hmi, docn) <-
-    case mbStr of
       Nothing -> return failure
       Just (L _ (HsDocString fs)) -> do
         let str = unpackFS fs
         case parseModuleHeader dflags str of
-          Left mess -> do
-            tell ["haddock module header parse failed: " ++ mess]
+          Left msg -> do
+            tell ["haddock module header parse failed: " ++ msg]
             return failure
-          Right (info, doc) -> return (renameHmi gre info, Just (rename gre doc))
-  return (hmi { hmi_safety = safety }, docn)
+          Right (hmi, doc) -> do
+            let !descr = rename dflags gre <$> hmi_description hmi
+                hmi' = hmi { hmi_description = descr }
+                doc' = rename dflags gre doc
+            return (hmi', Just doc')
+  return (hmi { hmi_safety = Just $ showPpr dflags safety }, doc)
   where
-    safety  = Just $ showPpr $ safeHaskell dflags
     failure = (emptyHaddockModInfo, Nothing)
 
 
-renameHmi :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name
-renameHmi gre hmi = hmi { hmi_description = rename gre <$> hmi_description hmi }
-
-
-rename :: GlobalRdrEnv -> Doc RdrName -> Doc Name
-rename gre = rn
+rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
+rename dflags gre = rn
   where
     rn d = case d of
       DocAppend a b -> DocAppend (rn a) (rn b)
@@ -101,13 +101,15 @@ rename gre = rn
         case names of
           [] ->
             case choices of
-              [] -> DocMonospaced (DocString (showSDoc $ ppr x))
-              [a] -> outOfScope a
-              a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope b
+              [] -> DocMonospaced (DocString (showPpr dflags x))
+              [a] -> outOfScope dflags a
+              a:b:_ | isRdrTc a -> outOfScope dflags a
+                    | otherwise -> outOfScope dflags b
           [a] -> DocIdentifier a
           a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
               -- If an id can refer to multiple things, we give precedence to type
               -- constructors.
+      DocWarning doc -> DocWarning (rn doc)
       DocEmphasis doc -> DocEmphasis (rn doc)
       DocMonospaced doc -> DocMonospaced (rn doc)
       DocUnorderedList docs -> DocUnorderedList (map rn docs)
@@ -116,7 +118,7 @@ rename gre = rn
       DocCodeBlock doc -> DocCodeBlock (rn doc)
       DocIdentifierUnchecked x -> DocIdentifierUnchecked x
       DocModule str -> DocModule str
-      DocURL str -> DocURL str
+      DocHyperlink l -> DocHyperlink l
       DocPic str -> DocPic str
       DocAName str -> DocAName str
       DocExamples e -> DocExamples e
@@ -124,12 +126,12 @@ rename gre = rn
       DocString str -> DocString str
 
 
-outOfScope :: RdrName -> Doc a
-outOfScope x =
+outOfScope :: DynFlags -> RdrName -> Doc a
+outOfScope dflags x =
   case x of
     Unqual occ -> monospaced occ
     Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)
     Orig _ occ -> monospaced occ
     Exact name -> monospaced name  -- Shouldn't happen since x is out of scope
   where
-    monospaced a = DocMonospaced (DocString (showSDoc $ ppr a))
+    monospaced a = DocMonospaced (DocString (showPpr dflags a))