From e8756e5bfcd128817b7942cb439ee3287dd0637a Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Tue, 6 May 2014 13:39:23 +0200 Subject: 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. --- src/Haddock/Interface/Create.hs | 129 +++++++++++++---------------- src/Haddock/Interface/LexParseRn.hs | 53 +++++------- src/Haddock/Interface/ParseModuleHeader.hs | 46 ++++------ src/Haddock/Parser.hs | 17 ++-- 4 files changed, 103 insertions(+), 142 deletions(-) (limited to 'src/Haddock') 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. -- diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs index 720f442b..ea4b7a3f 100644 --- a/src/Haddock/Parser.hs +++ b/src/Haddock/Parser.hs @@ -13,13 +13,12 @@ -- Stability : experimental -- Portability : portable -module Haddock.Parser ( module Documentation.Haddock.Parser - , parseParasMaybe - , parseStringMaybe +module Haddock.Parser ( parseParas + , parseString , parseIdent ) where -import Documentation.Haddock.Parser +import qualified Documentation.Haddock.Parser as P import DynFlags (DynFlags) import FastString (mkFastString) import Documentation.Haddock.Types @@ -29,13 +28,11 @@ import RdrName (RdrName) import SrcLoc (mkRealSrcLoc, unLoc) import StringBuffer (stringToStringBuffer) -{-# DEPRECATED parseParasMaybe "use `parseParas` instead" #-} -parseParasMaybe :: DynFlags -> String -> Maybe (DocH mod RdrName) -parseParasMaybe d = Just . overIdentifier (parseIdent d) . parseParas +parseParas :: DynFlags -> String -> DocH mod RdrName +parseParas d = P.overIdentifier (parseIdent d) . P.parseParas -{-# DEPRECATED parseStringMaybe "use `parseString` instead" #-} -parseStringMaybe :: DynFlags -> String -> Maybe (DocH mod RdrName) -parseStringMaybe d = Just . overIdentifier (parseIdent d) . parseString +parseString :: DynFlags -> String -> DocH mod RdrName +parseString d = P.overIdentifier (parseIdent d) . P.parseString parseIdent :: DynFlags -> String -> Maybe RdrName parseIdent dflags str0 = -- cgit v1.2.3