[commit: haddock] ghc-7.4: Add support for module warnings (3dcda28)

[David Waern]

Repository : ssh://darcs.haskell.org//srv/darcs/haddock

On branch  : ghc-7.4

http://hackage.haskell.org/trac/ghc/changeset/3dcda28c5a30652bd9ad8b69d996d8d0990902f5

>---------------------------------------------------------------

commit 3dcda28c5a30652bd9ad8b69d996d8d0990902f5
Author: Simon Hengel <sol at typeful.net>
Date:   Thu Jan 12 12:50:36 2012 +0100

    Add support for module warnings

>---------------------------------------------------------------

 src/Haddock/Interface/Create.hs |   21 ++++++++++++++++++++-
 1 files changed, 20 insertions(+), 1 deletions(-)

diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 2bca57d..2f8e1f0 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -35,6 +35,8 @@ import HscTypes
 import Name
 import Bag
 import RdrName (GlobalRdrEnv)
+import TcRnTypes (tcg_warns)
+import FastString (unpackFS)
 
 
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -49,6 +51,7 @@ createInterface tm flags modMap instIfaceMap = do
       dflags        = ms_hspp_opts ms
       instances     = modInfoInstances mi
       exportedNames = modInfoExports mi
+      warnings      = tcg_warns . fst . tm_internals_ $ tm
 
   -- The renamed source should always be available to us, but it's best
   -- to be on the safe side.
@@ -68,7 +71,9 @@ createInterface tm flags modMap instIfaceMap = do
         | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
         | otherwise = opts0
 
-  (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader
+  (info, mbDoc) <- do
+    (i, d) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader
+    return (i, addModuleWarnig warnings d)
 
   let declsWithDocs = topDecls group_
       (decls, _) = unzip declsWithDocs
@@ -125,6 +130,20 @@ createInterface tm flags modMap instIfaceMap = do
   }
 
 
+warningToDoc :: WarningTxt -> Doc id
+warningToDoc w = case w of
+  (DeprecatedTxt msg) -> format "Deprecated: " msg
+  (WarningTxt    msg) -> format "Warning: "    msg
+  where
+    format x xs = DocWarning . DocParagraph . DocString . concat $ x : map unpackFS xs
+
+
+addModuleWarnig :: Warnings -> Maybe (Doc id) -> Maybe (Doc id)
+addModuleWarnig warnings
+  | WarnAll w <- warnings = let d = warningToDoc w in Just . maybe d (mappend d)
+  | otherwise = id
+
+
 -------------------------------------------------------------------------------
 -- Doc options
 --