Refactoring: Make doc renaming monadic

This allows us to later throw warnings if can't find an identifier

3 files changed, 116 insertions, 95 deletions

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 89f7f71b..87cdb01f 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -30,6 +30,7 @@ import Haddock.Backends.Hyperlinker.Types
 import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
 import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
 
+import Data.Bitraversable
 import qualified Data.ByteString as BS
 import qualified Data.Map as M
 import Data.Map (Map)
@@ -38,8 +39,6 @@ import Data.Maybe
 import Data.Monoid
 import Data.Ord
 import Control.Applicative
-import Control.Arrow (second)
-import Control.DeepSeq (force)
 import Control.Exception (evaluate)
 import Control.Monad
 import Data.Traversable
@@ -109,7 +108,6 @@ createInterface tm flags modMap instIfaceMap = do
       exports
         | OptIgnoreExports `elem` opts = Nothing
         | otherwise = exports0
-      warningMap = mkWarningMap dflags warnings gre exportedNames
 
       localBundledPatSyns :: Map Name [Name]
       localBundledPatSyns =
@@ -134,8 +132,10 @@ createInterface tm flags modMap instIfaceMap = do
       -- Locations of all TH splices
       splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
 
-      maps@(!docMap, !argMap, !subMap, !declMap, _) =
-        mkMaps dflags gre localInsts declsWithDocs
+  warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
+
+  maps@(!docMap, !argMap, !subMap, !declMap, _) <-
+    liftErrMsg (mkMaps dflags gre localInsts declsWithDocs)
 
   let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
 
@@ -161,7 +161,8 @@ createInterface tm flags modMap instIfaceMap = do
 
   let !aliases =
         mkAliasMap dflags $ tm_renamed_source tm
-      modWarn = moduleWarning dflags gre warnings
+
+  modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
 
   tokenizedSrc <- mkMaybeTokenizedSrc flags tm
 
@@ -245,27 +246,29 @@ lookupModuleDyn dflags Nothing mdlName =
 -- Warnings
 -------------------------------------------------------------------------------
 
-mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
+mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
 mkWarningMap dflags warnings gre exps = case warnings of
-  NoWarnings  -> M.empty
-  WarnAll _   -> M.empty
+  NoWarnings  -> pure M.empty
+  WarnAll _   -> pure M.empty
   WarnSome ws ->
-    let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+    let ws' = [ (n, w)
+              | (occ, w) <- ws
+              , elt <- lookupGlobalRdrEnv gre occ
               , let n = gre_name elt, n `elem` exps ]
-    in M.fromList $ map (second $ parseWarning dflags gre) ws'
+    in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws'
 
-moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name)
-moduleWarning _ _ NoWarnings = Nothing
-moduleWarning _ _ (WarnSome _) = Nothing
-moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
+moduleWarning _ _ NoWarnings = pure Nothing
+moduleWarning _ _ (WarnSome _) = pure Nothing
+moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w
 
-parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
-parseWarning dflags gre w = force $ case w of
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
+parseWarning dflags gre w = case w of
   DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg)
   WarningTxt    _ msg -> format "Warning: "    (concatFS $ map (sl_fs . unLoc) msg)
   where
     format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
-                  . processDocString dflags gre $ HsDocString xs
+                  <$> processDocString dflags gre (HsDocString xs)
 
 
 -------------------------------------------------------------------------------
@@ -313,16 +316,15 @@ mkMaps :: DynFlags
        -> GlobalRdrEnv
        -> [Name]
        -> [(LHsDecl Name, [HsDocString])]
-       -> Maps
-mkMaps dflags gre instances decls =
-  let
-    (a, b, c, d) = unzip4 $ map mappings decls
-  in ( f' (map (nubByName fst) a)
-     , f  (filterMapping (not . M.null) b)
-     , f  (filterMapping (not . null) c)
-     , f  (filterMapping (not . null) d)
-     , instanceMap
-     )
+       -> ErrMsgM Maps
+mkMaps dflags gre instances decls = do
+  (a, b, c, d) <- unzip4 <$> traverse mappings decls
+  pure ( f' (map (nubByName fst) a)
+       , f  (filterMapping (not . M.null) b)
+       , f  (filterMapping (not . null) c)
+       , f  (filterMapping (not . null) d)
+       , instanceMap
+       )
   where
     f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
     f = M.fromListWith (<>) . concat
@@ -334,35 +336,42 @@ mkMaps dflags gre instances decls =
     filterMapping p = map (filter (p . snd))
 
     mappings :: (LHsDecl Name, [HsDocString])
-             -> ( [(Name, MDoc Name)]
-                , [(Name, Map Int (MDoc Name))]
-                , [(Name, [Name])]
-                , [(Name,  [LHsDecl Name])]
-                )
-    mappings (ldecl, docStrs) =
+             -> ErrMsgM ( [(Name, MDoc Name)]
+                        , [(Name, Map Int (MDoc Name))]
+                        , [(Name, [Name])]
+                        , [(Name,  [LHsDecl Name])]
+                        )
+    mappings (ldecl, docStrs) = do
       let L l decl = ldecl
           declDoc :: [HsDocString] -> Map Int HsDocString
-                  -> (Maybe (MDoc Name), Map Int (MDoc Name))
-          declDoc strs m =
-            let doc' = processDocStrings dflags gre strs
-                m' = M.map (processDocStringParas dflags gre) m
-            in (doc', m')
-          (doc, args) = declDoc docStrs (typeDocs decl)
+                  -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name))
+          declDoc strs m = do
+            doc' <- processDocStrings dflags gre strs
+            m'   <- traverse (processDocStringParas dflags gre) m
+            pure (doc', m')
+
+      (doc, args) <- declDoc docStrs (typeDocs decl)
+
+      let
           subs :: [(Name, [HsDocString], Map Int HsDocString)]
           subs = subordinates instanceMap decl
-          (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs
+
+      (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs
+
+      let
           ns = names l 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 ]
-      in seqList ns `seq`
-          seqList subNs `seq`
-          doc `seq`
-          seqList subDocs `seq`
-          seqList subArgs `seq`
-          (dm, am, sm, cm)
+
+      seqList ns `seq`
+        seqList subNs `seq`
+        doc `seq`
+        seqList subDocs `seq`
+        seqList subArgs `seq`
+        pure (dm, am, sm, cm)
 
     instanceMap :: Map SrcSpan Name
     instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
@@ -602,16 +611,20 @@ mkExportItems
       -- do so.
       -- NB: Pass in identity module, so we can look it up in index correctly
       moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
-    lookupExport (IEGroup lev docStr)  = return $
-      return . ExportGroup lev "" $ processDocString dflags gre docStr
+    lookupExport (IEGroup lev docStr)  = liftErrMsg $ do
+      doc <- processDocString dflags gre docStr
+      return [ExportGroup lev "" doc]
 
-    lookupExport (IEDoc docStr)        = return $
-      return . ExportDoc $ processDocStringParas dflags gre docStr
+    lookupExport (IEDoc docStr)        = liftErrMsg $ do
+      doc <- processDocStringParas dflags gre docStr
+      return [ExportDoc doc]
 
     lookupExport (IEDocNamed str)      = liftErrMsg $
-      findNamedDoc str [ unL d | d <- decls ] >>= return . \case
-        Nothing -> []
-        Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
+      findNamedDoc str [ unL d | d <- decls ] >>= \case
+        Nothing -> return  []
+        Just docStr -> do
+          doc <- processDocStringParas dflags gre docStr
+          return [ExportDoc doc]
 
     declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ]
     declWith pats t = do
@@ -924,9 +937,11 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
 
     mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
     mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
-      return . Just . ExportGroup lev "" $ processDocString dflags gre docStr
+      doc <- liftErrMsg (processDocString dflags gre docStr)
+      return . Just . ExportGroup lev "" $ doc
     mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
-      return . Just . ExportDoc $ processDocStringParas dflags gre docStr
+      doc <- liftErrMsg (processDocStringParas dflags gre docStr)
+      return . Just . ExportDoc $ doc
     mkExportItem (L l (ValD d))
       | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
           -- Top-level binding without type signature.
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 4f6b2c09..a38e7667 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -34,20 +34,21 @@ import RdrName
 import RnEnv (dataTcOccs)
 
 processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
-                  -> Maybe (MDoc Name)
-processDocStrings dflags gre strs =
-  case metaDocConcat $ map (processDocStringParas dflags gre) strs of
+                  -> ErrMsgM (Maybe (MDoc Name))
+processDocStrings dflags gre strs = do
+  mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs
+  case mdoc of
     -- We check that we don't have any version info to render instead
     -- of just checking if there is no comment: there may not be a
     -- comment but we still want to pass through any meta data.
-    MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing
-    x -> Just x
+    MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing
+    x -> pure (Just x)
 
-processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
 processDocStringParas dflags gre (HsDocString fs) =
-  overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs)
+  overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs)
 
-processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
 processDocString dflags gre (HsDocString fs) =
   rename dflags gre $ parseString dflags (unpackFS fs)
 
@@ -60,9 +61,11 @@ processModuleHeader dflags gre safety mayStr = do
       Just (L _ (HsDocString fs)) -> do
         let str = unpackFS fs
             (hmi, doc) = parseModuleHeader dflags str
-            !descr = rename dflags gre <$> hmi_description hmi
-            hmi' = hmi { hmi_description = descr }
-            doc' = overDoc (rename dflags gre) doc
+        !descr <- case hmi_description hmi of
+                    Just hmi_descr -> Just <$> rename dflags gre hmi_descr
+                    Nothing        -> pure Nothing
+        let hmi' = hmi { hmi_description = descr }
+        doc'  <- overDocF (rename dflags gre) doc
         return (hmi', Just doc')
 
   let flags :: [LangExt.Extension]
@@ -82,12 +85,12 @@ processModuleHeader dflags gre safety mayStr = do
 -- fallbacks in case we can't locate the identifiers.
 --
 -- See the comments in the source for implementation commentary.
-rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
+rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name)
 rename dflags gre = rn
   where
     rn d = case d of
-      DocAppend a b -> DocAppend (rn a) (rn b)
-      DocParagraph doc -> DocParagraph (rn doc)
+      DocAppend a b -> DocAppend <$> rn a <*> rn b
+      DocParagraph doc -> DocParagraph <$> rn doc
       DocIdentifier x -> do
         -- Generate the choices for the possible kind of thing this
         -- is.
@@ -100,7 +103,7 @@ rename dflags gre = rn
           -- We found no names in the env so we start guessing.
           [] ->
             case choices of
-              [] -> DocMonospaced (DocString (showPpr dflags x))
+              [] -> pure (DocMonospaced (DocString (showPpr dflags x)))
               -- There was nothing in the environment so we need to
               -- pick some default from what's available to us. We
               -- diverge here from the old way where we would default
@@ -109,37 +112,37 @@ rename dflags gre = rn
               -- type constructor names (such as in #253). So now we
               -- only get type constructor links if they are actually
               -- in scope.
-              a:_ -> outOfScope dflags a
+              a:_ -> pure (outOfScope dflags a)
 
           -- There is only one name in the environment that matches so
           -- use it.
-          [a] -> DocIdentifier a
+          [a] -> pure (DocIdentifier a)
           -- But when there are multiple names available, default to
           -- type constructors: somewhat awfully GHC returns the
           -- values in the list positionally.
-          a:b:_ | isTyConName a -> DocIdentifier a
-                | otherwise -> DocIdentifier b
+          a:b:_ | isTyConName a -> pure (DocIdentifier a)
+                | otherwise -> pure (DocIdentifier b)
 
-      DocWarning doc -> DocWarning (rn doc)
-      DocEmphasis doc -> DocEmphasis (rn doc)
-      DocBold doc -> DocBold (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
-      DocHyperlink l -> DocHyperlink l
-      DocPic str -> DocPic str
-      DocMathInline str -> DocMathInline str
-      DocMathDisplay str -> DocMathDisplay str
-      DocAName str -> DocAName str
-      DocProperty p -> DocProperty p
-      DocExamples e -> DocExamples e
-      DocEmpty -> DocEmpty
-      DocString str -> DocString str
-      DocHeader (Header l t) -> DocHeader $ Header l (rn t)
+      DocWarning doc -> DocWarning <$> rn doc
+      DocEmphasis doc -> DocEmphasis <$> rn doc
+      DocBold doc -> DocBold <$> rn doc
+      DocMonospaced doc -> DocMonospaced <$> rn doc
+      DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs
+      DocOrderedList docs -> DocOrderedList <$> traverse rn docs
+      DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list
+      DocCodeBlock doc -> DocCodeBlock <$> rn doc
+      DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
+      DocModule str -> pure (DocModule str)
+      DocHyperlink l -> pure (DocHyperlink l)
+      DocPic str -> pure (DocPic str)
+      DocMathInline str -> pure (DocMathInline str)
+      DocMathDisplay str -> pure (DocMathDisplay str)
+      DocAName str -> pure (DocAName str)
+      DocProperty p -> pure (DocProperty p)
+      DocExamples e -> pure (DocExamples e)
+      DocEmpty -> pure (DocEmpty)
+      DocString str -> pure (DocString str)
+      DocHeader (Header l t) -> DocHeader . Header l <$> rn t
 
 -- | Wrap an identifier that's out of scope (i.e. wasn't found in
 -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 48b29075..1e76c631 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -56,6 +56,9 @@ instance Bitraversable MetaDoc where
 overDoc :: (DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d
 overDoc f d = d { _doc = f $ _doc d }
 
+overDocF :: Functor f => (DocH a b -> f (DocH c d)) -> MetaDoc a b -> f (MetaDoc c d)
+overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d)
+
 type Version = [Int]
 
 data Hyperlink = Hyperlink