Clean up some code from last SoC project.

2 files changed, 78 insertions, 75 deletions

diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index cac3eac2..737547fd 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -28,7 +28,7 @@ import Data.Monoid
 import Data.Ord
 import Control.Applicative
 import Control.Monad
-import qualified Data.Traversable as Traversable
+import qualified Data.Traversable as T
 
 import GHC hiding (flags)
 import HscTypes
@@ -72,7 +72,7 @@ createInterface tm flags modMap instIfaceMap = do
         | otherwise = opts0
 
   (info, mbDoc) <- do
-    (i, d) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader
+    (i, d) <- liftErrMsg $ processModuleHeader dflags gre mayDocHeader
     return (i, addModuleWarning warnings d)
 
   let declsWithDocs = topDecls group_
@@ -193,13 +193,16 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
 
 
 --------------------------------------------------------------------------------
--- Declarations
+-- Maps
 --------------------------------------------------------------------------------
 
 
 type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap)
 
 
+-- | Create 'Maps' by looping through the declarations. For each declaration,
+-- find its names, its subordinates, and its doc strings. Process doc strings
+-- into 'Doc's.
 mkMaps :: DynFlags
        -> GlobalRdrEnv
        -> [Instance]
@@ -207,38 +210,36 @@ mkMaps :: DynFlags
        -> [(LHsDecl Name, [HsDocString])]
        -> ErrMsgM Maps
 mkMaps dflags gre instances exports decls = do
-  (dm, am, sm, cm) <- unzip4 <$> mapM mappings decls
-  let f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
-      f = M.fromListWith (<>) . concat
-  return (f dm, f am, f sm, f cm)
+  (a, b, c, d) <- unzip4 <$> mapM mappings decls
+  return (f a, f b, f c, f d)
   where
-    mappings (ldecl@(L _ decl), docs) = do
-      doc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs
-      argDocs <- fmap (M.mapMaybe id) $ Traversable.forM (typeDocs decl) $
-                   lexParseRnHaddockComment dflags NormalHaddockComment gre
-
+    f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
+    f = M.fromListWith (<>) . concat
+
+    mappings (ldecl, docStrs) = do
+      let decl = unLoc ldecl
+      let declDoc strs m = do
+            doc <- processDocStrings dflags gre strs
+            m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m
+            return (doc, m')
+      (doc, args) <- declDoc docStrs (typeDocs decl)
       let subs = [ s | s@(n, _, _) <- subordinates decl, n `elem` exports ]
-
-      (subDocs, subArgMap) <- unzip <$> (forM subs $ \(n, mbSubDocStr, subFnArgsDocStr) -> do
-        mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr
-        subFnArgsDoc <- fmap (M.mapMaybe id) $ Traversable.forM subFnArgsDocStr $
-                          lexParseRnHaddockComment dflags NormalHaddockComment gre
-        return ((n, mbSubDoc), (n, subFnArgsDoc)))
-
-      let names = case decl of
-              -- See note [2].
-            InstD (InstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap)
-            _ -> filter (`elem` exports) (getMainDeclBinder decl)
-
-      let subNames = map fst subDocs
-          dm = [ (n, d) | (n, Just d) <- (zip names (repeat doc)) ++ subDocs ]
-          am = [ (n, argDocs) | n <- names ] ++ subArgMap
-          sm = [ (n, subNames) | n <- names ]
-          cm = [ (n, [ldecl]) | n <- names ++ subNames ]
+      (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs
+      let ns = names decl
+          subNs = [ n | (n, _, _) <- subs ]
+          dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
+          am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
+          sm = [ (n, subNs) | n <- ns ]
+          cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
       return (dm, am, sm, cm)
 
+    instanceMap :: Map SrcSpan Name
     instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
 
+    names :: HsDecl Name -> [Name]
+    names (InstD (InstDecl (L l _) _ _ _)) = maybeToList (M.lookup l instanceMap)  -- See note [2].
+    names decl = filter (`elem` exports) (getMainDeclBinder decl)
+
 
 -- Note [2]:
 ------------
@@ -249,6 +250,12 @@ mkMaps dflags gre instances exports decls = do
 -- with InstDecls).
 
 
+--------------------------------------------------------------------------------
+-- Declarations
+--------------------------------------------------------------------------------
+
+
+-- | Get all subordinate declarations inside a declaration, and their docs.
 subordinates :: HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
 subordinates (TyClD decl)
   | isClassDecl decl = classSubs
@@ -446,15 +453,15 @@ mkExportItems
     lookupExport (IEModuleContents m)  =
       moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps
     lookupExport (IEGroup lev docStr)  = liftErrMsg $
-      ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr)
+      ifDoc (processDocString dflags gre docStr)
             (\doc -> return [ ExportGroup lev "" doc ])
     lookupExport (IEDoc docStr)        = liftErrMsg $
-      ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
+      ifDoc (processDocStringParas dflags gre docStr)
             (\doc -> return [ ExportDoc doc ])
     lookupExport (IEDocNamed str)      = liftErrMsg $
       ifDoc (findNamedDoc str [ unL d | d <- decls ])
             (\docStr ->
-            ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
+            ifDoc (processDocStringParas dflags gre docStr)
                   (\doc -> return [ ExportDoc doc ]))
 
 
@@ -656,10 +663,10 @@ fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls =
         f x xs = x : xs
 
     mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
-      mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr
+      mbDoc <- liftErrMsg $ processDocString dflags gre docStr
       return $ fmap (ExportGroup lev "") mbDoc
     mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
-      mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags NormalHaddockComment gre docStr
+      mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr
       return $ fmap ExportDoc mbDoc
     mkExportItem (L _ (ValD d))
       | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index ebd2b8fc..61f5d6ac 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+  -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.LexParseRn
 -- Copyright   :  (c) Isaac Dupree 2009,
@@ -9,11 +9,10 @@
 -- Portability :  portable
 -----------------------------------------------------------------------------
 module Haddock.Interface.LexParseRn
-  ( HaddockCommentType(..)
-  , lexParseRnHaddockComment
-  , lexParseRnHaddockCommentList
-  , lexParseRnMbHaddockComment
-  , lexParseRnHaddockModHeader
+  ( processDocString
+  , processDocStringParas
+  , processDocStrings
+  , processModuleHeader
   ) where
 
 
@@ -24,6 +23,7 @@ import Haddock.Interface.ParseModuleHeader
 import Haddock.Doc
 
 import Control.Applicative
+import Data.List
 import Data.Maybe
 import FastString
 import GHC
@@ -33,62 +33,58 @@ 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))
 
 
-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
-  (hmi, docn) <-
-    case mbStr of
+processModuleHeader :: DynFlags -> GlobalRdrEnv -> Maybe LHsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
+processModuleHeader dflags gre mayStr = do
+  (hmi, doc) <-
+    case mayStr 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 hmi' = hmi { hmi_description = rename gre <$> hmi_description hmi }
+                doc' = rename gre doc
+            return (hmi', Just doc')
+  let safety = Just $ showPpr $ safeHaskell dflags
+  return (hmi { hmi_safety = 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
   where