From cea620e1f967ce066e11bcd79b831905f6151fef Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 13:55:09 +0200 Subject: If parsing of deprecation message fails, include it verbatim --- src/Haddock/Interface/Create.hs | 19 ++-- .../tests/DeprecationMessageParseError.hs | 12 +++ .../tests/DeprecationMessageParseError.html.ref | 101 +++++++++++++++++++++ .../mini_DeprecationMessageParseError.html.ref | 31 +++++++ 4 files changed, 154 insertions(+), 9 deletions(-) create mode 100644 tests/html-tests/tests/DeprecationMessageParseError.hs create mode 100644 tests/html-tests/tests/DeprecationMessageParseError.html.ref create mode 100644 tests/html-tests/tests/mini_DeprecationMessageParseError.html.ref 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 @@ + +DeprecationMessageParseError

 

Safe HaskellNone

DeprecationMessageParseError

Description

What is tested here: +

  • if parsing of a deprecation message fails, the message is included + verbatim +

Synopsis

Documentation

foo :: Int

Deprecated: use @bar instead

some documentation for foo +

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 @@ + +DeprecationMessageParseError

DeprecationMessageParseError

foo

-- cgit v1.2.3