From dfc2cb4e31d6756b2d6ca7f87e80d8913751a4b7 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 11:58:13 +0200 Subject: Allow haddock markup in deprecation messages --- haddock.cabal | 1 + src/Haddock/Interface/Create.hs | 49 +++++++++++++--------- src/Haddock/Parse.y | 2 +- src/Haddock/Types.hs | 39 ++++++++++++++++- tests/html-tests/tests/BugDeprecated.html.ref | 18 +++++--- tests/html-tests/tests/BugExportHeadings.html.ref | 9 ++-- tests/html-tests/tests/DeprecatedClass.html.ref | 12 ++++-- tests/html-tests/tests/DeprecatedData.html.ref | 18 +++++--- tests/html-tests/tests/DeprecatedFunction.hs | 8 +++- tests/html-tests/tests/DeprecatedFunction.html.ref | 28 ++++++++++++- .../html-tests/tests/DeprecatedFunction2.html.ref | 3 +- .../html-tests/tests/DeprecatedFunction3.html.ref | 3 +- tests/html-tests/tests/DeprecatedModule.hs | 2 +- tests/html-tests/tests/DeprecatedModule.html.ref | 5 ++- tests/html-tests/tests/DeprecatedModule2.html.ref | 3 +- tests/html-tests/tests/DeprecatedNewtype.html.ref | 12 ++++-- tests/html-tests/tests/DeprecatedRecord.html.ref | 3 +- .../html-tests/tests/DeprecatedTypeFamily.html.ref | 6 ++- .../tests/DeprecatedTypeSynonym.html.ref | 6 ++- tests/html-tests/tests/ModuleWithWarning.hs | 2 +- tests/html-tests/tests/ModuleWithWarning.html.ref | 5 ++- .../tests/mini_DeprecatedFunction.html.ref | 6 +++ 22 files changed, 179 insertions(+), 61 deletions(-) diff --git a/haddock.cabal b/haddock.cabal index b77fc5ac..88c18cd3 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -189,6 +189,7 @@ test-suite spec base , ghc , containers + , deepseq , array -- NOTE: As of this writing, Cabal does not properly handle alex/happy for 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 diff --git a/tests/html-tests/tests/BugDeprecated.html.ref b/tests/html-tests/tests/BugDeprecated.html.ref index f632d670..913b189d 100644 --- a/tests/html-tests/tests/BugDeprecated.html.ref +++ b/tests/html-tests/tests/BugDeprecated.html.ref @@ -96,7 +96,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_BugDeprecated.html");} >

Deprecated: for foo

Deprecated: for foo +

Deprecated: for baz

Deprecated: for baz +

Deprecated: for bar

Deprecated: for bar +

Deprecated: for one

Deprecated: for one +

some documentation for one, two and three @@ -155,7 +159,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_BugDeprecated.html");} >

Deprecated: for three

Deprecated: for three +

some documentation for one, two and three @@ -172,7 +177,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_BugDeprecated.html");} >

Deprecated: for two

Deprecated: for two +

some documentation for one, two and three diff --git a/tests/html-tests/tests/BugExportHeadings.html.ref b/tests/html-tests/tests/BugExportHeadings.html.ref index d3298b2e..457e2c50 100644 --- a/tests/html-tests/tests/BugExportHeadings.html.ref +++ b/tests/html-tests/tests/BugExportHeadings.html.ref @@ -166,7 +166,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_BugExportHeadings.html >

Deprecated: for one

Deprecated: for one +

Deprecated: for two

Deprecated: for two +

Deprecated: for three

Deprecated: for three +

Deprecated: SomeClass

Deprecated: SomeClass +

some class @@ -106,7 +107,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedClass.html") >

Deprecated: foo

Deprecated: foo +

documentation for foo @@ -126,7 +128,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedClass.html") >

Deprecated: SomeOtherClass

Deprecated: SomeOtherClass +

Deprecated: bar

Deprecated: bar +

Deprecated: Foo

Deprecated: Foo +

type Foo @@ -110,7 +111,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedData.html"); >

Deprecated: Foo

Deprecated: Foo +

constructor Foo @@ -125,7 +127,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedData.html"); >

Deprecated: Bar

Deprecated: Bar +

constructor Bar @@ -145,7 +148,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedData.html"); >

Deprecated: One

Deprecated: One +

Deprecated: One

Deprecated: One +

Deprecated: Two

Deprecated: Two +

:: Int
  • bar :: Int

    • Deprecated: use bar instead

    Deprecated: use bar instead +

    some documentation foo + >some documentation for foo +

    bar :: Int

    some documentation for bar

    Deprecated: use bar instead

    Deprecated: use bar instead +

    Deprecated: use bar instead

    Deprecated: use bar instead +

    Deprecated: Use Foo instead

    Deprecated: Use Foo instead +

    Documentation for

    Deprecated: Use Foo instead

    Deprecated: Use Foo instead +

    Deprecated: SomeNewType

    Deprecated: SomeNewType +

    some documentation @@ -100,7 +101,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedNewtype.html >

    Deprecated: SomeNewTypeConst

    Deprecated: SomeNewTypeConst +

    constructor docu @@ -120,7 +122,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedNewtype.html >

    Deprecated: SomeOtherNewType

    Deprecated: SomeOtherNewType +

    Deprecated: SomeOtherNewTypeConst

    Deprecated: SomeOtherNewTypeConst +

    Deprecated: do not use this

    Deprecated: do not use this +

    some value diff --git a/tests/html-tests/tests/DeprecatedTypeFamily.html.ref b/tests/html-tests/tests/DeprecatedTypeFamily.html.ref index cd091802..ffc069a6 100644 --- a/tests/html-tests/tests/DeprecatedTypeFamily.html.ref +++ b/tests/html-tests/tests/DeprecatedTypeFamily.html.ref @@ -72,7 +72,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedTypeFamily.h >

    Deprecated: SomeTypeFamily

    Deprecated: SomeTypeFamily +

    some documentation @@ -89,7 +90,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedTypeFamily.h >

    Deprecated: SomeOtherTypeFamily

    Deprecated: SomeOtherTypeFamily +

    Deprecated: TypeSyn

    Deprecated: TypeSyn +

    some documentation @@ -97,7 +98,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedTypeSynonym. >

    Deprecated: OtherTypeSyn

    Deprecated: OtherTypeSyn +

    Warning: This is an unstable interface.

    Warning: This is an unstable interface. Prefer functions from Prelude instead! +

    Documentation for foo

    bar