aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs121
1 files changed, 79 insertions, 42 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 52a983a8..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
@@ -380,7 +380,7 @@ mkMaps dflags gre instances decls = do
m' <- traverse (processDocStringParas dflags gre) m
pure (doc', m')
- (doc, args) <- declDoc docStrs (typeDocs decl)
+ (doc, args) <- declDoc docStrs (declTypeDocs decl)
let
subs :: [(Name, [HsDocString], Map Int HsDocString)]
@@ -445,14 +445,14 @@ subordinates instMap decl = case decl of
| isDataDecl d -> dataSubs (tcdDataDefn d)
_ -> []
where
- classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
+ classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd
, name <- getMainDeclBinder d, not (isValD d)
]
dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]
dataSubs dd = constrs ++ fields ++ derivs
where
cons = map unL $ (dd_cons dd)
- constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
+ constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c)
| c <- cons, cname <- getConNames c ]
fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)
| RecCon flds <- map getConArgs cons
@@ -464,17 +464,33 @@ subordinates instMap decl = case decl of
unLoc $ dd_derivs dd
, Just instName <- [M.lookup l instMap] ]
+-- | Extract constructor argument docs from inside constructor decls.
+conArgDocs :: ConDecl GhcRn -> Map Int HsDocString
+conArgDocs con = case getConArgs con of
+ PrefixCon args -> go 0 (map unLoc args ++ ret)
+ InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
+ RecCon _ -> go 1 ret
+ where
+ go n (HsDocTy _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys
+ go n (_ : tys) = go (n+1) tys
+ go _ [] = M.empty
+
+ ret = case con of
+ ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
+ _ -> []
+
+-- | Extract function argument docs from inside top-level decls.
+declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString
+declTypeDocs (SigD (TypeSig _ ty)) = typeDocs (unLoc (hsSigWcType ty))
+declTypeDocs (SigD (ClassOpSig _ _ ty)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (SigD (PatSynSig _ ty)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (ForD (ForeignImport _ ty _ _)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (TyClD (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)
+declTypeDocs _ = M.empty
+
-- | Extract function argument docs from inside types.
-typeDocs :: HsDecl GhcRn -> Map Int HsDocString
-typeDocs d =
- let docs = go 0 in
- case d of
- SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty))
- SigD (ClassOpSig _ _ ty) -> docs (unLoc (hsSigType ty))
- SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty))
- ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty))
- TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
- _ -> M.empty
+typeDocs :: HsType GhcRn -> Map Int HsDocString
+typeDocs = go 0
where
go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
go n (HsQualTy { hst_body = ty }) = go n (unLoc ty)
@@ -483,7 +499,6 @@ typeDocs d =
go n (HsDocTy _ (L _ doc)) = M.singleton n doc
go _ _ = M.empty
-
-- | All the sub declarations of a class (that we handle), ordered by
-- source location, with documentation attached if it exists.
classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
@@ -689,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,
@@ -767,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
@@ -779,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 = []
@@ -978,47 +988,74 @@ 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
TyClD d@ClassDecl {} ->
- let matches = [ lsig
- | lsig <- tcdSigs d
- , ClassOpSig False _ _ <- pure $ unLoc lsig
- -- Note: exclude `default` declarations (see #505)
- , name `elem` sigName lsig
- ]
+ let
+ matchesMethod =
+ [ lsig
+ | lsig <- tcdSigs d
+ , ClassOpSig False _ _ <- pure $ unLoc lsig
+ -- Note: exclude `default` declarations (see #505)
+ , name `elem` sigName lsig
+ ]
+
+ matchesAssociatedType =
+ [ lfam_decl
+ | lfam_decl <- tcdATs d
+ , name == unLoc (fdLName (unLoc lfam_decl))
+ ]
+
-- TODO: document fixity
- in case matches of
- [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
- L pos sig = addClassContext n tyvar_names s0
- in L pos (SigD sig)
+ in case (matchesMethod, matchesAssociatedType) of
+ ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
+ 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:"
- O.$$ O.nest 4 (O.ppr matches))
+ O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType))
TyClD d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
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
@@ -1034,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"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 16:09:07 +0000