aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorDavid Waern <david.waern@gmail.com>2011-12-07 02:16:33 +0100
committerDavid Waern <david.waern@gmail.com>2011-12-27 12:57:43 +0100
commit60a043541e062ff6ceb52b0ab9e4f67d79dd3754 (patch)
treed6fc920f6dfdb5002f4e1d7841dfb27e1e2023ab /src
parent1bf42a0c5b92fc142eeb7e540e5f5e12373edc99 (diff)
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.
Diffstat (limited to 'src')
-rw-r--r--src/Documentation/Haddock.hs1
-rw-r--r--src/Haddock/GhcUtils.hs2
-rw-r--r--src/Haddock/Interface/AttachInstances.hs9
-rw-r--r--src/Haddock/Interface/Create.hs232
-rw-r--r--src/Haddock/Interface/Rename.hs19
-rw-r--r--src/Haddock/InterfaceFile.hs10
-rw-r--r--src/Haddock/Types.hs32
7 files changed, 149 insertions, 156 deletions
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)