aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock')
-rw-r--r--src/Haddock/Interface/Create.hs33
1 files changed, 9 insertions, 24 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 2d903133..f890b72e 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -34,7 +34,7 @@ import GHC hiding (flags)
import HscTypes
import Name
import Bag
-import RdrName (GlobalRdrEnv)
+import RdrName
import TcRnTypes (tcg_warns)
import FastString (unpackFS)
@@ -79,29 +79,14 @@ createInterface tm flags modMap instIfaceMap = do
(decls, _) = unzip declsWithDocs
localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
- (docs, argMap, subMap, declMap) <- liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs
-
- -- Attach warnings to documentation as appropriate. If there is a warning
- -- for an identifier with no documentation, create a piece of documentation,
- -- that just contains the warning.
- let docMap = warningMap `combine` docs
- where
- combine :: (Ord k, Monoid a) => Map k a -> Map k a -> Map k a
- combine = M.unionWith mappend
-
- warningMap = case warnings of
- -- NOTE: warningMap may contain more elements than xs, e.g. when
- -- we have a warning for:
- --
- -- data Foo = Foo
- --
- -- So you can not just map over xs!
- (WarnSome xs) -> foldr f M.empty exportedNames
- where
- f name m = case lookup (getOccName name) xs of
- Just x -> M.insert name (warningToDoc x) m
- Nothing -> m
- _ -> M.empty
+ (docMap0, argMap, subMap, declMap) <- liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs
+
+ -- Attach warnings to documentation. If there is a warning for an identifier
+ -- with no documentation, create a piece of documentation that just contains
+ -- the warning.
+ let docMap = foldl' (\m (n, d) -> M.insertWith mappend n d m) docMap0 l
+ where l = [ (gre_name elt, warningToDoc w) | WarnSome ws <- [warnings]
+ , (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ ]
let maps = (docMap, argMap, subMap, declMap)