From b19a4bea999c684e092e0ea0feaf02ff8747d2a5 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 4 Apr 2012 16:32:11 +0200 Subject: Add an optional label to URLs --- src/Haddock/Interface/LexParseRn.hs | 2 +- src/Haddock/Interface/Rename.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index 56ed1b42..de006386 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -113,7 +113,7 @@ rename gre = rn DocCodeBlock doc -> DocCodeBlock (rn doc) DocIdentifierUnchecked x -> DocIdentifierUnchecked x DocModule str -> DocModule str - DocURL str -> DocURL str + DocHyperlink l -> DocHyperlink l DocPic str -> DocPic str DocAName str -> DocAName str DocExamples e -> DocExamples e diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index b703da0f..18e5f1d2 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -200,7 +200,7 @@ renameDoc d = case d of DocCodeBlock doc -> do doc' <- renameDoc doc return (DocCodeBlock doc') - DocURL str -> return (DocURL str) + DocHyperlink l -> return (DocHyperlink l) DocPic str -> return (DocPic str) DocAName str -> return (DocAName str) DocExamples e -> return (DocExamples e) -- cgit v1.2.3 From 1483f369caaacc25e07f9715b15e49c35205b417 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 13:37:02 +0200 Subject: Use LANGUAGE pragmas instead of default-extensions in cabal file --- haddock.cabal | 4 ---- src/.ghci | 2 +- src/Haddock/Interface/AttachInstances.hs | 2 +- src/Haddock/InterfaceFile.hs | 2 +- src/Haddock/Utils.hs | 1 + src/Main.hs | 2 +- tests/unit-tests/.ghci | 2 +- 7 files changed, 6 insertions(+), 9 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/haddock.cabal b/haddock.cabal index 9d6f1a9b..609df296 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -104,8 +104,6 @@ executable haddock main-is: Main.hs hs-source-dirs: src - default-extensions: CPP, DeriveDataTypeable, - ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs other-modules: @@ -165,8 +163,6 @@ library build-depends: QuickCheck >= 2.1 && < 3 hs-source-dirs: src - default-extensions: CPP, DeriveDataTypeable, - ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs exposed-modules: diff --git a/src/.ghci b/src/.ghci index f00e6d55..3e83f04c 100644 --- a/src/.ghci +++ b/src/.ghci @@ -1 +1 @@ -:set -i../dist/build/autogen -i../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../dist/build/autogen/cabal_macros.h -XCPP -XDeriveDataTypeable -XScopedTypeVariables -XMagicHash +:set -i../dist/build/autogen -i../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../dist/build/autogen/cabal_macros.h diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index c012f2e0..d9f4350f 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP, MagicHash #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index ebe15325..7abb0583 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index ad61e88a..ef1b0469 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils diff --git a/src/Main.hs b/src/Main.hs index 8c15661d..52406821 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Main diff --git a/tests/unit-tests/.ghci b/tests/unit-tests/.ghci index 10563664..dcc5b13d 100644 --- a/tests/unit-tests/.ghci +++ b/tests/unit-tests/.ghci @@ -1 +1 @@ -:set -i../../src -i../../dist/build/autogen -i../../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../../dist/build/autogen/cabal_macros.h -XCPP -XDeriveDataTypeable -XScopedTypeVariables -XMagicHash +:set -i../../src -i../../dist/build/autogen -i../../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../../dist/build/autogen/cabal_macros.h -- cgit v1.2.3 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') 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') 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 2cbeae0385bddcd294a5b80a4e2c86b66ff3e1cc Mon Sep 17 00:00:00 2001 From: Roman Cheplyaka Date: Wed, 13 Jun 2012 14:31:22 +0300 Subject: Hide "internal" instances This fixes #37 (http://trac.haskell.org/haddock/ticket/37) Precisely, we show an instance iff its class and all the types are exported by non-hidden modules. --- src/Haddock/Interface.hs | 7 +++- src/Haddock/Interface/AttachInstances.hs | 55 ++++++++++++++++++++++++++++---- 2 files changed, 55 insertions(+), 7 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index 09f01883..0003cba2 100644 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -43,6 +43,7 @@ import Haddock.Utils import Control.Monad import Data.List import qualified Data.Map as Map +import qualified Data.Set as Set import Distribution.Verbosity import System.Directory import System.FilePath @@ -71,8 +72,12 @@ processModules verbosity modules flags extIfaces = do , iface <- ifInstalledIfaces ext ] interfaces <- createIfaces0 verbosity modules flags instIfaceMap + let exportedNames = + Set.unions $ map (Set.fromList . ifaceExports) $ + filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces + mods = Set.fromList $ map ifaceMod interfaces out verbosity verbose "Attaching instances..." - interfaces' <- attachInstances interfaces instIfaceMap + interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap out verbosity verbose "Building cross-linking environment..." -- Combine the link envs of the external packages into one diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index c012f2e0..089f31b4 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -20,6 +20,7 @@ import Haddock.Convert import Control.Arrow import Data.List import qualified Data.Map as Map +import qualified Data.Set as Set import GHC import Name @@ -36,21 +37,24 @@ import PrelNames import FastString #define FSLIT(x) (mkFastString# (x#)) +type ExportedNames = Set.Set Name +type Modules = Set.Set Module +type ExportInfo = (ExportedNames, Modules) -attachInstances :: [Interface] -> InstIfaceMap -> Ghc [Interface] -attachInstances ifaces instIfaceMap = mapM attach ifaces +attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] +attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces where -- TODO: take an IfaceMap as input ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] attach iface = do - newItems <- mapM (attachToExportItem iface ifaceMap instIfaceMap) + newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap) (ifaceExportItems iface) return $ iface { ifaceExportItems = newItems } -attachToExportItem :: Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name) -attachToExportItem iface ifaceMap instIfaceMap export = +attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name) +attachToExportItem expInfo iface ifaceMap instIfaceMap export = case export of ExportDecl { expItemDecl = L _ (TyClD d) } -> do mb_info <- getAllInfo (unLoc (tcdLName d)) @@ -59,7 +63,8 @@ attachToExportItem iface ifaceMap instIfaceMap export = expItemInstances = case mb_info of Just (_, _, instances) -> - let insts = map (first synifyInstHead) $ sortImage (first instHead) + let insts = map (first synifyInstHead) $ sortImage (first instHead) $ + filter (\((_,_,cls,tys),_) -> not $ isInstanceHidden expInfo cls tys) [ (instanceHead i, getName i) | i <- instances ] in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap) | (inst, name) <- insts ] @@ -140,3 +145,41 @@ funTyConName = mkWiredInName gHC_PRIM funTyConKey (ATyCon funTyCon) -- Relevant TyCon BuiltInSyntax + +-------------------------------------------------------------------------------- +-- Filtering hidden instances +-------------------------------------------------------------------------------- + +-- | A class or data type is hidden iff +-- +-- * it is defined in one of the modules that are being processed +-- +-- * and it is not exported by any non-hidden module +isNameHidden :: ExportInfo -> Name -> Bool +isNameHidden (names, modules) name = + nameModule name `Set.member` modules && + not (name `Set.member` names) + +-- | We say that an instance is «hidden» iff its class or any (part) +-- of its type(s) is hidden. +isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool +isInstanceHidden expInfo cls tys = + instClassHidden || instTypeHidden + where + instClassHidden :: Bool + instClassHidden = isNameHidden expInfo $ getName cls + + instTypeHidden :: Bool + instTypeHidden = any typeHidden tys + + nameHidden :: Name -> Bool + nameHidden = isNameHidden expInfo + + typeHidden :: Type -> Bool + typeHidden t = + case t of + TyVarTy {} -> False + AppTy t1 t2 -> typeHidden t1 || typeHidden t2 + TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args + FunTy t1 t2 -> typeHidden t1 || typeHidden t2 + ForAllTy _ ty -> typeHidden ty -- 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') 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 42422b76fd65dfd37ada0d4da5a85fdf30bf0fa2 Mon Sep 17 00:00:00 2001 From: David Waern Date: Fri, 7 Sep 2012 14:29:27 +0200 Subject: Follow changes in GHC. --- src/Haddock/Interface/AttachInstances.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index 8fff4d7a..ebe62cb6 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -186,3 +186,4 @@ isInstanceHidden expInfo cls tys = TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args FunTy t1 t2 -> typeHidden t1 || typeHidden t2 ForAllTy _ ty -> typeHidden ty + LitTy _ -> False -- cgit v1.2.3 From 6ccf78e15a525282fef61bc4f58a279aa9c21771 Mon Sep 17 00:00:00 2001 From: David Waern Date: Fri, 28 Sep 2012 19:50:20 +0200 Subject: Fix spurious superclass constraints bug. --- src/Haddock/Interface/AttachInstances.hs | 31 +++++++++++++++++++++++-------- 1 file changed, 23 insertions(+), 8 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index ebe62cb6..4b5f159d 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -22,19 +22,20 @@ import Data.List import qualified Data.Map as Map import qualified Data.Set as Set -import GHC -import Name -import InstEnv import Class +import FastString +import GHC import GhcMonad (withSession) -import TysPrim( funTyCon ) +import Id +import InstEnv import MonadUtils (liftIO) +import Name +import PrelNames import TcRnDriver (tcRnGetInfo) +import TyCon import TypeRep +import TysPrim( funTyCon ) import Var hiding (varName) -import TyCon -import PrelNames -import FastString #define FSLIT(x) (mkFastString# (x#)) type ExportedNames = Set.Set Name @@ -65,7 +66,7 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = Just (_, _, instances) -> let insts = map (first synifyInstHead) $ sortImage (first instHead) $ filter (\((_,_,cls,tys),_) -> not $ isInstanceHidden expInfo cls tys) - [ (instanceHead i, getName i) | i <- instances ] + [ (instanceHead' i, getName i) | i <- instances ] in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap) | (inst, name) <- insts ] Nothing -> [] @@ -94,6 +95,20 @@ lookupInstDoc name iface ifaceMap instIfaceMap = modName = nameModule name +-- | Like GHC's 'instanceHead' but drops "silent" arguments. +instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type]) +instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys) + where + dfun = is_dfun ispec + (tvs, theta, cls, tys) = instanceHead ispec + + +-- | Drop "silent" arguments. See GHC Note [Silent superclass +-- arguments]. +dropSilentArgs :: DFunId -> ThetaType -> ThetaType +dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta + + -- | Like GHC's getInfo but doesn't cut things out depending on the -- interative context, which we don't set sufficiently anyway. getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst])) -- cgit v1.2.3 From 72675c1bf281b81041a19014b1b7df03a0de9488 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 9 Apr 2012 15:45:57 +0900 Subject: Add markup support for properties --- src/Haddock/Backends/Hoogle.hs | 1 + src/Haddock/Backends/LaTeX.hs | 1 + src/Haddock/Backends/Xhtml/DocMarkup.hs | 1 + src/Haddock/Interface/LexParseRn.hs | 1 + src/Haddock/Interface/Rename.hs | 1 + src/Haddock/InterfaceFile.hs | 6 ++++++ src/Haddock/Lex.x | 8 ++++++++ src/Haddock/Parse.y | 6 ++++++ src/Haddock/Types.hs | 2 ++ src/Haddock/Utils.hs | 2 ++ 10 files changed, 29 insertions(+) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 4949daa1..28d35aca 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -256,6 +256,7 @@ markupTag dflags = Markup { markupCodeBlock = box TagPre, markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), markupAName = const $ str "", + markupProperty = box TagPre . str, markupExample = box TagPre . str . unlines . map exampleToString } diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 68cf715a..bf1e6ac3 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -1003,6 +1003,7 @@ parLatexMarkup ppId = Markup { markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", markupHyperlink = \l _ -> markupLink l, markupAName = \_ _ -> empty, + markupProperty = \p _ -> quote $ verb $ text p, markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e } where diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index e75cfaba..aa4ba377 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -50,6 +50,7 @@ parHtmlMarkup qual ppId = Markup { markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url mLabel, markupAName = \aname -> namedAnchor aname << "", markupPic = \path -> image ! [src path], + markupProperty = pre . toHtml, markupExample = examplesToHtml } where diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index 3ad9719e..ced12d8d 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -121,6 +121,7 @@ rename dflags gre = rn DocHyperlink l -> DocHyperlink l DocPic str -> DocPic str DocAName str -> DocAName str + DocProperty p -> DocProperty p DocExamples e -> DocExamples e DocEmpty -> DocEmpty DocString str -> DocString str diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 0f702683..55c9a5da 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -202,6 +202,7 @@ renameDoc d = case d of DocHyperlink l -> return (DocHyperlink l) DocPic str -> return (DocPic str) DocAName str -> return (DocAName str) + DocProperty p -> return (DocProperty p) DocExamples e -> return (DocExamples e) diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 8fa8ce95..59b83c70 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -481,6 +481,9 @@ instance (Binary id) => Binary (Doc id) where put_ bh (DocWarning ag) = do putByte bh 17 put_ bh ag + put_ bh (DocProperty x) = do + putByte bh 18 + put_ bh x get bh = do h <- getByte bh case h of @@ -538,6 +541,9 @@ instance (Binary id) => Binary (Doc id) where 17 -> do ag <- get bh return (DocWarning ag) + 18 -> do + x <- get bh + return (DocProperty x) _ -> fail "invalid binary data found" diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x index b9ebe688..35e6dd8a 100644 --- a/src/Haddock/Lex.x +++ b/src/Haddock/Lex.x @@ -50,6 +50,7 @@ $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:] <0,para> { $ws* \n ; $ws* \> { begin birdtrack } + $ws* prop\> { strtoken TokPropertyPrompt `andBegin` propertyexpr } $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr } $ws* [\*\-] { token TokBullet `andBegin` string } $ws* \[ { token TokDefStart `andBegin` def } @@ -61,6 +62,7 @@ $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:] -- beginning of a line { $ws* \> { begin birdtrack } + $ws* prop\> { strtoken TokPropertyPrompt `andBegin` propertyexpr } $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr } $ws* \n { token TokPara `andBegin` para } -- Here, we really want to be able to say @@ -84,6 +86,10 @@ $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:] .* \n { strtokenNL TokExampleResult `andBegin` example } + .* \n { strtokenNL TokPropertyExpression `andBegin` property } + + () { token TokPara `andBegin` para } + { $special { strtoken $ \s -> TokSpecial (head s) } \<\< [^\>]* \>\> { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) } @@ -129,6 +135,8 @@ data Token | TokEmphasis String | TokAName String | TokBirdTrack String + | TokPropertyPrompt String + | TokPropertyExpression String | TokExamplePrompt String | TokExampleExpression String | TokExampleResult String diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y index b34b14b9..c8a1a558 100644 --- a/src/Haddock/Parse.y +++ b/src/Haddock/Parse.y @@ -35,6 +35,8 @@ import Data.List (stripPrefix) '-' { (TokBullet,_) } '(n)' { (TokNumber,_) } '>..' { (TokBirdTrack $$,_) } + PPROMPT { (TokPropertyPrompt $$,_) } + PEXP { (TokPropertyExpression $$,_) } PROMPT { (TokExamplePrompt $$,_) } RESULT { (TokExampleResult $$,_) } EXP { (TokExampleExpression $$,_) } @@ -73,12 +75,16 @@ defpara :: { (Doc RdrName, Doc RdrName) } para :: { Doc RdrName } : seq { docParagraph $1 } | codepara { DocCodeBlock $1 } + | property { DocProperty $1 } | examples { DocExamples $1 } codepara :: { Doc RdrName } : '>..' codepara { docAppend (DocString $1) $2 } | '>..' { DocString $1 } +property :: { String } + : PPROMPT PEXP { strip $2 } + examples :: { [Example] } : example examples { $1 : $2 } | example { [$1] } diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index fbd05fae..05fc9747 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -306,6 +306,7 @@ data Doc id | DocHyperlink Hyperlink | DocPic String | DocAName String + | DocProperty String | DocExamples [Example] deriving (Functor) @@ -350,6 +351,7 @@ data DocMarkup id a = Markup , markupHyperlink :: Hyperlink -> a , markupAName :: String -> a , markupPic :: String -> a + , markupProperty :: String -> a , markupExample :: [Example] -> a } diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index b8f32589..4424ad73 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -432,6 +432,7 @@ markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) markup m (DocHyperlink l) = markupHyperlink m l markup m (DocAName ref) = markupAName m ref markup m (DocPic img) = markupPic m img +markup m (DocProperty p) = markupProperty m p markup m (DocExamples e) = markupExample m e @@ -459,6 +460,7 @@ idMarkup = Markup { markupHyperlink = DocHyperlink, markupAName = DocAName, markupPic = DocPic, + markupProperty = DocProperty, markupExample = DocExamples } -- cgit v1.2.3 From 2107860036788651c8286f9e1435472b3e799736 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 13 Oct 2012 19:02:16 +0200 Subject: Handle HsExplicitListTy in renameer (fixes #213) --- src/Haddock/Interface/Rename.hs | 2 + tests/html-tests/tests/AdvanceTypes.hs | 9 +++ tests/html-tests/tests/AdvanceTypes.html.ref | 97 +++++++++++++++++++++++ tests/html-tests/tests/mini_AdvanceTypes.html.ref | 33 ++++++++ 4 files changed, 141 insertions(+) create mode 100644 tests/html-tests/tests/AdvanceTypes.hs create mode 100644 tests/html-tests/tests/AdvanceTypes.html.ref create mode 100644 tests/html-tests/tests/mini_AdvanceTypes.html.ref (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 55c9a5da..4bdbcb76 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -271,6 +271,8 @@ renameType t = case t of HsTyLit x -> return (HsTyLit x) + HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b + _ -> error "renameType" diff --git a/tests/html-tests/tests/AdvanceTypes.hs b/tests/html-tests/tests/AdvanceTypes.hs new file mode 100644 index 00000000..939fdf07 --- /dev/null +++ b/tests/html-tests/tests/AdvanceTypes.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +module AdvanceTypes where + +data Pattern :: [*] -> * where + Nil :: Pattern '[] + Cons :: Maybe h -> Pattern t -> Pattern (h ': t) diff --git a/tests/html-tests/tests/AdvanceTypes.html.ref b/tests/html-tests/tests/AdvanceTypes.html.ref new file mode 100644 index 00000000..bac545be --- /dev/null +++ b/tests/html-tests/tests/AdvanceTypes.html.ref @@ -0,0 +1,97 @@ + +AdvanceTypes
Safe HaskellNone

AdvanceTypes

Documentation

data Pattern where

Constructors

Nil :: Pattern `[]` 
Cons :: Maybe h -> Pattern t -> Pattern (h : t) 
diff --git a/tests/html-tests/tests/mini_AdvanceTypes.html.ref b/tests/html-tests/tests/mini_AdvanceTypes.html.ref new file mode 100644 index 00000000..59d8dcb1 --- /dev/null +++ b/tests/html-tests/tests/mini_AdvanceTypes.html.ref @@ -0,0 +1,33 @@ + +AdvanceTypes

AdvanceTypes

data Pattern

-- cgit v1.2.3 From 401dd8302ddc3c1716762278f2d23fd354e1d1d4 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 13 Oct 2012 20:46:31 +0200 Subject: Better error messages --- src/Haddock/Interface/Rename.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 4bdbcb76..358fb964 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -273,8 +273,12 @@ renameType t = case t of HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b - _ -> error "renameType" - + HsQuasiQuoteTy _ -> error "renameType: HsQuasiQuoteTy" + HsSpliceTy _ _ _ -> error "renameType: HsSpliceTy" + HsRecTy _ -> error "renameType: HsRecTy" + HsCoreTy _ -> error "renameType: HsCoreTy" + HsExplicitTupleTy _ _ -> error "renameType: HsExplicitTupleTy" + HsWrapTy _ _ -> error "renameType: HsWrapTy" renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) -- cgit v1.2.3 From 80666e9b384277eb208fa99476634ee1559b3a7c Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 00:21:07 +0200 Subject: Simplify RnM type --- src/Haddock/Interface/Rename.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 358fb964..792e571a 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -82,33 +82,32 @@ renameInterface dflags renamingEnv warnings iface = -------------------------------------------------------------------------------- -newtype GenRnM n a = - RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function - -> (a,[n]) +newtype RnM a = + RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function + -> (a,[Name]) } -type RnM a = GenRnM Name a - -instance Monad (GenRnM n) where +instance Monad RnM where (>>=) = thenRn return = returnRn -instance Functor (GenRnM n) where +instance Functor RnM where fmap f x = do a <- x; return (f a) -instance Applicative (GenRnM n) where +instance Applicative RnM where pure = return (<*>) = ap -returnRn :: a -> GenRnM n a +returnRn :: a -> RnM a returnRn a = RnM (const (a,[])) -thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b +thenRn :: RnM a -> (a -> RnM b) -> RnM b m `thenRn` k = RnM (\lkp -> case unRn m lkp of (a,out1) -> case unRn (k a) lkp of (b,out2) -> (b,out1++out2)) getLookupRn :: RnM (Name -> (Bool, DocName)) getLookupRn = RnM (\lkp -> (lkp,[])) + outRn :: Name -> RnM () outRn name = RnM (const ((),[name])) -- cgit v1.2.3 From 3ba97f8470f401c968a2ea6f5fd1e7cae1c69028 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 00:23:35 +0200 Subject: Simplify lookupRn --- src/Haddock/Interface/Rename.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 792e571a..6e80da86 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -111,12 +111,12 @@ getLookupRn = RnM (\lkp -> (lkp,[])) outRn :: Name -> RnM () outRn name = RnM (const ((),[name])) -lookupRn :: (DocName -> a) -> Name -> RnM a -lookupRn and_then name = do +lookupRn :: Name -> RnM DocName +lookupRn name = do lkp <- getLookupRn case lkp name of - (False,maps_to) -> do outRn name; return (and_then maps_to) - (True, maps_to) -> return (and_then maps_to) + (False,maps_to) -> do outRn name; return maps_to + (True, maps_to) -> return maps_to runRnFM :: LinkEnv -> RnM a -> (a,[Name]) @@ -133,7 +133,7 @@ runRnFM env rn = unRn rn lkp rename :: Name -> RnM DocName -rename = lookupRn id +rename = lookupRn renameL :: Located Name -> RnM (Located DocName) @@ -476,8 +476,8 @@ renameExportItem item = case item of return (inst', idoc') return (ExportDecl decl' doc' subs' instances') ExportNoDecl x subs -> do - x' <- lookupRn id x - subs' <- mapM (lookupRn id) subs + x' <- lookupRn x + subs' <- mapM lookupRn subs return (ExportNoDecl x' subs') ExportDoc doc -> do doc' <- renameDoc doc -- cgit v1.2.3 From 91335e5044b6c09bbe8d28e2e9443378e5ddbd90 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 14 Oct 2012 10:34:58 +0200 Subject: Handle more cases in renameType --- src/Haddock/Interface/Rename.hs | 33 +++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 14 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 6e80da86..9f3a4155 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -270,14 +270,16 @@ renameType t = case t of HsTyLit x -> return (HsTyLit x) - HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b - - HsQuasiQuoteTy _ -> error "renameType: HsQuasiQuoteTy" + HsWrapTy a b -> HsWrapTy a <$> renameType b + HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a + HsCoreTy a -> pure (HsCoreTy a) + HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b + HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b + HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a HsSpliceTy _ _ _ -> error "renameType: HsSpliceTy" - HsRecTy _ -> error "renameType: HsRecTy" - HsCoreTy _ -> error "renameType: HsCoreTy" - HsExplicitTupleTy _ _ -> error "renameType: HsExplicitTupleTy" - HsWrapTy _ _ -> error "renameType: HsWrapTy" + +renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName) +renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) @@ -403,22 +405,25 @@ renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' , con_details = details', con_res = restype', con_doc = mbldoc' }) where - renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields + renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do a' <- renameLType a b' <- renameLType b return (InfixCon a' b') - renameField (ConDeclField name t doc) = do - name' <- renameL name - t' <- renameLType t - doc' <- mapM renameLDocHsSyn doc - return (ConDeclField name' t' doc') - renameResType (ResTyH98) = return ResTyH98 renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t + +renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName) +renameConDeclFieldField (ConDeclField name t doc) = do + name' <- renameL name + t' <- renameLType t + doc' <- mapM renameLDocHsSyn doc + return (ConDeclField name' t' doc') + + renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of TypeSig lnames ltype -> do -- 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') 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') 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') 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') 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