diff options
Diffstat (limited to 'src/Haddock')
-rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 1 | ||||
-rw-r--r-- | src/Haddock/Backends/LaTeX.hs | 1 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 1 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/DocMarkup.hs | 1 | ||||
-rw-r--r-- | src/Haddock/Interface/Create.hs | 200 | ||||
-rw-r--r-- | src/Haddock/Interface/LexParseRn.hs | 1 | ||||
-rw-r--r-- | src/Haddock/Interface/Rename.hs | 3 | ||||
-rw-r--r-- | src/Haddock/InterfaceFile.hs | 14 | ||||
-rw-r--r-- | src/Haddock/Types.hs | 2 | ||||
-rw-r--r-- | src/Haddock/Utils.hs | 2 |
10 files changed, 145 insertions, 81 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 6e3e306a..cbb5921d 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -235,6 +235,7 @@ markupTag = Markup { markupIdentifier = box (TagInline "a") . str . out, markupIdentifierUnchecked = box (TagInline "a") . str . out . snd, markupModule = box (TagInline "a") . str, + markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), markupMonospaced = box (TagInline "tt"), markupPic = const $ str " ", diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index e0a530be..ffe507ab 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -1006,6 +1006,7 @@ parLatexMarkup ppId = Markup { markupIdentifier = markupId ppId, markupIdentifierUnchecked = markupId (ppVerbOccName . snd), markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), + markupWarning = \p v -> emph (p v), markupEmphasis = \p v -> emph (p v), markupMonospaced = \p _ -> tt (p Mono), markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 686e9a3e..930a81bf 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -37,7 +37,6 @@ import Name import BasicTypes ( ipNameName ) --- TODO: use DeclInfo DocName or something ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index f506d2b8..ee0a549f 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -39,6 +39,7 @@ parHtmlMarkup qual ppId = Markup { markupIdentifierUnchecked = thecode . ppUncheckedLink qual, markupModule = \m -> let (mdl,ref) = break (=='#') m in ppModuleRef (mkModuleName mdl) ref, + markupWarning = thediv ! [theclass "warning"], markupEmphasis = emphasize, markupMonospaced = thecode, markupUnorderedList = unordList, diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 580aaa83..06d97265 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -34,7 +34,9 @@ import GHC hiding (flags) import HscTypes import Name import Bag -import RdrName (GlobalRdrEnv) +import RdrName +import TcRnTypes (tcg_warns) +import FastString (unpackFS) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -49,6 +51,7 @@ createInterface tm flags modMap instIfaceMap = do dflags = ms_hspp_opts ms instances = modInfoInstances mi exportedNames = modInfoExports mi + warnings = tcg_warns . fst . tm_internals_ $ tm -- The renamed source should always be available to us, but it's best -- to be on the safe side. @@ -68,16 +71,21 @@ createInterface tm flags modMap instIfaceMap = do | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader + (info, mbDoc) <- do + (i, d) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader + return (i, addModuleWarning warnings d) let declsWithDocs = topDecls group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - maps@(docMap, argMap, subMap, declMap) <- + (docMap0, argMap, subMap, declMap) <- liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs - let exports0 = fmap (reverse . map unLoc) mayExports + let docMap = addWarnings warnings gre exportedNames docMap0 + maps = (docMap, argMap, subMap, declMap) + + exports0 = fmap (reverse . map unLoc) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 @@ -90,18 +98,16 @@ createInterface tm flags modMap instIfaceMap = do 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) + let prunedExportItems0 = pruneExportItems exportItems + 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 - | OptPrune `elem` opts = prunedExportItems0 - | otherwise = exportItems + let prunedExportItems + | OptPrune `elem` opts = prunedExportItems0 + | otherwise = exportItems return Interface { ifaceMod = mdl, @@ -126,6 +132,40 @@ createInterface tm flags modMap instIfaceMap = do ------------------------------------------------------------------------------- +-- Warnings +------------------------------------------------------------------------------- + + +-- | 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 mappend) dm wm + where + wm = M.fromList + [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ + , let n = gre_name elt, n `elem` exps ] + + +addModuleWarning :: Warnings -> Maybe (Doc id) -> Maybe (Doc id) +addModuleWarning ws = + case ws of + NoWarnings -> id + WarnSome _ -> id + WarnAll w -> let d = warnToDoc w in Just . maybe d (mappend d) + + +warnToDoc :: WarningTxt -> Doc id +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 + + +------------------------------------------------------------------------------- -- Doc options -- -- Haddock options that are embedded in the source file @@ -160,43 +200,44 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap) -mkMaps :: DynFlags -> GlobalRdrEnv -> [Instance] -> [Name] -> [(LHsDecl Name, [HsDocString])] -> ErrMsgM Maps +mkMaps :: DynFlags + -> GlobalRdrEnv + -> [Instance] + -> [Name] + -> [(LHsDecl Name, [HsDocString])] + -> ErrMsgM Maps mkMaps dflags gre instances exports decls = do - maps <- mapM f decls - let mergeMaps (a,b,c,d) (x,y,z,w) = - (M.unionWith mappend a x, M.unionWith mappend b y, - M.unionWith mappend c z, M.unionWith mappend d w) - let emptyMaps = (M.empty, M.empty, M.empty, M.empty) - return (foldl' mergeMaps emptyMaps maps) + (dm, am, sm, cm) <- unzip4 <$> mapM mappings decls + let f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b + f = M.fromListWith mappend . concat + return (f dm, f am, f sm, f cm) where - instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] - - f :: (LHsDecl Name, [HsDocString]) -> ErrMsgM Maps - f (decl@(L _ d), docs) = do - mayDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs - argDocs <- fmap (M.mapMaybe id) $ Traversable.forM (typeDocs d) $ - \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc + mappings (ldecl@(L _ decl), docs) = do + doc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs + argDocs <- fmap (M.mapMaybe id) $ Traversable.forM (typeDocs decl) $ + lexParseRnHaddockComment dflags NormalHaddockComment gre - let subs_ = subordinates d - let subs_' = filter (\(name, _, _) -> name `elem` exports) subs_ + let subs = [ s | s@(n, _, _) <- subordinates decl, n `elem` exports ] - (subDocs, subArgMap) <- unzip <$> (forM subs_' $ \(name, mbSubDocStr, subFnArgsDocStr) -> do + (subDocs, subArgMap) <- unzip <$> (forM subs $ \(n, mbSubDocStr, subFnArgsDocStr) -> do mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr subFnArgsDoc <- fmap (M.mapMaybe id) $ Traversable.forM subFnArgsDocStr $ - \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc - return ((name, mbSubDoc), (name, subFnArgsDoc))) + lexParseRnHaddockComment dflags NormalHaddockComment gre + return ((n, mbSubDoc), (n, subFnArgsDoc))) - let subNames = map fst subDocs + let names = case decl of + -- See note [2]. + InstD (InstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) + _ -> filter (`elem` exports) (getMainDeclBinder decl) - let names = case d of - InstD (InstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) -- See note [2]. - _ -> filter (`elem` exports) (getMainDeclBinder d) + let subNames = map fst subDocs + dm = [ (n, d) | (n, Just d) <- (zip names (repeat doc)) ++ subDocs ] + am = [ (n, argDocs) | n <- names ] ++ subArgMap + sm = [ (n, subNames) | n <- names ] + cm = [ (n, [ldecl]) | n <- names ++ subNames ] + return (dm, am, sm, cm) - let docMap' = M.fromList (mapMaybe (\(n,doc) -> fmap (n,) doc) ([ (n, mayDoc) | n <- names ] ++ subDocs)) - let argMap' = M.fromList [ (n, argDocs) | n <- names ] `mappend` M.fromList subArgMap - let subMap' = M.fromList [ (n, subNames) | n <- names ] - let dclMap' = M.fromList [ (n, [decl]) | n <- names ++ subNames ] - return (docMap', argMap', subMap', dclMap') + instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] -- Note [2]: @@ -393,18 +434,10 @@ mkExportItems (maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags = case optExports of Nothing -> fullModuleContents dflags gre maps decls - Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports + Just exports -> liftM concat $ mapM lookupExport exports where decls = filter (not . isInstD . unLoc) decls0 - -- A type signature can have multiple names, like: - -- foo, bar :: Types.. - -- When going throug the exported names we have to take care to detect such - -- situations and remove the duplicates. - commaDeclared (ExportDecl (L _ sig1) _ _ _) (ExportDecl (L _ sig2) _ _ _) = - getMainDeclBinder sig1 == getMainDeclBinder sig2 - commaDeclared _ _ = False - lookupExport (IEVar x) = declWith x lookupExport (IEThingAbs t) = declWith t @@ -433,13 +466,12 @@ mkExportItems declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = - let (doc, subs) = exportDecl t docMap argMap subMap in case findDecl t of - [L _ (ValD _)] -> do + ([L _ (ValD _)], (doc, _)) -> do -- Top-level binding without type signature export <- hiValExportItem t doc return [export] - ds | decl : _ <- filter (not . isValD . unLoc) ds -> + (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) in case () of _ @@ -461,21 +493,20 @@ mkExportItems return [] -- normal case - | otherwise -> return [ mkExportDecl t newDecl (doc, subs) ] + | otherwise -> return [ mkExportDecl t newDecl docs_ ] where - -- Since a single signature might refer to many names, we - -- need to filter the ones that are actually exported. This - -- requires modifying the type signatures to "hide" the - -- names that are not exported. + -- A single signature might refer to many names, but we + -- create an export item for a single name only. So we + -- modify the signature to contain only that single name. newDecl = case decl of (L loc (SigD sig)) -> - L loc . SigD . fromJust $ filterSigNames isExported sig + L loc . SigD . fromJust $ filterSigNames (== t) sig -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. _ -> decl -- Declaration from another package - [] -> do + ([], _) -> do mayDecl <- hiDecl t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] @@ -489,7 +520,7 @@ mkExportItems let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> do - return [ mkExportDecl t decl (exportDecl t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] @@ -506,13 +537,15 @@ mkExportItems isExported = (`elem` exportedNames) - findDecl :: Name -> [LHsDecl Name] - findDecl name - | mdl == thisMod = maybe [] id (M.lookup name declMap) - | Just iface <- M.lookup mdl modMap = maybe [] id (M.lookup name (ifaceDeclMap iface)) - | otherwise = [] + 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) + | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = + (ds, lookupDocs n (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) + | otherwise = ([], (noDocForDecl, [])) where - mdl = nameModule name + m = nameModule n hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name)) @@ -533,12 +566,14 @@ hiValExportItem name doc = do Just decl -> return (ExportDecl decl doc [] []) -exportDecl :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) -exportDecl name docMap argMap subMap = - let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in - let doc = (M.lookup name docMap, lookupArgMap name) in - let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in - (doc, subs) +-- | Lookup docs for a declaration from maps. +lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs n docMap argMap subMap = + let lookupArgDoc x = M.findWithDefault M.empty x argMap in + let doc = (M.lookup n docMap, lookupArgDoc n) in + let subs = M.findWithDefault [] n subMap in + let subDocs = [ (s, (M.lookup s docMap, lookupArgDoc s)) | s <- subs ] in + (doc, subDocs) -- | Return all export items produced by an exported module. That is, we're @@ -605,8 +640,21 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = - liftM catMaybes $ mapM mkExportItem decls + liftM catMaybes $ mapM mkExportItem (expandSig decls) where + -- A type signature can have multiple names, like: + -- foo, bar :: Types.. + -- + -- We go through the list of declarations and expand type signatures, so + -- that every type signature has exactly one name! + expandSig :: [LHsDecl name] -> [LHsDecl name] + expandSig = foldr f [] + where + f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] + f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + 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 (L _ (DocD (DocGroup lev docStr))) = do mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr return $ fmap (ExportGroup lev "") mbDoc @@ -616,12 +664,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, _) = exportDecl name docMap argMap subMap in + let (doc, _) = lookupDocs name docMap argMap subMap in fmap Just (hiValExportItem name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = - let (doc, subs) = exportDecl name docMap argMap subMap in + let (doc, subs) = lookupDocs name docMap argMap subMap in return $ Just (ExportDecl decl doc subs []) | otherwise = return Nothing diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index f70c5953..ebd2b8fc 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -108,6 +108,7 @@ rename gre = rn a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b -- If an id can refer to multiple things, we give precedence to type -- constructors. + DocWarning doc -> DocWarning (rn doc) DocEmphasis doc -> DocEmphasis (rn doc) DocMonospaced doc -> DocMonospaced (rn doc) DocUnorderedList docs -> DocUnorderedList (map rn docs) diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 691dafbc..582c2ccd 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -169,6 +169,9 @@ renameDoc d = case d of return (DocIdentifier x') DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x) DocModule str -> return (DocModule str) + DocWarning doc -> do + doc' <- renameDoc doc + return (DocWarning doc') DocEmphasis doc -> do doc' <- renameDoc doc return (DocEmphasis doc') diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index fcf7fe65..e998ffec 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -65,13 +65,13 @@ binaryInterfaceMagic = 0xD0Cface -- we version our interface files accordingly. binaryInterfaceVersion :: Word16 #if __GLASGOW_HASKELL__ == 702 -binaryInterfaceVersion = 19 +binaryInterfaceVersion = 20 #elif __GLASGOW_HASKELL__ == 703 -binaryInterfaceVersion = 19 +binaryInterfaceVersion = 20 #elif __GLASGOW_HASKELL__ == 704 -binaryInterfaceVersion = 19 +binaryInterfaceVersion = 20 #elif __GLASGOW_HASKELL__ == 705 -binaryInterfaceVersion = 19 +binaryInterfaceVersion = 20 #else #error Unknown GHC version #endif @@ -469,6 +469,9 @@ instance (Binary id) => Binary (Doc id) where put_ bh (DocIdentifierUnchecked x) = do putByte bh 16 put_ bh x + put_ bh (DocWarning ag) = do + putByte bh 17 + put_ bh ag get bh = do h <- getByte bh case h of @@ -523,6 +526,9 @@ instance (Binary id) => Binary (Doc id) where 16 -> do x <- get bh return (DocIdentifierUnchecked x) + 17 -> do + ag <- get bh + return (DocWarning ag) _ -> fail "invalid binary data found" diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index a3a7db15..fe4039a7 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -283,6 +283,7 @@ data Doc id | DocIdentifier id | DocIdentifierUnchecked (ModuleName, OccName) | DocModule String + | DocWarning (Doc id) | DocEmphasis (Doc id) | DocMonospaced (Doc id) | DocUnorderedList [Doc id] @@ -324,6 +325,7 @@ data DocMarkup id a = Markup , markupIdentifier :: id -> a , markupIdentifierUnchecked :: (ModuleName, OccName) -> a , markupModule :: String -> a + , markupWarning :: a -> a , markupEmphasis :: a -> a , markupMonospaced :: a -> a , markupUnorderedList :: [a] -> a diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index de97ef85..9865fdf1 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -410,6 +410,7 @@ markup m (DocParagraph d) = markupParagraph m (markup m d) markup m (DocIdentifier x) = markupIdentifier m x markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x markup m (DocModule mod0) = markupModule m mod0 +markup m (DocWarning d) = markupWarning m (markup m d) markup m (DocEmphasis d) = markupEmphasis m (markup m d) markup m (DocMonospaced d) = markupMonospaced m (markup m d) markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) @@ -436,6 +437,7 @@ idMarkup = Markup { markupIdentifier = DocIdentifier, markupIdentifierUnchecked = DocIdentifierUnchecked, markupModule = DocModule, + markupWarning = DocWarning, markupEmphasis = DocEmphasis, markupMonospaced = DocMonospaced, markupUnorderedList = DocUnorderedList, |