From 3291502a4a15f30eaafdb22da4292a17e08aa7bd Mon Sep 17 00:00:00 2001
From: alexbiehl <alex.biehl@gmail.com>
Date: Sat, 20 Jan 2018 19:18:20 +0100
Subject: Fix duplicate declarations and TypeFamilies specifics
---
haddock-api/src/Haddock/Interface/Create.hs | 46 ++++++++++++++++++-----------
1 file changed, 29 insertions(+), 17 deletions(-)
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index bd990170..4866f76b 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -115,7 +115,7 @@ createInterface tm flags modMap instIfaceMap = do
unrestrictedImportedMods
-- module re-exports are only possible with
-- explicit export list
- | Just _ <- exports
+ | Just{} <- exports
= unrestrictedModuleImports (map unLoc imports)
| otherwise = M.empty
@@ -704,11 +704,6 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
let declNames = getMainDeclBinder (unL decl)
in case () of
_
- -- TODO: temp hack: we filter out separately exported ATs, since we haven't decided how
- -- to handle them yet. We should really give an warning message also, and filter the
- -- name out in mkVisibleNames...
- | t `elem` declATs (unL decl) -> return []
-
-- We should not show a subordinate by itself if any of its
-- parents is also exported. See note [1].
| t `notElem` declNames,
@@ -782,7 +777,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
return [ ExportDecl {
expItemDecl = restrictTo (fmap fst subs)
- (extractDecl (availName avail) decl)
+ (extractDecl declMap (availName avail) decl)
, expItemPats = bundledPatSyns
, expItemMbDoc = doc
, expItemSubDocs = subs
@@ -794,7 +789,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
| otherwise =
return [ ExportDecl {
- expItemDecl = extractDecl sub decl
+ expItemDecl = extractDecl declMap sub decl
, expItemPats = []
, expItemMbDoc = sub_doc
, expItemSubDocs = []
@@ -993,23 +988,32 @@ fullModuleContents :: Bool -- is it a signature
-> Avails
-> ErrMsgGhc [ExportItem GhcRn]
fullModuleContents is_sig modMap thisMod semMod warnings exportedNames
- decls maps fixMap splices instIfaceMap dflags avails = do
- let availEnv = availsToNameEnv avails
+ decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do
+ let availEnv = availsToNameEnv (nubAvails avails)
(concat . concat) `fmap` (for decls $ \decl -> do
for (getMainDeclBinder (unLoc decl)) $ \nm -> do
case lookupNameEnv availEnv nm of
- Just avail -> availExportItem is_sig modMap thisMod
- semMod warnings exportedNames maps fixMap
- splices instIfaceMap dflags avail
+ Just avail
+ | L _ (ValD valDecl) <- decl
+ , (name:_) <- collectHsBindBinders valDecl
+ , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
+ -> pure []
+
+ | otherwise
+ -> availExportItem is_sig modMap thisMod
+ semMod warnings exportedNames maps fixMap
+ splices instIfaceMap dflags avail
Nothing -> pure [])
-
+ where
+ isSigD (L _ SigD{}) = True
+ isSigD _ = False
-- | 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
-- cases we have to extract the required declaration (and somehow cobble
-- together a type signature for it...).
-extractDecl :: Name -> LHsDecl GhcRn -> LHsDecl GhcRn
-extractDecl name decl
+extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn
+extractDecl declMap name decl
| name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
case unLoc decl of
@@ -1035,6 +1039,10 @@ extractDecl name decl
L pos sig = addClassContext n tyvar_names s0
in L pos (SigD sig)
(_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl))
+
+ ([], [])
+ | Just (famInstDecl:_) <- M.lookup name declMap
+ -> extractDecl declMap name famInstDecl
_ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:"
O.$$ O.nest 4 (O.ppr d)
O.$$ O.text "Matches:"
@@ -1044,6 +1052,10 @@ extractDecl name decl
in if isDataConName name
then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+ TyClD FamDecl {}
+ | isValName name
+ , Just (famInst:_) <- M.lookup name declMap
+ -> extractDecl declMap name famInst
InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body =
FamEqn { feqn_tycon = L _ n
, feqn_pats = tys
@@ -1059,7 +1071,7 @@ extractDecl name decl
, selectorFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0)
+ [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
--
cgit v1.2.3