Allow haddock markup in deprecation messages

3 files changed, 68 insertions, 22 deletions

diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 32f287f5..fca1a00e 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 (unpackFS)
+import FastString (concatFS)
 
 
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -90,7 +90,8 @@ createInterface tm flags modMap instIfaceMap = do
 
   liftErrMsg $ warnAboutFilteredDecls dflags mdl decls
 
-  let warningMap = mkWarningMap warnings gre exportedNames
+  warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames
+
   exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports
                    instances instIfaceMap dflags
 
@@ -112,11 +113,13 @@ createInterface tm flags modMap instIfaceMap = do
   let !aliases =
         mkAliasMap dflags $ tm_renamed_source tm
 
+  modWarn <- liftErrMsg $ moduleWarning dflags gre warnings
+
   return $! Interface {
     ifaceMod             = mdl,
     ifaceOrigFilename    = msHsFilePath ms,
     ifaceInfo            = info,
-    ifaceDoc             = Documentation mbDoc (moduleWarning warnings),
+    ifaceDoc             = Documentation mbDoc modWarn,
     ifaceRnDoc           = Documentation Nothing Nothing,
     ifaceOptions         = opts,
     ifaceDocMap          = docMap,
@@ -169,29 +172,35 @@ lookupModuleDyn dflags Nothing mdlName =
 
 type WarningMap = DocMap Name
 
-mkWarningMap :: Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
-mkWarningMap NoWarnings  _ _ = M.empty
-mkWarningMap (WarnAll _) _ _ = M.empty
-mkWarningMap (WarnSome ws) gre exps = M.fromList
-      [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
-      , let n = gre_name elt, n `elem` exps ]
+mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
+mkWarningMap dflags warnings gre exps = case warnings of
+  NoWarnings  -> return M.empty
+  WarnAll _   -> return M.empty
+  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'
+  where
+    parse (n, w) = (fmap $ (,) n) <$> parseWarning dflags gre w
 
 
-moduleWarning :: Warnings -> Maybe (Doc id)
-moduleWarning ws =
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
+moduleWarning dflags gre ws =
   case ws of
-    NoWarnings -> Nothing
-    WarnSome _ -> Nothing
-    WarnAll w  -> Just $! warnToDoc w
+    NoWarnings -> return Nothing
+    WarnSome _ -> return Nothing
+    WarnAll w  -> parseWarning dflags gre w
 
 
-warnToDoc :: WarningTxt -> Doc id
-warnToDoc w = case w of
-  (DeprecatedTxt msg) -> format "Deprecated: " msg
-  (WarningTxt    msg) -> format "Warning: "    msg
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Maybe (Doc Name))
+parseWarning dflags gre w = do
+  r <- case w of
+    (DeprecatedTxt msg) -> format "Deprecated: " msg
+    (WarningTxt    msg) -> format "Warning: "    msg
+  r `deepseq` return r
   where
-    format x xs = let !str = force $ concat (x : map unpackFS xs)
-                  in DocWarning $ DocParagraph $ DocString str
+    format x xs = fmap (DocWarning . DocParagraph . DocAppend (DocString x))
+      <$> processDocString dflags gre (HsDocString $ concatFS xs)
 
 
 -------------------------------------------------------------------------------
diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y
index 0befe395..f40ff521 100644
--- a/src/Haddock/Parse.y
+++ b/src/Haddock/Parse.y
@@ -7,7 +7,7 @@
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
-module Haddock.Parse where
+module Haddock.Parse (parseString, parseParas) where
 
 import Haddock.Lex
 import Haddock.Types (Doc(..), Example(Example), Hyperlink(..))
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 05fc9747..9be46748 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -1,5 +1,5 @@
-{-# OPTIONS_HADDOCK hide #-}
 {-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Types
@@ -22,6 +22,7 @@ module Haddock.Types (
 
 import Control.Exception
 import Control.Arrow
+import Control.DeepSeq
 import Data.Typeable
 import Data.Map (Map)
 import Data.Maybe
@@ -316,18 +317,54 @@ instance Monoid (Doc id) where
   mappend = DocAppend
 
 
+instance NFData a => NFData (Doc a) where
+  rnf doc = case doc of
+    DocEmpty                  -> ()
+    DocAppend a b             -> a `deepseq` b `deepseq` ()
+    DocString a               -> a `deepseq` ()
+    DocParagraph a            -> a `deepseq` ()
+    DocIdentifier a           -> a `deepseq` ()
+    DocIdentifierUnchecked a  -> a `deepseq` ()
+    DocModule a               -> a `deepseq` ()
+    DocWarning a              -> a `deepseq` ()
+    DocEmphasis a             -> a `deepseq` ()
+    DocMonospaced a           -> a `deepseq` ()
+    DocUnorderedList a        -> a `deepseq` ()
+    DocOrderedList a          -> a `deepseq` ()
+    DocDefList a              -> a `deepseq` ()
+    DocCodeBlock a            -> a `deepseq` ()
+    DocHyperlink a            -> a `deepseq` ()
+    DocPic a                  -> a `deepseq` ()
+    DocAName a                -> a `deepseq` ()
+    DocProperty a             -> a `deepseq` ()
+    DocExamples a             -> a `deepseq` ()
+
+
+instance NFData Name
+instance NFData OccName
+instance NFData ModuleName
+
+
 data Hyperlink = Hyperlink
   { hyperlinkUrl   :: String
   , hyperlinkLabel :: Maybe String
   } deriving (Eq, Show)
 
 
+instance NFData Hyperlink where
+  rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()
+
+
 data Example = Example
   { exampleExpression :: String
   , exampleResult     :: [String]
   } deriving (Eq, Show)
 
 
+instance NFData Example where
+  rnf (Example a b) = a `deepseq` b `deepseq` ()
+
+
 exampleToString :: Example -> String
 exampleToString (Example expression result) =
     ">>> " ++ expression ++ "\n" ++  unlines result