Add support for warnings

1 files changed, 25 insertions, 2 deletions

diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 2f8e1f01..76b59a80 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -79,8 +79,31 @@ createInterface tm flags modMap instIfaceMap = do
       (decls, _) = unzip declsWithDocs
       localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
 
-  maps@(docMap, argMap, subMap, declMap) <-
-    liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs
+  (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
+
+  let maps = (docMap, argMap, subMap, declMap)
 
   let exports0 = fmap (reverse . map unLoc) mayExports
       exports