Skip to content
This repository was archived by the owner on Aug 3, 2024. It is now read-only.

Commit f7032e5

Browse files
alexbiehlalexbiehl
committed
Refactoring: Make doc renaming monadic
This allows us to later throw warnings if can't find an identifier
1 parent 2ad45f6 commit f7032e5

File tree

3 files changed

+116
-95
lines changed

3 files changed

+116
-95
lines changed

‎haddock-api/src/Haddock/Interface/Create.hs

Lines changed: 71 additions & 56 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ import Haddock.Backends.Hyperlinker.Types
3030
import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
3131
import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
3232

33+
import Data.Bitraversable
3334
import qualified Data.ByteString as BS
3435
import qualified Data.Map as M
3536
import Data.Map (Map)
@@ -38,8 +39,6 @@ import Data.Maybe
3839
import Data.Monoid
3940
import Data.Ord
4041
import Control.Applicative
41-
import Control.Arrow (second)
42-
import Control.DeepSeq (force)
4342
import Control.Exception (evaluate)
4443
import Control.Monad
4544
import Data.Traversable
@@ -109,7 +108,6 @@ createInterface tm flags modMap instIfaceMap = do
109108
exports
110109
| OptIgnoreExports `elem` opts = Nothing
111110
| otherwise = exports0
112-
warningMap = mkWarningMap dflags warnings gre exportedNames
113111

114112
localBundledPatSyns :: Map Name [Name]
115113
localBundledPatSyns =
@@ -134,8 +132,10 @@ createInterface tm flags modMap instIfaceMap = do
134132
-- Locations of all TH splices
135133
splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
136134

137-
maps@(!docMap, !argMap, !subMap, !declMap, _) =
138-
mkMaps dflags gre localInsts declsWithDocs
135+
warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
136+
137+
maps@(!docMap, !argMap, !subMap, !declMap, _) <-
138+
liftErrMsg (mkMaps dflags gre localInsts declsWithDocs)
139139

140140
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
141141

@@ -161,7 +161,8 @@ createInterface tm flags modMap instIfaceMap = do
161161

162162
let !aliases =
163163
mkAliasMap dflags $ tm_renamed_source tm
164-
modWarn = moduleWarning dflags gre warnings
164+
165+
modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
165166

166167
tokenizedSrc <- mkMaybeTokenizedSrc flags tm
167168

@@ -245,27 +246,29 @@ lookupModuleDyn dflags Nothing mdlName =
245246
-- Warnings
246247
-------------------------------------------------------------------------------
247248

248-
mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
249+
mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
249250
mkWarningMap dflags warnings gre exps = case warnings of
250-
NoWarnings -> M.empty
251-
WarnAll _ -> M.empty
251+
NoWarnings -> pure M.empty
252+
WarnAll _ -> pure M.empty
252253
WarnSome ws ->
253-
let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
254+
let ws' = [ (n, w)
255+
| (occ, w) <- ws
256+
, elt <- lookupGlobalRdrEnv gre occ
254257
, let n = gre_name elt, n `elem` exps ]
255-
in M.fromList $ map (second $ parseWarning dflags gre) ws'
258+
in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws'
256259

257-
moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name)
258-
moduleWarning _ _ NoWarnings = Nothing
259-
moduleWarning _ _ (WarnSome _) = Nothing
260-
moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
260+
moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
261+
moduleWarning _ _ NoWarnings = pure Nothing
262+
moduleWarning _ _ (WarnSome _) = pure Nothing
263+
moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w
261264

262-
parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
263-
parseWarning dflags gre w = force $ case w of
265+
parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
266+
parseWarning dflags gre w = case w of
264267
DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg)
265268
WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg)
266269
where
267270
format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
268-
. processDocString dflags gre $ HsDocString xs
271+
<$> processDocString dflags gre (HsDocString xs)
269272

270273

271274
-------------------------------------------------------------------------------
@@ -313,16 +316,15 @@ mkMaps :: DynFlags
313316
-> GlobalRdrEnv
314317
-> [Name]
315318
-> [(LHsDecl Name, [HsDocString])]
316-
-> Maps
317-
mkMaps dflags gre instances decls =
318-
let
319-
(a, b, c, d) = unzip4 $ map mappings decls
320-
in ( f' (map (nubByName fst) a)
321-
, f (filterMapping (not . M.null) b)
322-
, f (filterMapping (not . null) c)
323-
, f (filterMapping (not . null) d)
324-
, instanceMap
325-
)
319+
-> ErrMsgM Maps
320+
mkMaps dflags gre instances decls = do
321+
(a, b, c, d) <- unzip4 <$> traverse mappings decls
322+
pure ( f' (map (nubByName fst) a)
323+
, f (filterMapping (not . M.null) b)
324+
, f (filterMapping (not . null) c)
325+
, f (filterMapping (not . null) d)
326+
, instanceMap
327+
)
326328
where
327329
f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
328330
f = M.fromListWith (<>) . concat
@@ -334,35 +336,42 @@ mkMaps dflags gre instances decls =
334336
filterMapping p = map (filter (p . snd))
335337

336338
mappings :: (LHsDecl Name, [HsDocString])
337-
-> ( [(Name, MDoc Name)]
338-
, [(Name, Map Int (MDoc Name))]
339-
, [(Name, [Name])]
340-
, [(Name, [LHsDecl Name])]
341-
)
342-
mappings (ldecl, docStrs) =
339+
-> ErrMsgM ( [(Name, MDoc Name)]
340+
, [(Name, Map Int (MDoc Name))]
341+
, [(Name, [Name])]
342+
, [(Name, [LHsDecl Name])]
343+
)
344+
mappings (ldecl, docStrs) = do
343345
let L l decl = ldecl
344346
declDoc :: [HsDocString] -> Map Int HsDocString
345-
-> (Maybe (MDoc Name), Map Int (MDoc Name))
346-
declDoc strs m =
347-
let doc' = processDocStrings dflags gre strs
348-
m' = M.map (processDocStringParas dflags gre) m
349-
in (doc', m')
350-
(doc, args) = declDoc docStrs (typeDocs decl)
347+
-> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name))
348+
declDoc strs m = do
349+
doc' <- processDocStrings dflags gre strs
350+
m' <- traverse (processDocStringParas dflags gre) m
351+
pure (doc', m')
352+
353+
(doc, args) <- declDoc docStrs (typeDocs decl)
354+
355+
let
351356
subs :: [(Name, [HsDocString], Map Int HsDocString)]
352357
subs = subordinates instanceMap decl
353-
(subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs
358+
359+
(subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs
360+
361+
let
354362
ns = names l decl
355363
subNs = [ n | (n, _, _) <- subs ]
356364
dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
357365
am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
358366
sm = [ (n, subNs) | n <- ns ]
359367
cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
360-
in seqList ns `seq`
361-
seqList subNs `seq`
362-
doc `seq`
363-
seqList subDocs `seq`
364-
seqList subArgs `seq`
365-
(dm, am, sm, cm)
368+
369+
seqList ns `seq`
370+
seqList subNs `seq`
371+
doc `seq`
372+
seqList subDocs `seq`
373+
seqList subArgs `seq`
374+
pure (dm, am, sm, cm)
366375

367376
instanceMap :: Map SrcSpan Name
368377
instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
@@ -602,16 +611,20 @@ mkExportItems
602611
-- do so.
603612
-- NB: Pass in identity module, so we can look it up in index correctly
604613
moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
605-
lookupExport (IEGroup lev docStr) = return $
606-
return . ExportGroup lev "" $ processDocString dflags gre docStr
614+
lookupExport (IEGroup lev docStr) = liftErrMsg $ do
615+
doc <- processDocString dflags gre docStr
616+
return [ExportGroup lev "" doc]
607617

608-
lookupExport (IEDoc docStr) = return $
609-
return . ExportDoc $ processDocStringParas dflags gre docStr
618+
lookupExport (IEDoc docStr) = liftErrMsg $ do
619+
doc <- processDocStringParas dflags gre docStr
620+
return [ExportDoc doc]
610621

611622
lookupExport (IEDocNamed str) = liftErrMsg $
612-
findNamedDoc str [ unL d | d <- decls ] >>= return . \case
613-
Nothing -> []
614-
Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
623+
findNamedDoc str [ unL d | d <- decls ] >>= \case
624+
Nothing -> return []
625+
Just docStr -> do
626+
doc <- processDocStringParas dflags gre docStr
627+
return [ExportDoc doc]
615628

616629
declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ]
617630
declWith pats t = do
@@ -924,9 +937,11 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
924937

925938
mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
926939
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
927-
return . Just . ExportGroup lev "" $ processDocString dflags gre docStr
940+
doc <- liftErrMsg (processDocString dflags gre docStr)
941+
return . Just . ExportGroup lev "" $ doc
928942
mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
929-
return . Just . ExportDoc $ processDocStringParas dflags gre docStr
943+
doc <- liftErrMsg (processDocStringParas dflags gre docStr)
944+
return . Just . ExportDoc $ doc
930945
mkExportItem (L l (ValD d))
931946
| name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
932947
-- Top-level binding without type signature.

‎haddock-api/src/Haddock/Interface/LexParseRn.hs

Lines changed: 42 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -34,20 +34,21 @@ import RdrName
3434
import RnEnv (dataTcOccs)
3535

3636
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
37-
-> Maybe (MDoc Name)
38-
processDocStrings dflags gre strs =
39-
case metaDocConcat $ map (processDocStringParas dflags gre) strs of
37+
-> ErrMsgM (Maybe (MDoc Name))
38+
processDocStrings dflags gre strs = do
39+
mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs
40+
case mdoc of
4041
-- We check that we don't have any version info to render instead
4142
-- of just checking if there is no comment: there may not be a
4243
-- comment but we still want to pass through any meta data.
43-
MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing
44-
x -> Just x
44+
MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing
45+
x -> pure (Just x)
4546

46-
processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name
47+
processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
4748
processDocStringParas dflags gre (HsDocString fs) =
48-
overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs)
49+
overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs)
4950

50-
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
51+
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
5152
processDocString dflags gre (HsDocString fs) =
5253
rename dflags gre $ parseString dflags (unpackFS fs)
5354

@@ -60,9 +61,11 @@ processModuleHeader dflags gre safety mayStr = do
6061
Just (L _ (HsDocString fs)) -> do
6162
let str = unpackFS fs
6263
(hmi, doc) = parseModuleHeader dflags str
63-
!descr = rename dflags gre <$> hmi_description hmi
64-
hmi' = hmi { hmi_description = descr }
65-
doc' = overDoc (rename dflags gre) doc
64+
!descr <- case hmi_description hmi of
65+
Just hmi_descr -> Just <$> rename dflags gre hmi_descr
66+
Nothing -> pure Nothing
67+
let hmi' = hmi { hmi_description = descr }
68+
doc' <- overDocF (rename dflags gre) doc
6669
return (hmi', Just doc')
6770

6871
let flags :: [LangExt.Extension]
@@ -82,12 +85,12 @@ processModuleHeader dflags gre safety mayStr = do
8285
-- fallbacks in case we can't locate the identifiers.
8386
--
8487
-- See the comments in the source for implementation commentary.
85-
rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
88+
rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name)
8689
rename dflags gre = rn
8790
where
8891
rn d = case d of
89-
DocAppend a b -> DocAppend (rn a) (rn b)
90-
DocParagraph doc -> DocParagraph (rn doc)
92+
DocAppend a b -> DocAppend <$> rn a <*> rn b
93+
DocParagraph doc -> DocParagraph <$> rn doc
9194
DocIdentifier x -> do
9295
-- Generate the choices for the possible kind of thing this
9396
-- is.
@@ -100,7 +103,7 @@ rename dflags gre = rn
100103
-- We found no names in the env so we start guessing.
101104
[] ->
102105
case choices of
103-
[] -> DocMonospaced (DocString (showPpr dflags x))
106+
[] -> pure (DocMonospaced (DocString (showPpr dflags x)))
104107
-- There was nothing in the environment so we need to
105108
-- pick some default from what's available to us. We
106109
-- diverge here from the old way where we would default
@@ -109,37 +112,37 @@ rename dflags gre = rn
109112
-- type constructor names (such as in #253). So now we
110113
-- only get type constructor links if they are actually
111114
-- in scope.
112-
a:_ -> outOfScope dflags a
115+
a:_ -> pure (outOfScope dflags a)
113116

114117
-- There is only one name in the environment that matches so
115118
-- use it.
116-
[a] -> DocIdentifier a
119+
[a] -> pure (DocIdentifier a)
117120
-- But when there are multiple names available, default to
118121
-- type constructors: somewhat awfully GHC returns the
119122
-- values in the list positionally.
120-
a:b:_ | isTyConName a -> DocIdentifier a
121-
| otherwise -> DocIdentifier b
123+
a:b:_ | isTyConName a -> pure (DocIdentifier a)
124+
| otherwise -> pure (DocIdentifier b)
122125

123-
DocWarning doc -> DocWarning (rn doc)
124-
DocEmphasis doc -> DocEmphasis (rn doc)
125-
DocBold doc -> DocBold (rn doc)
126-
DocMonospaced doc -> DocMonospaced (rn doc)
127-
DocUnorderedList docs -> DocUnorderedList (map rn docs)
128-
DocOrderedList docs -> DocOrderedList (map rn docs)
129-
DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
130-
DocCodeBlock doc -> DocCodeBlock (rn doc)
131-
DocIdentifierUnchecked x -> DocIdentifierUnchecked x
132-
DocModule str -> DocModule str
133-
DocHyperlink l -> DocHyperlink l
134-
DocPic str -> DocPic str
135-
DocMathInline str -> DocMathInline str
136-
DocMathDisplay str -> DocMathDisplay str
137-
DocAName str -> DocAName str
138-
DocProperty p -> DocProperty p
139-
DocExamples e -> DocExamples e
140-
DocEmpty -> DocEmpty
141-
DocString str -> DocString str
142-
DocHeader (Header l t) -> DocHeader $ Header l (rn t)
126+
DocWarning doc -> DocWarning <$> rn doc
127+
DocEmphasis doc -> DocEmphasis <$> rn doc
128+
DocBold doc -> DocBold <$> rn doc
129+
DocMonospaced doc -> DocMonospaced <$> rn doc
130+
DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs
131+
DocOrderedList docs -> DocOrderedList <$> traverse rn docs
132+
DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list
133+
DocCodeBlock doc -> DocCodeBlock <$> rn doc
134+
DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
135+
DocModule str -> pure (DocModule str)
136+
DocHyperlink l -> pure (DocHyperlink l)
137+
DocPic str -> pure (DocPic str)
138+
DocMathInline str -> pure (DocMathInline str)
139+
DocMathDisplay str -> pure (DocMathDisplay str)
140+
DocAName str -> pure (DocAName str)
141+
DocProperty p -> pure (DocProperty p)
142+
DocExamples e -> pure (DocExamples e)
143+
DocEmpty -> pure (DocEmpty)
144+
DocString str -> pure (DocString str)
145+
DocHeader (Header l t) -> DocHeader . Header l <$> rn t
143146

144147
-- | Wrap an identifier that's out of scope (i.e. wasn't found in
145148
-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently

‎haddock-library/src/Documentation/Haddock/Types.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,9 @@ instance Bitraversable MetaDoc where
5656
overDoc :: (DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d
5757
overDoc f d = d { _doc = f $ _doc d }
5858

59+
overDocF :: Functor f => (DocH a b -> f (DocH c d)) -> MetaDoc a b -> f (MetaDoc c d)
60+
overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d)
61+
5962
type Version = [Int]
6063

6164
data Hyperlink = Hyperlink

0 commit comments

Comments
 (0)