Remove no longer necessary parser error handling.

We can now drop some Maybe tests and even lets us strip an error
handling monad away in a few places.

3 files changed, 96 insertions, 132 deletions

diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 08810d6e..bc615cde 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections, BangPatterns #-}
+{-# LANGUAGE TupleSections, BangPatterns, LambdaCase #-}
 {-# OPTIONS_GHC -Wwarn #-}
 -----------------------------------------------------------------------------
 -- |
@@ -29,11 +29,11 @@ import Data.Maybe
 import Data.Monoid
 import Data.Ord
 import Control.Applicative
+import Control.Arrow (second)
 import Control.DeepSeq
 import Control.Monad
 import Data.Function (on)
 import qualified Data.Foldable as F
-import qualified Data.Traversable as T
 
 import qualified Packages
 import qualified Module
@@ -44,7 +44,7 @@ import Name
 import Bag
 import RdrName
 import TcRnTypes
-import FastString (unpackFS, concatFS)
+import FastString (concatFS)
 
 
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -89,15 +89,14 @@ createInterface tm flags modMap instIfaceMap = do
       -- Locations of all TH splices
       splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
 
-  maps@(!docMap, !argMap, !subMap, !declMap, _) <-
-    liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
+      maps@(!docMap, !argMap, !subMap, !declMap, _) =
+        mkMaps dflags gre localInsts declsWithDocs
 
   let exports0 = fmap (reverse . map unLoc) mayExports
       exports
-       | OptIgnoreExports `elem` opts = Nothing
-       | otherwise = exports0
-
-  warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames
+        | OptIgnoreExports `elem` opts = Nothing
+        | otherwise = exports0
+      warningMap = mkWarningMap dflags warnings gre exportedNames
 
   let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
 
@@ -121,8 +120,7 @@ createInterface tm flags modMap instIfaceMap = do
 
   let !aliases =
         mkAliasMap dflags $ tm_renamed_source tm
-
-  modWarn <- liftErrMsg $ moduleWarning dflags gre warnings
+      modWarn = moduleWarning dflags gre warnings
 
   return $! Interface {
     ifaceMod             = mdl
@@ -182,35 +180,27 @@ lookupModuleDyn dflags Nothing mdlName =
 -- Warnings
 -------------------------------------------------------------------------------
 
-mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
+mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
 mkWarningMap dflags warnings gre exps = case warnings of
-  NoWarnings  -> return M.empty
-  WarnAll _   -> return M.empty
-  WarnSome ws -> do
+  NoWarnings  -> M.empty
+  WarnAll _   -> M.empty
+  WarnSome ws ->
     let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
               , let n = gre_name elt, n `elem` exps ]
-    M.fromList <$> mapM parse ws'
-  where
-    parse (n, w) = (,) n <$> parseWarning dflags gre w
-
-
-moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
-moduleWarning dflags gre ws =
-  case ws of
-    NoWarnings -> return Nothing
-    WarnSome _ -> return Nothing
-    WarnAll w  -> Just <$> parseWarning dflags gre w
-
-parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
-parseWarning dflags gre w = do
-  r <- case w of
-    (DeprecatedTxt msg) -> format "Deprecated: " (concatFS msg)
-    (WarningTxt    msg) -> format "Warning: "    (concatFS msg)
-  r `deepseq` return r
+    in M.fromList $ map (second $ 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
+
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
+parseWarning dflags gre w = force $ case w of
+  DeprecatedTxt msg -> format "Deprecated: " (concatFS msg)
+  WarningTxt    msg -> format "Warning: "    (concatFS msg)
   where
     format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
-      .   fromMaybe (DocString . unpackFS $ xs)
-      <$> processDocString dflags gre (HsDocString xs)
+                  . processDocString dflags gre $ HsDocString xs
 
 
 -------------------------------------------------------------------------------
@@ -258,35 +248,44 @@ mkMaps :: DynFlags
        -> GlobalRdrEnv
        -> [Name]
        -> [(LHsDecl Name, [HsDocString])]
-       -> ErrMsgM Maps
-mkMaps dflags gre instances decls = do
-  (a, b, c, d) <- unzip4 <$> mapM mappings decls
-  return (f $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
+       -> Maps
+mkMaps dflags gre instances decls =
+  let (a, b, c, d) = unzip4 $ map mappings decls
+  in (f $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
   where
     f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
     f = M.fromListWith (<>) . concat
 
-    mappings (ldecl, docStrs) = do
+    mappings :: (LHsDecl Name, [HsDocString])
+             -> ( [(Name, Doc Name)]
+                , [(Name, Map Int (Doc Name))]
+                , [(Name, [Name])]
+                , [(Name,  [LHsDecl Name])]
+                )
+    mappings (ldecl, docStrs) =
       let L l decl = 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 = subordinates instanceMap decl
-      (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs
-      let ns = names l decl
+          declDoc :: [HsDocString] -> Map Int HsDocString
+                  -> (Maybe (Doc Name), Map Int (Doc 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)
+          subs :: [(Name, [HsDocString], Map Int HsDocString)]
+          subs = subordinates instanceMap decl
+          (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs
+          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 ]
-      seqList ns `seq`
+      in seqList ns `seq`
           seqList subNs `seq`
           doc `seq`
           seqList subDocs `seq`
           seqList subArgs `seq`
-          return (dm, am, sm, cm)
+          (dm, am, sm, cm)
 
     instanceMap :: Map SrcSpan Name
     instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
@@ -499,24 +498,16 @@ mkExportItems
     lookupExport (IEThingWith t _)     = declWith t
     lookupExport (IEModuleContents m)  =
       moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
-    lookupExport (IEGroup lev docStr)  = liftErrMsg $
-      ifDoc (processDocString dflags gre docStr)
-            (\doc -> return [ ExportGroup lev "" doc ])
-    lookupExport (IEDoc docStr)        = liftErrMsg $
-      ifDoc (processDocStringParas dflags gre docStr)
-            (\doc -> return [ ExportDoc doc ])
-    lookupExport (IEDocNamed str)      = liftErrMsg $
-      ifDoc (findNamedDoc str [ unL d | d <- decls ])
-            (\docStr ->
-            ifDoc (processDocStringParas dflags gre docStr)
-                  (\doc -> return [ ExportDoc doc ]))
+    lookupExport (IEGroup lev docStr)  = return $
+      return . ExportGroup lev "" $ processDocString dflags gre docStr
 
+    lookupExport (IEDoc docStr)        = return $
+      return . ExportDoc $ processDocStringParas dflags gre docStr
 
-    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
-
+    lookupExport (IEDocNamed str)      = liftErrMsg $
+      findNamedDoc str [ unL d | d <- decls ] >>= return . \case
+        Nothing -> []
+        Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
 
     declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
     declWith t =
@@ -728,11 +719,9 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
 
     mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
     mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
-      mbDoc <- liftErrMsg $ processDocString dflags gre docStr
-      return $ fmap (ExportGroup lev "") mbDoc
+      return . Just . ExportGroup lev "" $ processDocString dflags gre docStr
     mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
-      mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr
-      return $ fmap ExportDoc mbDoc
+      return . Just . ExportDoc $ processDocStringParas dflags gre docStr
     mkExportItem (L l (ValD d))
       | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
           -- Top-level binding without type signature.
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index d9d4ae58..54c7351d 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -21,8 +21,7 @@ module Haddock.Interface.LexParseRn
 import Control.Applicative
 import Data.IntSet (toList)
 import Data.List
-import Data.Maybe
-import Data.Monoid ((<>))
+import Data.Monoid (mconcat)
 import DynFlags (ExtensionFlag(..), languageExtensions)
 import FastString
 import GHC
@@ -33,34 +32,27 @@ import Name
 import Outputable (showPpr)
 import RdrName
 
-processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
-processDocStrings dflags gre strs = do
-  docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs
-  let doc = foldl' (<>) DocEmpty docs
-  case doc of
-    DocEmpty -> return Nothing
-    _ -> return (Just doc)
+processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name)
+processDocStrings dflags gre strs =
+  case mconcat $ map (processDocStringParas dflags gre) strs of
+    DocEmpty -> Nothing
+    x -> Just x
 
-processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
-processDocStringParas = process parseParasMaybe
 
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
+processDocStringParas = process parseParas
 
-processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
-processDocString = process parseStringMaybe
 
-process :: (DynFlags -> String -> Maybe (Doc RdrName))
+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
+processDocString = process parseString
+
+process :: (DynFlags -> String -> Doc RdrName)
         -> DynFlags
         -> GlobalRdrEnv
         -> HsDocString
-        -> ErrMsgM (Maybe (Doc Name))
-process parse dflags gre (HsDocString fs) = do
-   let str = unpackFS fs
-   case parse dflags str of
-     Nothing -> do
-       tell [ "doc comment parse failed: " ++ str ]
-       return Nothing
-     Just doc -> do
-       return (Just (rename dflags gre doc))
+        -> Doc Name
+process parse dflags gre (HsDocString fs) =
+  rename dflags gre $ parse dflags (unpackFS fs)
 
 
 processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
@@ -68,19 +60,14 @@ processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsD
 processModuleHeader dflags gre safety 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 msg -> do
-            tell ["haddock module header parse failed: " ++ msg]
-            return failure
-          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')
+            (hmi, doc) = parseModuleHeader dflags str
+            !descr = rename dflags gre <$> hmi_description hmi
+            hmi' = hmi { hmi_description = descr }
+            doc' = rename dflags gre doc
+        return (hmi', Just doc')
 
   let flags :: [ExtensionFlag]
       -- We remove the flags implied by the language setting and we display the language instead
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
index 0be2511f..6848dc63 100644
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -11,14 +11,13 @@
 -----------------------------------------------------------------------------
 module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
 
-import Haddock.Types
+import Control.Applicative ((<$>))
+import Control.Monad (mplus)
+import Data.Char
+import DynFlags
 import Haddock.Parser
-
+import Haddock.Types
 import RdrName
-import DynFlags
-
-import Data.Char
-import Control.Monad (mplus)
 
 -- -----------------------------------------------------------------------------
 -- Parsing module headers
@@ -26,7 +25,7 @@ import Control.Monad (mplus)
 -- 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 :: DynFlags -> String -> Either String (HaddockModInfo RdrName, Doc RdrName)
+parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, Doc RdrName)
 parseModuleHeader dflags str0 =
    let
       getKey :: String -> String -> (Maybe String,String)
@@ -43,28 +42,17 @@ parseModuleHeader dflags str0 =
       (stabilityOpt,str7) = getKey "Stability" str6
       (portabilityOpt,str8) = getKey "Portability" str7
 
-      description1 :: Either String (Maybe (Doc RdrName))
-      description1 = case descriptionOpt of
-         Nothing -> Right Nothing
-         Just description -> case parseStringMaybe dflags description of
-            Nothing -> Left ("Cannot parse Description: " ++ description)
-            Just doc -> Right (Just doc)
-   in
-      case description1 of
-         Left mess -> Left mess
-         Right docOpt -> case parseParasMaybe dflags str8 of
-           Nothing -> Left "Cannot parse header documentation paragraphs"
-           Just doc -> Right (HaddockModInfo {
-            hmi_description = docOpt,
-            hmi_copyright = copyrightOpt,
-            hmi_license = licenseOpt `mplus` licenceOpt,
-            hmi_maintainer = maintainerOpt,
-            hmi_stability = stabilityOpt,
-            hmi_portability = portabilityOpt,
-            hmi_safety = Nothing,
-            hmi_language = Nothing, -- set in LexParseRn
-            hmi_extensions = [] -- also set in LexParseRn
-            }, doc)
+   in (HaddockModInfo {
+          hmi_description = parseString dflags <$> descriptionOpt,
+          hmi_copyright = copyrightOpt,
+          hmi_license = licenseOpt `mplus` licenceOpt,
+          hmi_maintainer = maintainerOpt,
+          hmi_stability = stabilityOpt,
+          hmi_portability = portabilityOpt,
+          hmi_safety = Nothing,
+          hmi_language = Nothing, -- set in LexParseRn
+          hmi_extensions = [] -- also set in LexParseRn
+          }, parseParas dflags str8)
 
 -- | This function is how we read keys.
 --