aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs127
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs81
-rw-r--r--haddock-library/src/Documentation/Haddock/Types.hs3
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 07:00:45 +0000