If parsing of deprecation message fails, include it verbatim

author: Simon Hengel <sol@typeful.net> 2012-10-14 13:55:09 +0200
committer: Simon Hengel <sol@typeful.net> 2012-10-14 14:00:23 +0200
commit: cea620e1f967ce066e11bcd79b831905f6151fef (patch)
tree: 035e6df7ea61bdc414b0e4166ee657aafb705c64
parent: dfc2cb4e31d6756b2d6ca7f87e80d8913751a4b7 (diff)
4 files changed, 154 insertions, 9 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index fca1a00e..3eb5205c 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -41,7 +41,7 @@ import Name
 import Bag
 import RdrName
 import TcRnTypes
-import FastString (concatFS)
+import FastString (unpackFS, concatFS)
 
 
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -179,9 +179,9 @@ mkWarningMap dflags warnings gre exps = case warnings of
   WarnSome ws -> do
     let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
               , let n = gre_name elt, n `elem` exps ]
-    M.fromList . catMaybes <$> mapM parse ws'
+    M.fromList <$> mapM parse ws'
   where
-    parse (n, w) = (fmap $ (,) n) <$> parseWarning dflags gre w
+    parse (n, w) = (,) n <$> parseWarning dflags gre w
 
 
 moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
@@ -189,18 +189,19 @@ moduleWarning dflags gre ws =
   case ws of
     NoWarnings -> return Nothing
     WarnSome _ -> return Nothing
-    WarnAll w  -> parseWarning dflags gre w
+    WarnAll w  -> Just <$> parseWarning dflags gre w
 
 
-parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Maybe (Doc Name))
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
 parseWarning dflags gre w = do
   r <- case w of
-    (DeprecatedTxt msg) -> format "Deprecated: " msg
-    (WarningTxt    msg) -> format "Warning: "    msg
+    (DeprecatedTxt msg) -> format "Deprecated: " (concatFS msg)
+    (WarningTxt    msg) -> format "Warning: "    (concatFS msg)
   r `deepseq` return r
   where
-    format x xs = fmap (DocWarning . DocParagraph . DocAppend (DocString x))
-      <$> processDocString dflags gre (HsDocString $ concatFS xs)
+    format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
+      .   fromMaybe (DocString . unpackFS $ xs)
+      <$> processDocString dflags gre (HsDocString xs)
 
 
 -------------------------------------------------------------------------------
diff --git a/tests/html-tests/tests/DeprecationMessageParseError.hs b/tests/html-tests/tests/DeprecationMessageParseError.hs
new file mode 100644
index 00000000..5f0b8713
--- /dev/null
+++ b/tests/html-tests/tests/DeprecationMessageParseError.hs
@@ -0,0 +1,12 @@
+-- |
+-- What is tested here:
+--
+-- * if parsing of a deprecation message fails, the message is included
+--   verbatim
+--
+module DeprecationMessageParseError where
+
+-- | some documentation for foo
+foo :: Int
+foo = 23
+{-# DEPRECATED foo "use @bar instead" #-}
diff --git a/tests/html-tests/tests/DeprecationMessageParseError.html.ref b/tests/html-tests/tests/DeprecationMessageParseError.html.ref
new file mode 100644
index 00000000..b4ea426e
--- /dev/null
+++ b/tests/html-tests/tests/DeprecationMessageParseError.html.ref
@@ -0,0 +1,101 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >DeprecationMessageParseError</title
+    ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//<![CDATA[
+window.onload = function () {pageLoad();setSynopsis("mini_DeprecationMessageParseError.html");};
+//]]>
+</script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href=""
+	  >Contents</a
+	  ></li
+	><li
+	><a href=""
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      >&nbsp;</p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >None</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>DeprecationMessageParseError</p
+	></div
+      ><div id="description"
+      ><p class="caption"
+	>Description</p
+	><div class="doc"
+	><p
+	  >What is tested here:
+</p
+	  ><ul
+	  ><li
+	    > if parsing of a deprecation message fails, the message is included
+   verbatim
+</li
+	    ></ul
+	  ></div
+	></div
+      ><div id="synopsis"
+      ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')"
+	>Synopsis</p
+	><ul id="section.syn" class="hide" onclick="toggleSection('syn')"
+	><li class="src short"
+	  ><a href=""
+	    >foo</a
+	    > :: <a href=""
+	    >Int</a
+	    ></li
+	  ></ul
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><a name="v:foo" class="def"
+	    >foo</a
+	    > :: <a href=""
+	    >Int</a
+	    ></p
+	  ><div class="doc"
+	  ><div class="warning"
+	    ><p
+	      >Deprecated: use @bar instead</p
+	      ></div
+	    ><p
+	    >some documentation for foo
+</p
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ><p
+      >Produced by <a href=""
+	>Haddock</a
+	> version 2.13.1</p
+      ></div
+    ></body
+  ></html
+>
diff --git a/tests/html-tests/tests/mini_DeprecationMessageParseError.html.ref b/tests/html-tests/tests/mini_DeprecationMessageParseError.html.ref
new file mode 100644
index 00000000..e52f487f
--- /dev/null
+++ b/tests/html-tests/tests/mini_DeprecationMessageParseError.html.ref
@@ -0,0 +1,31 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >DeprecationMessageParseError</title
+    ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//<![CDATA[
+window.onload = function () {pageLoad();};
+//]]>
+</script
+    ></head
+  ><body id="mini"
+  ><div id="module-header"
+    ><p class="caption"
+      >DeprecationMessageParseError</p
+      ></div
+    ><div id="interface"
+    ><div class="top"
+      ><p class="src"
+	><a href="" target="main"
+	  >foo</a
+	  ></p
+	></div
+      ></div
+    ></body
+  ></html
+>
author	Simon Hengel <sol@typeful.net>	2012-10-14 13:55:09 +0200
committer	Simon Hengel <sol@typeful.net>	2012-10-14 14:00:23 +0200
commit	cea620e1f967ce066e11bcd79b831905f6151fef (patch)
tree	035e6df7ea61bdc414b0e4166ee657aafb705c64
parent	dfc2cb4e31d6756b2d6ca7f87e80d8913751a4b7 (diff)