From 8344dcced9607de9f969ed2e226346e5ba57df03 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 14:13:15 +0200 Subject: Fix typo in comment --- src/Haddock/Interface/Create.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Haddock/Interface/Create.hs') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 50f468db..6fa6c598 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -764,7 +764,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) --- | Keep exprt items with docs. +-- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems = filter hasDoc where -- cgit v1.2.3 From 0730c1b4088fd5d2c36671b0adf3c9e11222e233 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 14:13:37 +0200 Subject: Add a type signature for a where-binding --- src/Haddock/Interface/Create.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'src/Haddock/Interface/Create.hs') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 6fa6c598..32d187a5 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -690,6 +690,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names f x xs = x : xs + mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do mbDoc <- liftErrMsg $ processDocString dflags gre docStr return $ fmap (ExportGroup lev "") mbDoc -- cgit v1.2.3 From ed9ff6c9ba93f0759d276715fd1162edc4d21ad7 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Mon, 13 Aug 2012 22:12:27 +0100 Subject: Improve haddock memory usage --- haddock.cabal | 1 + src/Haddock/Interface/Create.hs | 55 +++++++++++++++++----------- src/Haddock/Interface/LexParseRn.hs | 5 ++- src/Haddock/Interface/ParseModuleHeader.hs | 1 + src/Haddock/Types.hs | 58 +++++++++++++++--------------- 5 files changed, 69 insertions(+), 51 deletions(-) (limited to 'src/Haddock/Interface/Create.hs') diff --git a/haddock.cabal b/haddock.cabal index 5c950f98..116ee00c 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -88,6 +88,7 @@ executable haddock directory, pretty, containers, + deepseq, array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 64995a5f..32f287f5 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections, BangPatterns #-} +{-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Create @@ -27,6 +28,7 @@ import Data.Maybe import Data.Monoid import Data.Ord import Control.Applicative +import Control.DeepSeq import Control.Monad import qualified Data.Traversable as T @@ -48,13 +50,13 @@ import FastString (unpackFS) createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface createInterface tm flags modMap instIfaceMap = do - let ms = pm_mod_summary . tm_parsed_module $ tm - mi = moduleInfo tm - safety = modInfoSafe mi - mdl = ms_mod ms - dflags = ms_hspp_opts ms - instances = modInfoInstances mi - exportedNames = modInfoExports mi + let ms = pm_mod_summary . tm_parsed_module $ tm + mi = moduleInfo tm + !safety = modInfoSafe mi + mdl = ms_mod ms + dflags = ms_hspp_opts ms + !instances = modInfoInstances mi + !exportedNames = modInfoExports mi (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm @@ -72,13 +74,13 @@ createInterface tm flags modMap instIfaceMap = do | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - (info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader + (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - maps@(docMap, argMap, subMap, declMap) <- + maps@(!docMap, !argMap, !subMap, !declMap) <- liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs let exports0 = fmap (reverse . map unLoc) mayExports @@ -92,24 +94,25 @@ createInterface tm flags modMap instIfaceMap = do exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports instances instIfaceMap dflags - let visibleNames = mkVisibleNames exportItems opts + let !visibleNames = mkVisibleNames exportItems opts -- Measure haddock documentation coverage. let prunedExportItems0 = pruneExportItems exportItems - haddockable = 1 + length exportItems -- module + exports - haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 - coverage = (haddockable, haddocked) + !haddockable = 1 + length exportItems -- module + exports + !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 + !coverage = (haddockable, haddocked) -- Prune the export list to just those declarations that have -- documentation, if the 'prune' option is on. - let prunedExportItems + let prunedExportItems' | OptPrune `elem` opts = prunedExportItems0 | otherwise = exportItems + !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - let aliases = + let !aliases = mkAliasMap dflags $ tm_renamed_source tm - return Interface { + return $! Interface { ifaceMod = mdl, ifaceOrigFilename = msHsFilePath ms, ifaceInfo = info, @@ -179,7 +182,7 @@ moduleWarning ws = case ws of NoWarnings -> Nothing WarnSome _ -> Nothing - WarnAll w -> Just (warnToDoc w) + WarnAll w -> Just $! warnToDoc w warnToDoc :: WarningTxt -> Doc id @@ -187,7 +190,8 @@ warnToDoc 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 + format x xs = let !str = force $ concat (x : map unpackFS xs) + in DocWarning $ DocParagraph $ DocString str ------------------------------------------------------------------------------- @@ -254,7 +258,12 @@ mkMaps dflags gre instances decls = do am = [ (n, args) | n <- ns ] ++ zip subNs subArgs sm = [ (n, subNs) | n <- ns ] cm = [ (n, [ldecl]) | n <- ns ++ subNs ] - return (dm, am, sm, cm) + seqList ns `seq` + seqList subNs `seq` + doc `seq` + seqList subDocs `seq` + seqList subArgs `seq` + return (dm, am, sm, cm) instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] @@ -774,7 +783,8 @@ pruneExportItems = filter hasDoc mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name] mkVisibleNames exports opts | OptHide `elem` opts = [] - | otherwise = concatMap exportName exports + | otherwise = let ns = concatMap exportName exports + in seqList ns `seq` ns where exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs where subs = map fst (expItemSubDocs e) @@ -782,6 +792,9 @@ mkVisibleNames exports opts -- we don't want links to go to them. exportName _ = [] +seqList :: [a] -> () +seqList [] = () +seqList (x : xs) = x `seq` seqList xs -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index a5eb1143..3ad9719e 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.LexParseRn @@ -78,7 +80,8 @@ processModuleHeader dflags gre safety mayStr = do tell ["haddock module header parse failed: " ++ msg] return failure Right (hmi, doc) -> do - let hmi' = hmi { hmi_description = rename dflags gre <$> hmi_description hmi } + let !descr = rename dflags gre <$> hmi_description hmi + hmi' = hmi { hmi_description = descr } doc' = rename dflags gre doc return (hmi', Just doc') return (hmi { hmi_safety = Just $ showPpr dflags safety }, doc) diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs index 411b6661..18f4c768 100644 --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.ParseModuleHeader diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index e1e7ce4b..fbd05fae 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -59,10 +59,10 @@ type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources data Interface = Interface { -- | The module behind this interface. - ifaceMod :: Module + ifaceMod :: !Module -- | Original file name of the module. - , ifaceOrigFilename :: FilePath + , ifaceOrigFilename :: !FilePath -- | Textual information about the module. , ifaceInfo :: !(HaddockModInfo Name) @@ -71,7 +71,7 @@ data Interface = Interface , ifaceDoc :: !(Documentation Name) -- | Documentation header with cross-reference information. - , ifaceRnDoc :: Documentation DocName + , ifaceRnDoc :: !(Documentation DocName) -- | Haddock options for this module (prune, ignore-exports, etc). , ifaceOptions :: ![DocOption] @@ -79,22 +79,22 @@ data Interface = Interface -- | Declarations originating from the module. Excludes declarations without -- names (instances and stand-alone documentation comments). Includes -- names of subordinate declarations mapped to their parent declarations. - , ifaceDeclMap :: Map Name [LHsDecl Name] + , ifaceDeclMap :: !(Map Name [LHsDecl Name]) -- | Documentation of declarations originating from the module (including -- subordinates). - , ifaceDocMap :: DocMap Name - , ifaceArgMap :: ArgMap Name + , ifaceDocMap :: !(DocMap Name) + , ifaceArgMap :: !(ArgMap Name) -- | Documentation of declarations originating from the module (including -- subordinates). - , ifaceRnDocMap :: DocMap DocName - , ifaceRnArgMap :: ArgMap DocName + , ifaceRnDocMap :: !(DocMap DocName) + , ifaceRnArgMap :: !(ArgMap DocName) - , ifaceSubMap :: Map Name [Name] + , ifaceSubMap :: !(Map Name [Name]) , ifaceExportItems :: ![ExportItem Name] - , ifaceRnExportItems :: [ExportItem DocName] + , ifaceRnExportItems :: ![ExportItem DocName] -- | All names exported by the module. , ifaceExports :: ![Name] @@ -105,14 +105,14 @@ data Interface = Interface , ifaceVisibleExports :: ![Name] -- | Aliases of module imports as in @import A.B.C as C@. - , ifaceModuleAliases :: AliasMap + , ifaceModuleAliases :: !AliasMap -- | Instances exported by the module. , ifaceInstances :: ![ClsInst] -- | The number of haddockable and haddocked items in the module, as a -- tuple. Haddockable items are the exports and the module itself. - , ifaceHaddockCoverage :: (Int,Int) + , ifaceHaddockCoverage :: !(Int, Int) } @@ -172,51 +172,51 @@ data ExportItem name = ExportDecl { -- | A declaration. - expItemDecl :: LHsDecl name + expItemDecl :: !(LHsDecl name) -- | Maybe a doc comment, and possibly docs for arguments (if this -- decl is a function or type-synonym). - , expItemMbDoc :: DocForDecl name + , expItemMbDoc :: !(DocForDecl name) -- | Subordinate names, possibly with documentation. - , expItemSubDocs :: [(name, DocForDecl name)] + , expItemSubDocs :: ![(name, DocForDecl name)] -- | Instances relevant to this declaration, possibly with -- documentation. - , expItemInstances :: [DocInstance name] + , expItemInstances :: ![DocInstance name] } -- | An exported entity for which we have no documentation (perhaps because it -- resides in another package). | ExportNoDecl - { expItemName :: name + { expItemName :: !name -- | Subordinate names. - , expItemSubs :: [name] + , expItemSubs :: ![name] } -- | A section heading. | ExportGroup { -- | Section level (1, 2, 3, ...). - expItemSectionLevel :: Int + expItemSectionLevel :: !Int -- | Section id (for hyperlinks). - , expItemSectionId :: String + , expItemSectionId :: !String -- | Section heading text. - , expItemSectionText :: Doc name + , expItemSectionText :: !(Doc name) } -- | Some documentation. - | ExportDoc (Doc name) + | ExportDoc !(Doc name) -- | A cross-reference to another module. - | ExportModule Module + | ExportModule !Module data Documentation name = Documentation { documentationDoc :: Maybe (Doc name) - , documentationWarning :: Maybe (Doc name) + , documentationWarning :: !(Maybe (Doc name)) } deriving Functor @@ -355,11 +355,11 @@ data DocMarkup id a = Markup data HaddockModInfo name = HaddockModInfo - { hmi_description :: Maybe (Doc name) - , hmi_portability :: Maybe String - , hmi_stability :: Maybe String - , hmi_maintainer :: Maybe String - , hmi_safety :: Maybe String + { hmi_description :: (Maybe (Doc name)) + , hmi_portability :: (Maybe String) + , hmi_stability :: (Maybe String) + , hmi_maintainer :: (Maybe String) + , hmi_safety :: (Maybe String) } -- cgit v1.2.3 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(-) (limited to 'src/Haddock/Interface/Create.hs') 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

    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 (limited to 'src/Haddock/Interface/Create.hs') 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

    -- cgit v1.2.3 From 4334a1657865b5a745ac0e8c56de4318fcd54bac Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 15:40:53 +0200 Subject: Minor formatting change --- src/Haddock/Interface/Create.hs | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) (limited to 'src/Haddock/Interface/Create.hs') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 3eb5205c..2ffe8de8 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -116,25 +116,25 @@ createInterface tm flags modMap instIfaceMap = do modWarn <- liftErrMsg $ moduleWarning dflags gre warnings return $! Interface { - ifaceMod = mdl, - ifaceOrigFilename = msHsFilePath ms, - ifaceInfo = info, - ifaceDoc = Documentation mbDoc modWarn, - ifaceRnDoc = Documentation Nothing Nothing, - ifaceOptions = opts, - ifaceDocMap = docMap, - ifaceArgMap = argMap, - ifaceRnDocMap = M.empty, - ifaceRnArgMap = M.empty, - ifaceExportItems = prunedExportItems, - ifaceRnExportItems = [], - ifaceExports = exportedNames, - ifaceVisibleExports = visibleNames, - ifaceDeclMap = declMap, - ifaceSubMap = subMap, - ifaceModuleAliases = aliases, - ifaceInstances = instances, - ifaceHaddockCoverage = coverage + ifaceMod = mdl + , ifaceOrigFilename = msHsFilePath ms + , ifaceInfo = info + , ifaceDoc = Documentation mbDoc modWarn + , ifaceRnDoc = Documentation Nothing Nothing + , ifaceOptions = opts + , ifaceDocMap = docMap + , ifaceArgMap = argMap + , ifaceRnDocMap = M.empty + , ifaceRnArgMap = M.empty + , ifaceExportItems = prunedExportItems + , ifaceRnExportItems = [] + , ifaceExports = exportedNames + , ifaceVisibleExports = visibleNames + , ifaceDeclMap = declMap + , ifaceSubMap = subMap + , ifaceModuleAliases = aliases + , ifaceInstances = instances + , ifaceHaddockCoverage = coverage } mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName -- cgit v1.2.3 From 37a4e2c3b71280fdee7b217dd9ddff090ed34873 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 16:03:43 +0200 Subject: Properly handle deprecation messages for re-exported things (fixes #220) --- src/Haddock/Interface/Create.hs | 7 +- src/Haddock/Types.hs | 5 ++ tests/html-tests/tests/DeprecatedReExport.hs | 3 + tests/html-tests/tests/DeprecatedReExport.html.ref | 91 ++++++++++++++++++++++ .../tests/mini_DeprecatedReExport.html.ref | 31 ++++++++ 5 files changed, 134 insertions(+), 3 deletions(-) create mode 100644 tests/html-tests/tests/DeprecatedReExport.hs create mode 100644 tests/html-tests/tests/DeprecatedReExport.html.ref create mode 100644 tests/html-tests/tests/mini_DeprecatedReExport.html.ref (limited to 'src/Haddock/Interface/Create.hs') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 2ffe8de8..6c121ad4 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -92,7 +92,9 @@ createInterface tm flags modMap instIfaceMap = do warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames - exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports + let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) + + exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps exports instances instIfaceMap dflags let !visibleNames = mkVisibleNames exportItems opts @@ -135,6 +137,7 @@ createInterface tm flags modMap instIfaceMap = do , ifaceModuleAliases = aliases , ifaceInstances = instances , ifaceHaddockCoverage = coverage + , ifaceWarningMap = warningMap } mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName @@ -170,8 +173,6 @@ lookupModuleDyn dflags Nothing mdlName = -- Warnings ------------------------------------------------------------------------------- -type WarningMap = DocMap Name - mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap mkWarningMap dflags warnings gre exps = case warnings of NoWarnings -> return M.empty diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 9be46748..181ea026 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -114,8 +114,13 @@ data Interface = Interface -- | The number of haddockable and haddocked items in the module, as a -- tuple. Haddockable items are the exports and the module itself. , ifaceHaddockCoverage :: !(Int, Int) + + -- | Warnings for things defined in this module. + , ifaceWarningMap :: !WarningMap } +type WarningMap = DocMap Name + -- | A subset of the fields of 'Interface' that we store in the interface -- files. diff --git a/tests/html-tests/tests/DeprecatedReExport.hs b/tests/html-tests/tests/DeprecatedReExport.hs new file mode 100644 index 00000000..10a8c6a2 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedReExport.hs @@ -0,0 +1,3 @@ +module DeprecatedReExport (foo) where + +import DeprecatedFunction diff --git a/tests/html-tests/tests/DeprecatedReExport.html.ref b/tests/html-tests/tests/DeprecatedReExport.html.ref new file mode 100644 index 00000000..17988951 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedReExport.html.ref @@ -0,0 +1,91 @@ + +DeprecatedReExport
    Safe HaskellNone

    DeprecatedReExport

    Synopsis

    Documentation

    foo :: Int

    Deprecated: use bar instead +

    some documentation for foo +

    diff --git a/tests/html-tests/tests/mini_DeprecatedReExport.html.ref b/tests/html-tests/tests/mini_DeprecatedReExport.html.ref new file mode 100644 index 00000000..de5dcf95 --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedReExport.html.ref @@ -0,0 +1,31 @@ + +DeprecatedReExport

    DeprecatedReExport

    -- cgit v1.2.3