From a6bcb1e464ff33161f84c5794f5ae239604fb7e5 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 17 May 2012 18:35:21 +0200 Subject: Attach warnings to `Documentation` type --- src/Haddock/Backends/Hoogle.hs | 2 +- src/Haddock/Backends/LaTeX.hs | 8 ++-- src/Haddock/Backends/Xhtml.hs | 2 +- src/Haddock/Backends/Xhtml/Decl.hs | 4 +- src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 +- src/Haddock/Interface/Create.hs | 75 +++++++++++++++------------------ src/Haddock/Interface/Rename.hs | 3 +- src/Haddock/Types.hs | 13 ++++-- 8 files changed, 56 insertions(+), 53 deletions(-) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 98eeaab8..d27ca80f 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -198,7 +198,7 @@ ppCtor dat subdocs con = lookupCon subdocs (con_name con) -- DOCUMENTATION ppDocumentation :: Outputable o => Documentation o -> [String] -ppDocumentation (Documentation d) = doc d +ppDocumentation (Documentation d w) = doc d ++ doc w doc :: Outputable o => Maybe (Doc o) -> [String] diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 6cce753c..31ba3b0b 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -208,7 +208,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t)))) - (Documentation Nothing, argDocs) _ _) + (Documentation Nothing Nothing, argDocs) _ _) | Map.null argDocs = Just (map unLoc lnames, t) isSimpleSig _ = Nothing @@ -640,7 +640,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = forall = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -650,7 +650,7 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst + mbDoc = lookup name subdocs >>= combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -1041,7 +1041,7 @@ docToLaTeX doc = markup latexMarkup doc Plain documentationToLaTeX :: Documentation DocName -> Maybe LaTeX -documentationToLaTeX (Documentation mDoc) = docToLaTeX `fmap` mDoc +documentationToLaTeX = fmap docToLaTeX . combineDocumentation rdrDocToLaTeX :: Doc RdrName -> LaTeX diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index c5925cda..5a3cbac0 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -508,7 +508,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual -- todo: if something has only sub-docs, or fn-args-docs, should -- it be measured here and thus prevent omitting the synopsis? - has_doc (ExportDecl _ (Documentation mDoc, _) _ _) = isJust mDoc + has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _) = isJust mDoc || isJust mWarning has_doc (ExportNoDecl _ _) = False has_doc (ExportModule _) = False has_doc _ = True diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 66b78cbd..21a33ea8 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -588,7 +588,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) forall_ = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -600,7 +600,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = []) where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst + mbDoc = lookup name subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index cd1595f6..052116ee 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -86,7 +86,7 @@ docElement el content_ = docSection :: Qualification -> Documentation DocName -> Html -docSection qual (Documentation doc) = maybe noHtml (docSection_ qual) doc +docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation docSection_ :: Qualification -> Doc DocName -> Html diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index e2cc9959..1513349f 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -72,28 +72,23 @@ createInterface tm flags modMap instIfaceMap = do | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - (info, mbDoc) <- do - (i, d) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader - return (i, addModuleWarning warnings d) + (info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - (docMap0, argMap, subMap, declMap) <- + maps@(docMap, argMap, subMap, declMap) <- liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs - let docMap = addWarnings warnings gre exportedNames docMap0 - maps = (docMap, argMap, subMap, declMap) - - exports0 = fmap (reverse . map unLoc) mayExports + let exports0 = fmap (reverse . map unLoc) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 liftErrMsg $ warnAboutFilteredDecls mdl decls - exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports + exportItems <- mkExportItems modMap mdl warnings gre exportedNames decls maps exports instances instIfaceMap dflags let visibleNames = mkVisibleNames exportItems opts @@ -117,8 +112,8 @@ createInterface tm flags modMap instIfaceMap = do ifaceMod = mdl, ifaceOrigFilename = msHsFilePath ms, ifaceInfo = info, - ifaceDoc = Documentation mbDoc, - ifaceRnDoc = Documentation Nothing, + ifaceDoc = Documentation mbDoc (moduleWarning warnings), + ifaceRnDoc = Documentation Nothing Nothing, ifaceOptions = opts, ifaceDocMap = docMap, ifaceArgMap = argMap, @@ -169,25 +164,23 @@ lookupModuleDyn dflags Nothing mdlName = ------------------------------------------------------------------------------- --- | Add warnings to documentation. If there is a warning for an identifier --- with no documentation, create a piece of documentation that just contains --- the warning. -addWarnings :: Warnings -> GlobalRdrEnv -> [Name] -> DocMap Name -> DocMap Name -addWarnings NoWarnings _ _ dm = dm -addWarnings (WarnAll _) _ _ dm = dm -addWarnings (WarnSome ws) gre exps dm = M.unionWith (flip (<>)) dm wm +-- FIXME: simplify +lookupWarning :: Warnings -> GlobalRdrEnv -> Name -> Maybe (Doc id) +lookupWarning NoWarnings _ _ = Nothing +lookupWarning (WarnAll _) _ _ = Nothing +lookupWarning (WarnSome ws) gre name = M.lookup name wm where wm = M.fromList [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ - , let n = gre_name elt, n `elem` exps ] + , let n = gre_name elt, n == name ] -addModuleWarning :: Warnings -> Maybe (Doc id) -> Maybe (Doc id) -addModuleWarning ws = +moduleWarning :: Warnings -> Maybe (Doc id) +moduleWarning ws = case ws of - NoWarnings -> id - WarnSome _ -> id - WarnAll w -> let d = warnToDoc w in Just . maybe d (d <>) + NoWarnings -> Nothing + WarnSome _ -> Nothing + WarnAll w -> Just (warnToDoc w) warnToDoc :: WarningTxt -> Doc id @@ -459,6 +452,7 @@ collectDocs = go Nothing [] mkExportItems :: IfaceMap -> Module -- this module + -> Warnings -> GlobalRdrEnv -> [Name] -- exported names (orig) -> [LHsDecl Name] @@ -469,10 +463,10 @@ mkExportItems -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems - modMap thisMod gre exportedNames decls0 + modMap thisMod warnings gre exportedNames decls0 (maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags = case optExports of - Nothing -> fullModuleContents dflags gre maps decls + Nothing -> fullModuleContents dflags warnings gre maps decls Just exports -> liftM concat $ mapM lookupExport exports where decls = filter (not . isInstD . unLoc) decls0 @@ -483,7 +477,7 @@ mkExportItems lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = - moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps + moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps lookupExport (IEGroup lev docStr) = liftErrMsg $ ifDoc (processDocString dflags gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) @@ -559,7 +553,7 @@ mkExportItems let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> - return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl t decl (lookupDocs t warnings gre (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] @@ -579,9 +573,9 @@ mkExportItems findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n | m == thisMod, Just ds <- M.lookup n declMap = - (ds, lookupDocs n docMap argMap subMap) + (ds, lookupDocs n warnings gre docMap argMap subMap) | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = - (ds, lookupDocs n (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) + (ds, lookupDocs n warnings gre (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) | otherwise = ([], (noDocForDecl, [])) where m = nameModule n @@ -606,15 +600,15 @@ hiValExportItem name doc = do -- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs n docMap argMap subMap = +lookupDocs :: Name -> Warnings -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs n warnings gre docMap argMap subMap = let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in let subs = M.findWithDefault [] n subMap in let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in (doc, subDocs) where - lookupDoc = Documentation . (`M.lookup` docMap) + lookupDoc name = Documentation (M.lookup name docMap) (lookupWarning warnings gre name) -- | Return all export items produced by an exported module. That is, we're @@ -633,6 +627,7 @@ lookupDocs n docMap argMap subMap = moduleExports :: Module -- ^ Module A -> ModuleName -- ^ The real name of B, the exported module -> DynFlags -- ^ The flags used when typechecking A + -> Warnings -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A -> [LHsDecl Name] -- ^ All the declarations in A @@ -640,8 +635,8 @@ moduleExports :: Module -- ^ Module A -> InstIfaceMap -- ^ Interfaces in other packages -> Maps -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items -moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap maps - | m == thisMod = fullModuleContents dflags gre maps decls +moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps + | m == thisMod = fullModuleContents dflags warnings gre maps decls | otherwise = case M.lookup m ifaceMap of Just iface @@ -679,8 +674,8 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map -- (For more information, see Trac #69) -fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] -fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = +fullModuleContents :: DynFlags -> Warnings -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] +fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = liftM catMaybes $ mapM mkExportItem (expandSig decls) where -- A type signature can have multiple names, like: @@ -705,12 +700,12 @@ fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = mkExportItem (L _ (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. - let (doc, _) = lookupDocs name docMap argMap subMap in + let (doc, _) = lookupDocs name warnings gre docMap argMap subMap in fmap Just (hiValExportItem name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = - let (doc, subs) = lookupDocs name docMap argMap subMap in + let (doc, subs) = lookupDocs name warnings gre docMap argMap subMap in return $ Just (ExportDecl decl doc subs []) | otherwise = return Nothing @@ -774,7 +769,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems = filter hasDoc where - hasDoc (ExportDecl{expItemMbDoc = (Documentation d, _)}) = isJust d + hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index fd2a1f10..7f322eca 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -148,7 +148,8 @@ renameDocForDecl (doc, fnArgsDoc) = renameDocumentation :: Documentation Name -> RnM (Documentation DocName) -renameDocumentation (Documentation mDoc) = Documentation <$> mapM renameDoc mDoc +renameDocumentation (Documentation mDoc mWarning) = + Documentation `fmap` mapM renameDoc mDoc `ap` mapM renameDoc mWarning renameLDocHsSyn :: LHsDocString -> RnM LHsDocString diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index f8d51b2b..048a7ff7 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -24,6 +24,7 @@ import Control.Exception import Control.Arrow import Data.Typeable import Data.Map (Map) +import Data.Maybe import qualified Data.Map as Map import Data.Monoid import GHC hiding (NoLink) @@ -213,9 +214,15 @@ data ExportItem name -- | A cross-reference to another module. | ExportModule Module +data Documentation name = Documentation + { documentationDoc :: Maybe (Doc name) + , documentationWarning :: Maybe (Doc name) + } deriving Functor -newtype Documentation name = Documentation (Maybe (Doc name)) - deriving Functor + +combineDocumentation :: Documentation name -> Maybe (Doc name) +combineDocumentation (Documentation Nothing Nothing) = Nothing +combineDocumentation (Documentation mDoc mWarning) = Just (fromMaybe mempty mWarning `mappend` fromMaybe mempty mDoc) -- | Arguments and result are indexed by Int, zero-based from the left, @@ -225,7 +232,7 @@ type DocForDecl name = (Documentation name, FnArgsDoc name) noDocForDecl :: DocForDecl name -noDocForDecl = (Documentation Nothing, Map.empty) +noDocForDecl = (Documentation Nothing Nothing, Map.empty) unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name -- cgit v1.2.3