From b03be836b8491e09e31bc7a1bba14588db79df11 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 3 Dec 2011 05:20:20 +0100 Subject: Slightly better behaviour on top-levels without type signatures. - Docs don't get attached to the next top-level with signature by mistake. - If there's an export list and the top-level is part of it, its doc comment shows up in the documentation. --- src/Haddock/GhcUtils.hs | 12 ++- src/Haddock/Interface/Create.hs | 203 +++++++++++++++------------------------- src/Haddock/Types.hs | 8 +- 3 files changed, 94 insertions(+), 129 deletions(-) (limited to 'src') diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index 2fb8c8a3..989563b7 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -20,6 +20,7 @@ import Data.Version import Control.Applicative ( (<$>) ) import Control.Arrow import Data.Foldable hiding (concatMap) +import Data.Function import Data.Traversable import Distribution.Compat.ReadP import Distribution.Text @@ -141,6 +142,11 @@ isInstD (TyClD d) = isFamInstDecl d isInstD _ = False +isValD :: HsDecl a -> Bool +isValD (ValD _) = True +isValD _ = False + + declATs :: HsDecl a -> [a] declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d declATs _ = [] @@ -167,6 +173,10 @@ reL :: a -> Located a reL = L undefined +before :: Located a -> Located a -> Bool +before = (<) `on` getLoc + + instance Foldable (GenLocated l) where foldMap f (L _ x) = f x @@ -253,7 +263,7 @@ modifySessionDynFlags f = do -- | A variant of 'gbracket' where the return value from the first computation -- is not required. gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c -gbracket_ before after thing = gbracket before (const after) (const thing) +gbracket_ before_ after thing = gbracket before_ (const after) (const thing) ------------------------------------------------------------------------------- diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 155cd938..5f633a0b 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -24,6 +24,7 @@ import qualified Data.Map as Map import Data.Map (Map) import Data.List import Data.Maybe +import Data.Monoid import Data.Ord import Control.Monad import qualified Data.Traversable as Traversable @@ -67,8 +68,8 @@ createInterface tm flags modMap instIfaceMap = do declDocs = [ (decl, doc) | (L _ decl, (Just doc, _), _) <- decls0 ] instanceDocMap = mkInstanceDocMap localInsts declDocs - decls = filterOutInstances decls0 - declMap = mkDeclMap decls + declMap = mkDeclMap decls0 + decls = filter (\(L _ d, _, _) -> not (isInstD d || isValD d)) decls0 exports0 = fmap (reverse . map unLoc) optExports exports | OptIgnoreExports `elem` opts = Nothing @@ -171,16 +172,23 @@ mkSubMap declMap exports = filterSubs (_, _, subs) = [ sub | (sub, _) <- subs, sub `elem` exports ] --- Make a map from names to 'DeclInfo's. Exclude declarations that don't have --- names (e.g. instances and stand-alone documentation comments). Include --- subordinate names, but map them to their parent declarations. +-- Make a map from names to 'DeclInfo's. +-- +-- Exclude nameless declarations (e.g. instances and stand-alone documentation +-- comments). Merge declarations of same names (i.e. type signatures and +-- bindings). Include subordinate names, mapped to their parent declarations. mkDeclMap :: [DeclInfo] -> Map Name DeclInfo -mkDeclMap decls = Map.fromList . concat $ - [ decls_ ++ subDecls - | (parent@(L _ d), doc, subs) <- decls +mkDeclMap decls = Map.fromListWith merge . concat $ + [ decls_ ++ subDecls | (parent@(L _ d), doc, subs) <- decls , let decls_ = [ (name, (parent, doc, subs)) | name <- getMainDeclBinder d ] subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ] - , not (isDocD d), not (isInstD d) ] + , not (isDocD d), not (isInstD d) + ] + where + merge (s@(L _ (SigD _)), s_doc, _) (v@(L _ (ValD _)), v_doc, _) = (s, f s s_doc v v_doc, []) + merge (v@(L _ (ValD _)), v_doc, _) (s@(L _ (SigD _)), s_doc, _) = (s, f s s_doc v v_doc, []) + merge a _ = a + f s s_doc v v_doc | s `before` v = s_doc `mappend` v_doc | otherwise = v_doc `mappend` s_doc declInfos :: DynFlags -> GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo] @@ -267,25 +275,25 @@ topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)] topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup -filterOutInstances :: [(Located (HsDecl a), b, c)] -> [(Located (HsDecl a), b, c)] -filterOutInstances = filter (\(L _ d, _, _) -> not (isInstD d)) - - -- | Take all declarations except pragmas, infix decls, rules and value -- bindings from an 'HsGroup'. declsFromGroup :: HsGroup Name -> [Decl] declsFromGroup group_ = - mkDecls (concat . hs_tyclds) TyClD group_ ++ - mkDecls hs_derivds DerivD group_ ++ - mkDecls hs_defds DefD group_ ++ - mkDecls hs_fords ForD group_ ++ - mkDecls hs_docs DocD group_ ++ - mkDecls hs_instds InstD group_ ++ - mkDecls (typesigs . hs_valds) SigD group_ + mkDecls (concat . hs_tyclds) TyClD group_ ++ + mkDecls hs_derivds DerivD group_ ++ + mkDecls hs_defds DefD group_ ++ + mkDecls hs_fords ForD group_ ++ + mkDecls hs_docs DocD group_ ++ + mkDecls hs_instds InstD group_ ++ + mkDecls (typesigs . hs_valds) SigD group_ ++ + mkDecls (valbinds . hs_valds) ValD group_ where typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs typesigs _ = error "expected ValBindsOut" + valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds + valbinds _ = error "expected ValBindsOut" + -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor @@ -335,6 +343,7 @@ filterDecls decls = filter (isHandled . unL . fst) decls isHandled (TyClD {}) = True isHandled (InstD {}) = True isHandled (SigD d) = isVanillaLSig (reL d) + isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD _) = True isHandled _ = False @@ -482,6 +491,14 @@ mkExportItems modMap thisMod gre exportedNames decls declMap declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = case findDecl t of + -- Top-level binding from this package without type signature + Just (L _ (ValD _), doc, _) -> do + mayDecl <- ifaceDecl t + case mayDecl of + Nothing -> return [ ExportNoDecl t [] ] + Just decl -> return [ ExportDecl decl doc [] [] ] + + -- Top-level declaration from this module Just (decl, doc, subs) -> let declNames = getMainDeclBinder (unL decl) in case () of @@ -516,114 +533,36 @@ mkExportItems modMap thisMod gre exportedNames decls declMap -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. _ -> decl + + -- Declaration from another package Nothing -> do - -- If we can't find the declaration, it must belong to - -- another package - mbTyThing <- liftGhcToErrMsgGhc $ lookupName t - -- show the name as exported as well as the name's - -- defining module (because the latter is where we - -- looked for the .hi/.haddock). It's to help people - -- debugging after all, so good to show more info. - let exportInfoString = - moduleString thisMod ++ "." ++ getOccString t - ++ ": " - ++ pretty (nameModule t) ++ "." ++ getOccString t - - case mbTyThing of - Nothing -> do - liftErrMsg $ tell - ["Warning: Couldn't find TyThing for exported " - ++ exportInfoString ++ "; not documenting."] - -- Is getting to here a bug in Haddock? - -- Aren't the .hi files always present? - return [ ExportNoDecl t [] ] - Just tyThing -> do - let hsdecl = tyThingToLHsDecl tyThing - -- This is not the ideal way to implement haddockumentation - -- for functions/values without explicit type signatures. - -- - -- However I didn't find an easy way to implement it properly, - -- and as long as we're using lookupName it is going to find - -- the types of local inferenced binds. If we don't check for - -- this at all, then we'll get the "warning: couldn't find - -- .haddock" which is wrong. - -- - -- The reason this is not an ideal implementation - -- (besides that we take a trip to desugared syntax and back - -- unnecessarily) - -- is that Haddock won't be able to detect doc-strings being - -- attached to such a function, such as, - -- - -- > -- | this is an identity function - -- > id a = a - -- - -- . It's more difficult to say what it ought to mean in cases - -- where multiple exports are bound at once, like - -- - -- > -- | comment... - -- > (a, b) = ... - -- - -- especially since in the export-list they might not even - -- be next to each other. But a proper implementation would - -- really need to find the type of *all* exports as well as - -- addressing all these issues. This implementation works - -- adequately. Do you see a way to improve the situation? - -- Please go ahead! I got stuck trying to figure out how to - -- get the 'PostTcType's that we want for all the bindings - -- of an HsBind (you get 'LHsBinds' from 'GHC.typecheckedSource' - -- for example). - -- - -- But I might be missing something obvious. What's important - -- /here/ is that we behave reasonably when we run into one of - -- those exported type-inferenced values. - isLocalAndTypeInferenced <- liftGhcToErrMsgGhc $ do - let mdl = nameModule t - if modulePackageId mdl == thisPackage dflags then - isLoaded (moduleName mdl) - else return False - - if isLocalAndTypeInferenced then do - -- I don't think there can be any subs in this case, - -- currently? But better not to rely on it. - let subs = subordinatesWithNoDocs (unLoc hsdecl) - return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ] - else - -- We try to get the subs and docs - -- from the installed interface of that package. - case Map.lookup (nameModule t) instIfaceMap of - -- It's Nothing in the cases where I thought - -- Haddock has already warned the user: "Warning: The - -- documentation for the following packages are not - -- installed. No links will be generated to these packages: - -- ..." - -- But I guess it was Cabal creating that warning. Anyway, - -- this is more serious than links: it's exported decls where - -- we don't have the docs that they deserve! - - -- We could use 'subordinates' to find the Names of the subs - -- (with no docs). Is that necessary? Yes it is, otherwise - -- e.g. classes will be shown without their exported subs. - Nothing -> do - liftErrMsg $ tell - ["Warning: Couldn't find .haddock for exported " - ++ exportInfoString] - let subs = subordinatesWithNoDocs (unLoc hsdecl) - return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ] - Just iface -> do - let subs = case Map.lookup t (instSubMap iface) of - Nothing -> [] - Just x -> x - return [ mkExportDecl t - ( hsdecl - , fromMaybe noDocForDecl $ - Map.lookup t (instDocMap iface) - , map (\subt -> - ( subt , - fromMaybe noDocForDecl $ - Map.lookup subt (instDocMap iface) - ) - ) subs - )] + mayDecl <- ifaceDecl t + case mayDecl of + Nothing -> return [ ExportNoDecl t [] ] + Just decl -> do + -- We try to get the subs and docs + -- from the installed .haddock file for that package. + case Map.lookup (nameModule t) instIfaceMap of + Nothing -> do + liftErrMsg $ tell + ["Warning: Couldn't find .haddock for export " ++ pretty t] + let subs = subordinatesWithNoDocs (unLoc decl) + return [ mkExportDecl t (decl, noDocForDecl, subs) ] + Just iface -> do + let subs = case Map.lookup t (instSubMap iface) of + Nothing -> [] + Just x -> x + return [ mkExportDecl t + ( decl + , fromMaybe noDocForDecl $ + Map.lookup t (instDocMap iface) + , map (\subt -> + ( subt , + fromMaybe noDocForDecl $ + Map.lookup subt (instDocMap iface) + ) + ) subs + )] mkExportDecl :: Name -> DeclInfo -> ExportItem Name @@ -648,6 +587,16 @@ mkExportItems modMap thisMod gre exportedNames decls declMap m = nameModule n +ifaceDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name)) +ifaceDecl t = do + mayTyThing <- liftGhcToErrMsgGhc $ lookupName t + case mayTyThing of + Nothing -> do + liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty t] + return Nothing + Just x -> return (Just (tyThingToLHsDecl x)) + + -- | Return all export items produced by an exported module. That is, we're -- interested in the exports produced by \"module B\" in such a scenario: -- diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index fbaf89c5..2b78905c 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -25,6 +25,7 @@ import Control.Arrow import Data.Typeable import Data.Map (Map) import qualified Data.Map as Map +import Data.Monoid import GHC hiding (NoLink) import OccName @@ -289,7 +290,12 @@ data Doc id | DocPic String | DocAName String | DocExamples [Example] - deriving (Eq, Functor) + deriving (Functor) + + +instance Monoid (Doc id) where + mempty = DocEmpty + mappend = DocAppend unrenameDoc :: Doc DocName -> Doc Name -- cgit v1.2.3 From 20c4bfe760b3b50c875e91e455c47f544ba5129e Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 3 Dec 2011 18:56:25 +0100 Subject: Cleanup. --- src/Haddock/Interface/Create.hs | 38 +++++++++++--------------------------- 1 file changed, 11 insertions(+), 27 deletions(-) (limited to 'src') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 5f633a0b..de87ca94 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -212,19 +212,6 @@ declInfos dflags gre decls = return (parent, (mbDoc, fnArgsDoc), subs) --- | If you know the HsDecl can't contain any docs --- (e.g., it was loaded from a .hi file and you don't have a .haddock file --- to help you find out about the subs or docs) --- then you can use this to get its subs. -subordinatesWithNoDocs :: HsDecl Name -> [(Name, DocForDecl Name)] -subordinatesWithNoDocs decl = map noDocs (subordinates decl) - where - -- check the condition... or shouldn't we be checking? - noDocs (n, doc1, doc2) | null doc1, Map.null doc2 - = (n, noDocForDecl) - noDocs _ = error ("no-docs thing has docs! " ++ pretty decl) - - subordinates :: HsDecl Name -> [(Name, MaybeDocStrings, Map Int HsDocString)] subordinates (TyClD d) = classDataSubs d subordinates _ = [] @@ -254,31 +241,28 @@ classDataSubs decl , ConDeclField n _ doc <- flds ] --- All the sub declarations of a class (that we handle), ordered by +-- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. classDecls :: TyClDecl Name -> [(Decl, MaybeDocStrings)] -classDecls = filterDecls . collectDocs . sortByLoc . declsFromClass - - -declsFromClass :: TyClDecl a -> [Located (HsDecl a)] -declsFromClass class_ = docs ++ defs ++ sigs ++ ats +classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where - docs = mkDecls tcdDocs DocD class_ - defs = mkDecls (bagToList . tcdMeths) ValD class_ - sigs = mkDecls tcdSigs SigD class_ - ats = mkDecls tcdATs TyClD class_ + decls = docs ++ defs ++ sigs ++ ats + docs = mkDecls tcdDocs DocD class_ + defs = mkDecls (bagToList . tcdMeths) ValD class_ + sigs = mkDecls tcdSigs SigD class_ + ats = mkDecls tcdATs TyClD class_ -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)] -topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup +topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Take all declarations except pragmas, infix decls, rules and value -- bindings from an 'HsGroup'. -declsFromGroup :: HsGroup Name -> [Decl] -declsFromGroup group_ = +ungroup :: HsGroup Name -> [Decl] +ungroup group_ = mkDecls (concat . hs_tyclds) TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ mkDecls hs_defds DefD group_ ++ @@ -546,7 +530,7 @@ mkExportItems modMap thisMod gre exportedNames decls declMap Nothing -> do liftErrMsg $ tell ["Warning: Couldn't find .haddock for export " ++ pretty t] - let subs = subordinatesWithNoDocs (unLoc decl) + let subs = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t (decl, noDocForDecl, subs) ] Just iface -> do let subs = case Map.lookup t (instSubMap iface) of -- cgit v1.2.3 From 1bf42a0c5b92fc142eeb7e540e5f5e12373edc99 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 3 Dec 2011 19:45:56 +0100 Subject: More cleanup. --- haddock.cabal | 2 -- src/Haddock/Interface/Create.hs | 41 ++++++++++++++++---------- src/Haddock/Interface/ExtractFnArgDocs.hs | 49 ------------------------------- 3 files changed, 25 insertions(+), 67 deletions(-) delete mode 100644 src/Haddock/Interface/ExtractFnArgDocs.hs (limited to 'src') diff --git a/haddock.cabal b/haddock.cabal index 81d64756..16b37bcc 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -109,7 +109,6 @@ executable haddock Haddock.Interface Haddock.Interface.Rename Haddock.Interface.Create - Haddock.Interface.ExtractFnArgDocs Haddock.Interface.AttachInstances Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader @@ -172,7 +171,6 @@ library Haddock.Interface Haddock.Interface.Rename Haddock.Interface.Create - Haddock.Interface.ExtractFnArgDocs Haddock.Interface.AttachInstances Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index de87ca94..74c98dd9 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -18,7 +18,6 @@ import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn -import Haddock.Interface.ExtractFnArgDocs import qualified Data.Map as Map import Data.Map (Map) @@ -197,7 +196,7 @@ declInfos dflags gre decls = mbDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbDocString fnArgsDoc <- fmap (Map.mapMaybe id) $ - Traversable.forM (getDeclFnArgDocs d) $ + Traversable.forM (typeDocs d) $ \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc let subs_ = subordinates d @@ -213,23 +212,16 @@ declInfos dflags gre decls = subordinates :: HsDecl Name -> [(Name, MaybeDocStrings, Map Int HsDocString)] -subordinates (TyClD d) = classDataSubs d -subordinates _ = [] - - -classDataSubs :: TyClDecl Name -> [(Name, MaybeDocStrings, Map Int HsDocString)] -classDataSubs decl +subordinates (TyClD decl) | isClassDecl decl = classSubs | isDataDecl decl = dataSubs - | otherwise = [] where - classSubs = [ (name, doc, fnArgsDoc) - | (L _ d, doc) <- classDecls decl + classSubs = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls decl , name <- getMainDeclBinder d - , let fnArgsDoc = getDeclFnArgDocs d ] - dataSubs = constrs ++ fields + ] + dataSubs = constrs ++ fields where - cons = map unL $ tcdCons decl + cons = map unL $ tcdCons decl -- should we use the type-signature of the constructor -- and the docs of the fields to produce fnArgsDoc for the constr, -- just in case someone exports it without exporting the type @@ -239,6 +231,24 @@ classDataSubs decl fields = [ (unL n, maybeToList $ fmap unL doc, Map.empty) | RecCon flds <- map con_details cons , ConDeclField n _ doc <- flds ] +subordinates _ = [] + + +-- | Extract function argument docs from inside types. +typeDocs :: HsDecl Name -> Map Int HsDocString +typeDocs d = + let docs = go 0 in + case d of + SigD (TypeSig _ ty) -> docs (unLoc ty) + ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) + TyClD (TySynonym {tcdSynRhs = ty}) -> docs (unLoc ty) + _ -> Map.empty + where + go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) + go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = Map.insert n x $ go (n+1) ty + go n (HsFunTy _ ty) = go (n+1) (unLoc ty) + go n (HsDocTy _ (L _ doc)) = Map.singleton n doc + go _ _ = Map.empty -- | All the sub declarations of a class (that we handle), ordered by @@ -259,8 +269,7 @@ topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)] topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup --- | Take all declarations except pragmas, infix decls, rules and value --- bindings from an 'HsGroup'. +-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup Name -> [Decl] ungroup group_ = mkDecls (concat . hs_tyclds) TyClD group_ ++ diff --git a/src/Haddock/Interface/ExtractFnArgDocs.hs b/src/Haddock/Interface/ExtractFnArgDocs.hs deleted file mode 100644 index a9f8a807..00000000 --- a/src/Haddock/Interface/ExtractFnArgDocs.hs +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Interface.ExtractFnArgDocs --- Copyright : (c) Isaac Dupree 2009, --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Interface.ExtractFnArgDocs ( - getDeclFnArgDocs, getSigFnArgDocs, getTypeFnArgDocs -) where - -import Haddock.Types - -import qualified Data.Map as Map -import Data.Map (Map) - -import GHC - --- the type of Name doesn't matter, except in 6.10 where --- HsDocString = HsDoc Name, so we can't just say "HsDecl name" yet. - -getDeclFnArgDocs :: HsDecl Name -> Map Int HsDocString -getDeclFnArgDocs (SigD (TypeSig _ ty)) = getTypeFnArgDocs ty -getDeclFnArgDocs (ForD (ForeignImport _ ty _ _)) = getTypeFnArgDocs ty -getDeclFnArgDocs (TyClD (TySynonym {tcdSynRhs = ty})) = getTypeFnArgDocs ty -getDeclFnArgDocs _ = Map.empty - -getSigFnArgDocs :: Sig Name -> Map Int HsDocString -getSigFnArgDocs (TypeSig _ ty) = getTypeFnArgDocs ty -getSigFnArgDocs _ = Map.empty - -getTypeFnArgDocs :: LHsType Name -> Map Int HsDocString -getTypeFnArgDocs ty = getLTypeDocs 0 ty - - -getLTypeDocs :: Int -> LHsType Name -> Map Int HsDocString -getLTypeDocs n (L _ ty) = getTypeDocs n ty - -getTypeDocs :: Int -> HsType Name -> Map Int HsDocString -getTypeDocs n (HsForAllTy _ _ _ ty) = getLTypeDocs n ty -getTypeDocs n (HsFunTy (L _ (HsDocTy _arg_type (L _ doc))) res_type) = - Map.insert n doc $ getLTypeDocs (n+1) res_type -getTypeDocs n (HsFunTy _ res_type) = getLTypeDocs (n+1) res_type -getTypeDocs n (HsDocTy _res_type (L _ doc)) = Map.singleton n doc -getTypeDocs _ _res_type = Map.empty - -- cgit v1.2.3 From 60a043541e062ff6ceb52b0ab9e4f67d79dd3754 Mon Sep 17 00:00:00 2001 From: David Waern Date: Wed, 7 Dec 2011 02:16:33 +0100 Subject: Go back to having a doc, sub and decl map instead of one big decl map. This setup makes more sense since when we add value bindings to the processed declarations (for type inference), we will have multiple declarations which should share documentation. Also, we already have a separate doc map for instances which we can now merge into the main doc map. Another benefit is that we don't need the DeclInfo type any longer. --- src/Documentation/Haddock.hs | 1 - src/Haddock/GhcUtils.hs | 2 +- src/Haddock/Interface/AttachInstances.hs | 9 +- src/Haddock/Interface/Create.hs | 232 +++++++++++++++---------------- src/Haddock/Interface/Rename.hs | 19 +-- src/Haddock/InterfaceFile.hs | 10 +- src/Haddock/Types.hs | 32 +++-- 7 files changed, 149 insertions(+), 156 deletions(-) (limited to 'src') diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs index 96198494..052f1044 100644 --- a/src/Documentation/Haddock.hs +++ b/src/Documentation/Haddock.hs @@ -22,7 +22,6 @@ module Documentation.Haddock ( -- * Export items & declarations ExportItem(..), Decl, - DeclInfo, DocForDecl, FnArgsDoc, diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index 989563b7..fc04351b 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -78,7 +78,7 @@ isVarSym = isLexVarSym . occNameFS getMainDeclBinder :: HsDecl name -> [name] -getMainDeclBinder (TyClD d) = [tcdName d] +getMainDeclBinder (TyClD d) | not (isFamInstDecl d) = [tcdName d] getMainDeclBinder (ValD d) = case collectHsBindBinders d of [] -> [] diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index 5b7771ec..c012f2e0 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -73,20 +73,17 @@ lookupInstDoc :: Name -> Interface -> IfaceMap -> InstIfaceMap -> Maybe (Doc Nam -- TODO: capture this pattern in a function (when we have streamlined the -- handling of instances) lookupInstDoc name iface ifaceMap instIfaceMap = - case Map.lookup name (ifaceInstanceDocMap iface) of + case Map.lookup name (ifaceDocMap iface) of Just doc -> Just doc Nothing -> case Map.lookup modName ifaceMap of Just iface2 -> - case Map.lookup name (ifaceInstanceDocMap iface2) of + case Map.lookup name (ifaceDocMap iface2) of Just doc -> Just doc Nothing -> Nothing Nothing -> case Map.lookup modName instIfaceMap of - Just instIface -> - case Map.lookup name (instDocMap instIface) of - Just (doc, _) -> doc - Nothing -> Nothing + Just instIface -> Map.lookup name (instDocMap instIface) Nothing -> Nothing where modName = nameModule name diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 74c98dd9..a9f6c2ed 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Create @@ -20,11 +21,13 @@ import Haddock.Convert import Haddock.Interface.LexParseRn import qualified Data.Map as Map +import qualified Data.Map as M import Data.Map (Map) import Data.List import Data.Maybe import Data.Monoid import Data.Ord +import Control.Applicative import Control.Monad import qualified Data.Traversable as Traversable @@ -61,22 +64,20 @@ createInterface tm flags modMap instIfaceMap = do | otherwise = opts0 (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre optDocHeader - decls0 <- liftErrMsg $ declInfos dflags gre (topDecls group_) - let localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - declDocs = [ (decl, doc) | (L _ decl, (Just doc, _), _) <- decls0 ] - instanceDocMap = mkInstanceDocMap localInsts declDocs + let declsWithDocs = topDecls group_ + (decls, _) = unzip declsWithDocs + localInsts = filter (nameIsLocalOrFrom mdl . getName) instances + (docMap, argMap, subMap, declMap) <- liftErrMsg $ maps dflags gre localInsts exportedNames declsWithDocs - declMap = mkDeclMap decls0 - decls = filter (\(L _ d, _, _) -> not (isInstD d || isValD d)) decls0 - exports0 = fmap (reverse . map unLoc) optExports - exports + let exports0 = fmap (reverse . map unLoc) optExports + exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - liftErrMsg $ warnAboutFilteredDecls mdl decls0 + liftErrMsg $ warnAboutFilteredDecls mdl decls - exportItems <- mkExportItems modMap mdl gre exportedNames decls declMap + exportItems <- mkExportItems modMap mdl gre exportedNames decls docMap argMap subMap declMap exports instances instIfaceMap dflags let visibleNames = mkVisibleNames exportItems opts @@ -102,15 +103,17 @@ createInterface tm flags modMap instIfaceMap = do ifaceDoc = mbDoc, ifaceRnDoc = Nothing, ifaceOptions = opts, + ifaceDocMap = docMap, + ifaceArgMap = argMap, ifaceRnDocMap = Map.empty, + ifaceRnArgMap = Map.empty, ifaceExportItems = prunedExportItems, ifaceRnExportItems = [], ifaceExports = exportedNames, ifaceVisibleExports = visibleNames, ifaceDeclMap = declMap, - ifaceSubMap = mkSubMap declMap exportedNames, + ifaceSubMap = subMap, ifaceInstances = instances, - ifaceInstanceDocMap = instanceDocMap, ifaceHaddockCoverage = coverage } @@ -147,68 +150,55 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing -------------------------------------------------------------------------------- -mkInstanceDocMap :: [Instance] -> [(HsDecl name, doc)] -> Map Name doc -mkInstanceDocMap instances decls = - -- We relate Instances to InstDecls using the SrcSpans buried inside them. - -- That should work for normal user-written instances (from looking at GHC - -- sources). We can assume that commented instances are user-written. - -- This lets us relate Names (from Instances) to comments (associated - -- with InstDecls). - let docMap = Map.fromList [ (loc, doc) - | (InstD (InstDecl (L loc _) _ _ _), doc) <- decls ] +type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap) - in Map.fromList [ (name, doc) | inst <- instances - , let name = getName inst - , Just doc <- [ Map.lookup (getSrcSpan name) docMap ] ] - --- | Make a sub map from a declaration map. Make sure we only include exported --- names. -mkSubMap :: Map Name DeclInfo -> [Name] -> Map Name [Name] -mkSubMap declMap exports = - Map.filterWithKey (\k _ -> k `elem` exports) (Map.map filterSubs declMap) +maps :: DynFlags -> GlobalRdrEnv -> [Instance] -> [Name] -> [(Decl, MaybeDocStrings)] -> ErrMsgM Maps +maps 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_) where - filterSubs (_, _, subs) = [ sub | (sub, _) <- subs, sub `elem` exports ] + instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] + f :: (Decl, MaybeDocStrings) -> ErrMsgM Maps + f (decl@(L _ d), docs) = do + mayDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs + argDocs <- fmap (Map.mapMaybe id) $ Traversable.forM (typeDocs d) $ + \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc --- Make a map from names to 'DeclInfo's. --- --- Exclude nameless declarations (e.g. instances and stand-alone documentation --- comments). Merge declarations of same names (i.e. type signatures and --- bindings). Include subordinate names, mapped to their parent declarations. -mkDeclMap :: [DeclInfo] -> Map Name DeclInfo -mkDeclMap decls = Map.fromListWith merge . concat $ - [ decls_ ++ subDecls | (parent@(L _ d), doc, subs) <- decls - , let decls_ = [ (name, (parent, doc, subs)) | name <- getMainDeclBinder d ] - subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ] - , not (isDocD d), not (isInstD d) - ] - where - merge (s@(L _ (SigD _)), s_doc, _) (v@(L _ (ValD _)), v_doc, _) = (s, f s s_doc v v_doc, []) - merge (v@(L _ (ValD _)), v_doc, _) (s@(L _ (SigD _)), s_doc, _) = (s, f s s_doc v v_doc, []) - merge a _ = a - f s s_doc v v_doc | s `before` v = s_doc `mappend` v_doc | otherwise = v_doc `mappend` s_doc + let subs_ = subordinates d + let subs_' = filter (\(name, _, _) -> name `elem` exports) subs_ + (subDocs, subArgMap) <- unzip <$> (forM subs_' $ \(name, mbSubDocStr, subFnArgsDocStr) -> do + mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr + subFnArgsDoc <- fmap (Map.mapMaybe id) $ Traversable.forM subFnArgsDocStr $ + \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc + return ((name, mbSubDoc), (name, subFnArgsDoc))) -declInfos :: DynFlags -> GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo] -declInfos dflags gre decls = - forM decls $ \(parent@(L _ d), mbDocString) -> do - mbDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment - gre mbDocString - fnArgsDoc <- fmap (Map.mapMaybe id) $ - Traversable.forM (typeDocs d) $ - \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc + let subNames = map fst subDocs - let subs_ = subordinates d - subs <- forM subs_ $ \(subName, mbSubDocStr, subFnArgsDocStr) -> do - mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment - gre mbSubDocStr - subFnArgsDoc <- fmap (Map.mapMaybe id) $ - Traversable.forM subFnArgsDocStr $ - \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc - return (subName, (mbSubDoc, subFnArgsDoc)) + let names = case d of + InstD (InstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) -- See note [2]. + _ -> filter (`elem` exports) (getMainDeclBinder d) - return (parent, (mbDoc, fnArgsDoc), subs) + 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') + + +-- Note [2]: +------------ +-- We relate Instances to InstDecls using the SrcSpans buried inside them. +-- That should work for normal user-written instances (from looking at GHC +-- sources). We can assume that commented instances are user-written. +-- This lets us relate Names (from Instances) to comments (associated +-- with InstDecls). subordinates :: HsDecl Name -> [(Name, MaybeDocStrings, Map Int HsDocString)] @@ -217,7 +207,7 @@ subordinates (TyClD decl) | isDataDecl decl = dataSubs where classSubs = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls decl - , name <- getMainDeclBinder d + , name <- getMainDeclBinder d, not (isValD d) ] dataSubs = constrs ++ fields where @@ -299,11 +289,11 @@ sortByLoc :: [Located a] -> [Located a] sortByLoc = sortBy (comparing getLoc) -warnAboutFilteredDecls :: Module -> [(LHsDecl Name, b, c)] -> ErrMsgM () +warnAboutFilteredDecls :: Module -> [LHsDecl Name] -> ErrMsgM () warnAboutFilteredDecls mdl decls = do let modStr = moduleString mdl let typeInstances = - nub [ tcdName d | (L _ (TyClD d), _, _) <- decls, isFamInstDecl d ] + nub [ tcdName d | L _ (TyClD d) <- decls, isFamInstDecl d ] unless (null typeInstances) $ tell [ @@ -312,7 +302,7 @@ warnAboutFilteredDecls mdl decls = do ++ "will be filtered out:\n " ++ concat (intersperse ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty i | (L _ (InstD (InstDecl i _ _ ats)), _, _) <- decls + let instances = nub [ pretty i | L _ (InstD (InstDecl i _ _ ats)) <- decls , not (null ats) ] unless (null instances) $ @@ -434,19 +424,24 @@ mkExportItems -> Module -- this module -> GlobalRdrEnv -> [Name] -- exported names (orig) - -> [DeclInfo] - -> Map Name DeclInfo -- maps local names to declarations + -> [LHsDecl Name] + -> DocMap Name + -> ArgMap Name + -> SubMap + -> DeclMap -- maps local names to declarations -> Maybe [IE Name] -> [Instance] -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem Name] -mkExportItems modMap thisMod gre exportedNames decls declMap +mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declMap optExports _ instIfaceMap dflags = case optExports of - Nothing -> liftErrMsg $ fullContentsOfThisModule dflags gre decls + Nothing -> liftErrMsg $ fullContentsOfThisModule dflags gre docMap argMap subMap decls Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports where + decls = filter (\(L _ d) -> not (isInstD d || isValD d)) 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 @@ -461,7 +456,7 @@ mkExportItems modMap thisMod gre exportedNames decls declMap lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = - moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap + moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap docMap argMap subMap lookupExport (IEGroup lev docStr) = liftErrMsg $ ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) @@ -469,7 +464,7 @@ mkExportItems modMap thisMod gre exportedNames decls declMap ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) (\doc -> return [ ExportDoc doc ]) lookupExport (IEDocNamed str) = liftErrMsg $ - ifDoc (findNamedDoc str [ unL d | (d,_,_) <- decls ]) + ifDoc (findNamedDoc str [ unL d | d <- decls ]) (\docStr -> ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) (\doc -> return [ ExportDoc doc ])) @@ -483,16 +478,16 @@ mkExportItems modMap thisMod gre exportedNames decls declMap declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = + let doc = (Map.lookup t docMap, maybe Map.empty id (Map.lookup t argMap)) in case findDecl t of - -- Top-level binding from this package without type signature - Just (L _ (ValD _), doc, _) -> do + [L _ (ValD _)] -> do + -- Top-level binding without type signature mayDecl <- ifaceDecl t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] Just decl -> return [ ExportDecl decl doc [] [] ] - -- Top-level declaration from this module - Just (decl, doc, subs) -> + ds | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) in case () of _ @@ -514,7 +509,7 @@ mkExportItems modMap thisMod gre exportedNames decls declMap return [] -- normal case - | otherwise -> return [ mkExportDecl t (newDecl, doc, subs) ] + | otherwise -> return [ mkExportDecl t newDecl (exportDecl t newDecl docMap argMap subMap) ] where -- Since a single signature might refer to many names, we -- need to filter the ones that are actually exported. This @@ -528,7 +523,7 @@ mkExportItems modMap thisMod gre exportedNames decls declMap _ -> decl -- Declaration from another package - Nothing -> do + [] -> do mayDecl <- ifaceDecl t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] @@ -540,26 +535,15 @@ mkExportItems modMap thisMod gre exportedNames decls declMap liftErrMsg $ tell ["Warning: Couldn't find .haddock for export " ++ pretty t] let subs = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] - return [ mkExportDecl t (decl, noDocForDecl, subs) ] + return [ mkExportDecl t decl (noDocForDecl, subs) ] Just iface -> do - let subs = case Map.lookup t (instSubMap iface) of - Nothing -> [] - Just x -> x - return [ mkExportDecl t - ( decl - , fromMaybe noDocForDecl $ - Map.lookup t (instDocMap iface) - , map (\subt -> - ( subt , - fromMaybe noDocForDecl $ - Map.lookup subt (instDocMap iface) - ) - ) subs - )] - - - mkExportDecl :: Name -> DeclInfo -> ExportItem Name - mkExportDecl n (decl, doc, subs) = decl' + return [ mkExportDecl t decl (exportDecl t decl (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + + _ -> return [] + + + mkExportDecl :: Name -> Decl -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name + mkExportDecl n decl (doc, subs) = decl' where decl' = ExportDecl (restrictTo sub_names (extractDecl n mdl decl)) doc subs' [] mdl = nameModule n @@ -570,12 +554,12 @@ mkExportItems modMap thisMod gre exportedNames decls declMap isExported = (`elem` exportedNames) - findDecl :: Name -> Maybe DeclInfo + findDecl :: Name -> [Decl] findDecl n - | m == thisMod = Map.lookup n declMap + | m == thisMod = maybe [] id (Map.lookup n declMap) | otherwise = case Map.lookup m modMap of - Just iface -> Map.lookup n (ifaceDeclMap iface) - Nothing -> Nothing + Just iface -> maybe [] id (Map.lookup n (ifaceDeclMap iface)) + Nothing -> [] where m = nameModule n @@ -590,6 +574,14 @@ ifaceDecl t = do Just x -> return (Just (tyThingToLHsDecl x)) +exportDecl :: Name -> Decl -> 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) + + -- | Return all export items produced by an exported module. That is, we're -- interested in the exports produced by \"module B\" in such a scenario: -- @@ -608,12 +600,15 @@ moduleExports :: Module -- ^ Module A -> DynFlags -- ^ The flag used when typechecking A -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A - -> [DeclInfo] -- ^ All the declarations in A + -> [Decl] -- ^ All the declarations in A -> IfaceMap -- ^ Already created interfaces -> InstIfaceMap -- ^ Interfaces in other packages + -> DocMap Name + -> ArgMap Name + -> SubMap -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items -moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap - | m == thisMod = liftErrMsg $ fullContentsOfThisModule dflags gre decls +moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap docMap argMap subMap + | m == thisMod = liftErrMsg $ fullContentsOfThisModule dflags gre docMap argMap subMap decls | otherwise = case Map.lookup m ifaceMap of Just iface @@ -651,17 +646,20 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap -- (For more information, see Trac #69) -fullContentsOfThisModule :: DynFlags -> GlobalRdrEnv -> [DeclInfo] -> ErrMsgM [ExportItem Name] -fullContentsOfThisModule dflags gre decls = liftM catMaybes $ mapM mkExportItem decls +fullContentsOfThisModule :: DynFlags -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> [Decl] -> ErrMsgM [ExportItem Name] +fullContentsOfThisModule dflags gre docMap argMap subMap decls = liftM catMaybes $ mapM mkExportItem decls where - mkExportItem (L _ (DocD (DocGroup lev docStr)), _, _) = do - mbDoc <- lexParseRnHaddockComment dflags DocSectionComment gre docStr - return $ fmap (ExportGroup lev "") mbDoc - mkExportItem (L _ (DocD (DocCommentNamed _ docStr)), _, _) = do - mbDoc <- lexParseRnHaddockComment dflags NormalHaddockComment gre docStr - return $ fmap ExportDoc mbDoc - mkExportItem (decl, doc, subs) = return $ Just $ ExportDecl decl doc subs [] - + mkExportItem (L _ (DocD (DocGroup lev docStr))) = do + mbDoc <- lexParseRnHaddockComment dflags DocSectionComment gre docStr + return $ fmap (ExportGroup lev "") mbDoc + mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do + mbDoc <- lexParseRnHaddockComment dflags NormalHaddockComment gre docStr + return $ fmap ExportDoc mbDoc + mkExportItem decl + | name : _ <- getMainDeclBinder (unLoc decl) = + let (doc, subs) = exportDecl name decl docMap argMap subMap in + return $ Just (ExportDecl decl doc subs []) + | otherwise = return Nothing -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 35ff8542..691dafbc 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -36,30 +36,22 @@ renameInterface renamingEnv warnings iface = let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface) where fn env name = Map.insert name (ifaceMod iface) env - docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface) - - -- make instance docs into 'docForDecls' - instDocs = [ (name, (Just doc, Map.empty)) - | (name, doc) <- Map.toList (ifaceInstanceDocMap iface) ] - - docs = Map.toList docMap ++ instDocs - renameMapElem (k,d) = do d' <- renameDocForDecl d; return (k, d') - -- rename names in the exported declarations to point to things that -- are closer to, or maybe even exported by, the current module. (renamedExportItems, missingNames1) = runRnFM localEnv (renameExportItems (ifaceExportItems iface)) - (rnDocMap, missingNames2) - = runRnFM localEnv (liftM Map.fromList (mapM renameMapElem docs)) + (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface)) + + (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) - (finalModuleDoc, missingNames3) + (finalModuleDoc, missingNames4) = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface)) -- combine the missing names and filter out the built-ins, which would -- otherwise allways be missing. missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much - (missingNames1 ++ missingNames2 ++ missingNames3) + (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4) -- filter out certain built in type constructors using their string -- representation. TODO: use the Name constants from the GHC API. @@ -77,6 +69,7 @@ renameInterface renamingEnv warnings iface = return $ iface { ifaceRnDoc = finalModuleDoc, ifaceRnDocMap = rnDocMap, + ifaceRnArgMap = rnArgMap, ifaceRnExportItems = renamedExportItems } diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 1da46662..21179885 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -65,9 +65,9 @@ binaryInterfaceMagic = 0xD0Cface -- we version our interface files accordingly. binaryInterfaceVersion :: Word16 #if __GLASGOW_HASKELL__ == 702 -binaryInterfaceVersion = 18 +binaryInterfaceVersion = 19 #elif __GLASGOW_HASKELL__ == 703 -binaryInterfaceVersion = 18 +binaryInterfaceVersion = 19 #else #error Unknown GHC version #endif @@ -355,10 +355,11 @@ instance Binary InterfaceFile where instance Binary InstalledInterface where - put_ bh (InstalledInterface modu info docMap exps visExps opts subMap) = do + put_ bh (InstalledInterface modu info docMap argMap exps visExps opts subMap) = do put_ bh modu put_ bh info put_ bh docMap + put_ bh argMap put_ bh exps put_ bh visExps put_ bh opts @@ -368,12 +369,13 @@ instance Binary InstalledInterface where modu <- get bh info <- get bh docMap <- get bh + argMap <- get bh exps <- get bh visExps <- get bh opts <- get bh subMap <- get bh - return (InstalledInterface modu info docMap + return (InstalledInterface modu info docMap argMap exps visExps opts subMap) diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 2b78905c..3baa4a94 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -36,8 +36,11 @@ import OccName type IfaceMap = Map Module Interface -type InstIfaceMap = Map Module InstalledInterface -type DocMap = Map Name (Doc DocName) +type InstIfaceMap = Map Module InstalledInterface -- TODO: rename +type DocMap a = Map Name (Doc a) +type ArgMap a = Map Name (Map Int (Doc a)) +type SubMap = Map Name [Name] +type DeclMap = Map Name [Decl] type SrcMap = Map PackageId FilePath type Decl = LHsDecl Name type GhcDocHdr = Maybe LHsDocString @@ -77,11 +80,17 @@ 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 DeclInfo + , ifaceDeclMap :: Map Name [Decl] -- | Documentation of declarations originating from the module (including -- subordinates). - , ifaceRnDocMap :: Map Name (DocForDecl DocName) + , ifaceDocMap :: DocMap Name + , ifaceArgMap :: ArgMap Name + + -- | Documentation of declarations originating from the module (including + -- subordinates). + , ifaceRnDocMap :: DocMap DocName + , ifaceRnArgMap :: ArgMap DocName , ifaceSubMap :: Map Name [Name] @@ -99,9 +108,6 @@ data Interface = Interface -- | Instances exported by the module. , ifaceInstances :: ![Instance] - -- | Documentation of instances defined in the module. - , ifaceInstanceDocMap :: Map Name (Doc Name) - -- | 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) @@ -120,7 +126,9 @@ data InstalledInterface = InstalledInterface -- | Documentation of declarations originating from the module (including -- subordinates). - , instDocMap :: Map Name (DocForDecl Name) + , instDocMap :: DocMap Name + + , instArgMap :: ArgMap Name -- | All names exported by this module. , instExports :: [Name] @@ -142,7 +150,8 @@ toInstalledIface :: Interface -> InstalledInterface toInstalledIface interface = InstalledInterface { instMod = ifaceMod interface , instInfo = ifaceInfo interface - , instDocMap = fmap unrenameDocForDecl $ ifaceRnDocMap interface + , instDocMap = ifaceDocMap interface + , instArgMap = ifaceArgMap interface , instExports = ifaceExports interface , instVisibleExports = ifaceVisibleExports interface , instOptions = ifaceOptions interface @@ -204,11 +213,6 @@ data ExportItem name | ExportModule Module --- | A declaration that may have documentation, including its subordinates, --- which may also have documentation. -type DeclInfo = (Decl, DocForDecl Name, [(Name, DocForDecl Name)]) - - -- | Arguments and result are indexed by Int, zero-based from the left, -- because that's the easiest to use when recursing over types. type FnArgsDoc name = Map Int (Doc name) -- cgit v1.2.3