From f7032e5e48c7a6635e1dca607a37a16c8893e94b Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Wed, 16 Aug 2017 09:06:40 +0200 Subject: Refactoring: Make doc renaming monadic This allows us to later throw warnings if can't find an identifier --- haddock-api/src/Haddock/Interface/Create.hs | 127 ++++++++++++--------- haddock-api/src/Haddock/Interface/LexParseRn.hs | 81 ++++++------- haddock-library/src/Documentation/Haddock/Types.hs | 3 + 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 -- cgit v1.2.3