Cleanup.

3 files changed, 79 insertions, 123 deletions

diff --git a/haddock.cabal b/haddock.cabal
index 1180cad0..81d64756 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -111,7 +111,6 @@ executable haddock
     Haddock.Interface.Create
     Haddock.Interface.ExtractFnArgDocs
     Haddock.Interface.AttachInstances
-    Haddock.Interface.Rn
     Haddock.Interface.LexParseRn
     Haddock.Interface.ParseModuleHeader
     Haddock.Lex
@@ -175,7 +174,6 @@ library
     Haddock.Interface.Create
     Haddock.Interface.ExtractFnArgDocs
     Haddock.Interface.AttachInstances
-    Haddock.Interface.Rn
     Haddock.Interface.LexParseRn
     Haddock.Interface.ParseModuleHeader
     Haddock.Lex
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index d013ca27..f70c5953 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -8,28 +8,34 @@
 -- Stability   :  experimental
 -- Portability :  portable
 -----------------------------------------------------------------------------
-module Haddock.Interface.LexParseRn (
-  HaddockCommentType(..),
-  lexParseRnHaddockComment,
-  lexParseRnHaddockCommentList,
-  lexParseRnMbHaddockComment,
-  lexParseRnHaddockModHeader
+module Haddock.Interface.LexParseRn
+  ( HaddockCommentType(..)
+  , lexParseRnHaddockComment
+  , lexParseRnHaddockCommentList
+  , lexParseRnMbHaddockComment
+  , lexParseRnHaddockModHeader
   ) where
 
+
 import Haddock.Types
 import Haddock.Lex
 import Haddock.Parse
-import Haddock.Interface.Rn
 import Haddock.Interface.ParseModuleHeader
 import Haddock.Doc
+
+import Control.Applicative
 import Data.Maybe
 import FastString
 import GHC
-import Outputable ( showPpr )
+import Name
+import Outputable
 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
@@ -39,6 +45,7 @@ lexParseRnHaddockCommentList dflags hty gre docStrs = do
     DocEmpty -> return Nothing
     _ -> return (Just doc)
 
+
 lexParseRnHaddockComment :: DynFlags -> HaddockCommentType ->
     GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
 lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do
@@ -51,27 +58,78 @@ lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do
      Nothing -> do
        tell ["doc comment parse failed: "++str]
        return Nothing
-     Just doc -> return (Just (rnDoc gre doc))
+     Just doc -> return (Just (rename 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
 
+
 -- 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
-    (hmod, 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]
-                return failure
-              Right (info, doc) ->
-                return (rnHaddockModInfo gre info, Just (rnDoc gre doc))
-    return (hmod { hmi_safety = safety }, docn)
-
+  (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]
+            return failure
+          Right (info, doc) -> return (renameHmi gre info, Just (rename gre doc))
+  return (hmi { hmi_safety = safety }, docn)
   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
+  where
+    rn d = case d of
+      DocAppend a b -> DocAppend (rn a) (rn b)
+      DocParagraph doc -> DocParagraph (rn doc)
+      DocIdentifier x -> do
+        let choices = dataTcOccs x
+        let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
+        case names of
+          [] ->
+            case choices of
+              [] -> DocMonospaced (DocString (showSDoc $ ppr x))
+              [a] -> outOfScope a
+              a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope 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.
+      DocEmphasis doc -> DocEmphasis (rn doc)
+      DocMonospaced doc -> DocMonospaced (rn doc)
+      DocUnorderedList docs -> DocUnorderedList (map rn docs)
+      DocOrderedList docs -> DocOrderedList (map rn docs)
+      DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
+      DocCodeBlock doc -> DocCodeBlock (rn doc)
+      DocIdentifierUnchecked x -> DocIdentifierUnchecked x
+      DocModule str -> DocModule str
+      DocURL str -> DocURL str
+      DocPic str -> DocPic str
+      DocAName str -> DocAName str
+      DocExamples e -> DocExamples e
+      DocEmpty -> DocEmpty
+      DocString str -> DocString str
+
+
+outOfScope :: RdrName -> Doc a
+outOfScope 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))
diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs
deleted file mode 100644
index 0b5efe4b..00000000
--- a/src/Haddock/Interface/Rn.hs
+++ /dev/null
@@ -1,100 +0,0 @@
-module Haddock.Interface.Rn ( rnDoc, rnHaddockModInfo ) where
-
-import Haddock.Types
-
-import RnEnv       ( dataTcOccs )
-
-import RdrName
-import Name        ( Name, isTyConName )
-import Outputable  ( ppr, showSDoc )
-
-rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name
-rnHaddockModInfo gre hmod =
-  let desc = hmi_description hmod
-  in hmod { hmi_description = fmap (rnDoc gre) desc }
-
-data Id x = Id {unId::x}
-instance Monad Id where (Id v)>>=f = f v; return = Id
-
-rnDoc :: GlobalRdrEnv -> Doc RdrName -> Doc Name
-rnDoc 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 x -> do
-    let choices = dataTcOccs x
-    let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
-    return $
-      case names of
-        [] ->
-          case choices of
-            [] -> DocMonospaced (DocString (showSDoc $ ppr x))
-            [a] -> outOfScope a
-            a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope 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.
-
-  DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x)
-
-  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)
-
-  DocExamples e -> return (DocExamples e)
-
-
-outOfScope :: RdrName -> Doc a
-outOfScope 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))