aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r--src/Haddock/Interface/Create.hs62
-rw-r--r--src/Haddock/Interface/Rename.hs6
2 files changed, 42 insertions, 26 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 0123d22a..78c73c09 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -176,9 +176,10 @@ mkSubMap declMap exports =
-- subordinate names, but map them to their parent declarations.
mkDeclMap :: [DeclInfo] -> Map Name DeclInfo
mkDeclMap decls = Map.fromList . concat $
- [ (declName d, (parent, doc, subs)) : subDecls
+ [ decls_ ++ subDecls
| (parent@(L _ d), doc, subs) <- decls
- , let subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ]
+ , let decls_ = [ (name, (parent, doc, subs)) | name <- declNames d ]
+ subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ]
, not (isDocD d), not (isInstD d) ]
@@ -227,8 +228,9 @@ classDataSubs decl
| isDataDecl decl = dataSubs
| otherwise = []
where
- classSubs = [ (declName d, doc, fnArgsDoc)
+ classSubs = [ (name, doc, fnArgsDoc)
| (L _ d, doc) <- classDecls decl
+ , name <- declNames d
, let fnArgsDoc = getDeclFnArgDocs d ]
dataSubs = constrs ++ fields
where
@@ -259,12 +261,12 @@ declsFromClass class_ = docs ++ defs ++ sigs ++ ats
ats = mkDecls tcdATs TyClD class_
-declName :: HsDecl a -> a
-declName (TyClD d) = tcdName d
-declName (ForD (ForeignImport n _ _)) = unLoc n
+declNames :: HsDecl a -> [a]
+declNames (TyClD d) = [tcdName d]
+declNames (ForD (ForeignImport n _ _)) = [unLoc n]
-- we have normal sigs only (since they are taken from ValBindsOut)
-declName (SigD sig) = fromJust $ sigNameNoLoc sig
-declName _ = error "unexpected argument to declName"
+declNames (SigD sig) = sigNameNoLoc sig
+declNames _ = error "unexpected argument to declNames"
-- | The top-level declarations of a module that we care about,
@@ -453,8 +455,17 @@ mkExportItems modMap thisMod gre exportedNames decls declMap
optExports _ instIfaceMap dflags =
case optExports of
Nothing -> liftErrMsg $ fullContentsOfThisModule dflags gre decls
- Just exports -> liftM concat $ mapM lookupExport exports
+ Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports
where
+ -- 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
lookupExport (IEThingAll t) = declWith t
@@ -483,11 +494,8 @@ mkExportItems modMap thisMod gre exportedNames decls declMap
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
declWith t =
case findDecl t of
- Just x@(decl,_,_) ->
- let declName_ =
- case getMainDeclBinder (unL decl) of
- Just n -> n
- Nothing -> error "declWith: should not happen"
+ Just (decl, doc, subs) ->
+ let declNames_ = getMainDeclBinder (unL decl)
in case () of
_
-- temp hack: we filter out separately exported ATs, since we haven't decided how
@@ -497,7 +505,7 @@ mkExportItems modMap thisMod gre exportedNames decls declMap
-- We should not show a subordinate by itself if any of its
-- parents is also exported. See note [1].
- | t /= declName_,
+ | not $ t `elem` declNames_,
Just p <- find isExported (parents t $ unL decl) ->
do liftErrMsg $ tell [
"Warning: " ++ moduleString thisMod ++ ": " ++
@@ -508,7 +516,18 @@ mkExportItems modMap thisMod gre exportedNames decls declMap
return []
-- normal case
- | otherwise -> return [ mkExportDecl t x ]
+ | otherwise -> return [ mkExportDecl t (newDecl, doc, subs) ]
+ 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.
+ newDecl = case decl of
+ (L loc (SigD sig)) ->
+ L loc . SigD . fromJust $ filterSigNames isExported sig
+ -- fromJust is safe since we already checked in guards
+ -- that 't' is a name declared in this declaration.
+ _ -> decl
Nothing -> do
-- If we can't find the declaration, it must belong to
-- another package
@@ -720,11 +739,11 @@ fullContentsOfThisModule dflags gre decls = liftM catMaybes $ mapM mkExportItem
-- together a type signature for it...)
extractDecl :: Name -> Module -> Decl -> Decl
extractDecl name mdl decl
- | Just n <- getMainDeclBinder (unLoc decl), n == name = decl
+ | name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
case unLoc decl of
TyClD d | isClassDecl d ->
- let matches = [ sig | sig <- tcdSigs d, sigName sig == Just name,
+ let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
isVanillaLSig sig ] -- TODO: document fixity
in case matches of
[s0] -> let (n, tyvar_names) = name_and_tyvars d
@@ -762,7 +781,7 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (L _ con : rest) =
case con_details con of
RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
- L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty))))
+ L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))))
_ -> extractRecSel nm mdl t tvs rest
where
matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]
@@ -782,10 +801,7 @@ mkVisibleNames exports opts
| OptHide `elem` opts = []
| otherwise = concatMap exportName exports
where
- exportName e@ExportDecl {} =
- case getMainDeclBinder $ unL $ expItemDecl e of
- Just n -> n : subs
- Nothing -> subs
+ exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs
where subs = map fst (expItemSubDocs e)
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
-- we don't want links to go to them.
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index b53f579c..2d5c899a 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -401,10 +401,10 @@ renameTyClD d = case d of
renameSig :: Sig Name -> RnM (Sig DocName)
renameSig sig = case sig of
- TypeSig lname ltype -> do
- lname' <- renameL lname
+ TypeSig lnames ltype -> do
+ lnames' <- mapM renameL lnames
ltype' <- renameLType ltype
- return (TypeSig lname' ltype')
+ return (TypeSig lnames' ltype')
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"