aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs129
1 files changed, 72 insertions, 57 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index da55397e..4a13f386 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -673,22 +673,11 @@ availExportItem :: Bool -- is it a signature
-> AvailInfo
-> ErrMsgGhc [ExportItem GhcRn]
availExportItem is_sig modMap thisMod semMod warnings exportedNames
- maps@(docMap, argMap, declMap, instMap) fixMap splices instIfaceMap
- dflags availInfo
- | availName availInfo `notElem` availNamesWithSelectors availInfo = do
- exportItems <- for (availNamesWithSelectors availInfo)
- (availExportItem is_sig modMap thisMod semMod
- warnings exportedNames maps fixMap splices
- instIfaceMap dflags . Avail.avail)
- return (concat exportItems)
- | otherwise = do
- pats <- findBundledPatterns availInfo
- declWith availInfo pats
+ (docMap, argMap, declMap, _) fixMap splices instIfaceMap
+ dflags availInfo = declWith availInfo
where
- declWith :: AvailInfo
- -> [(HsDecl GhcRn, DocForDecl Name)]
- -> ErrMsgGhc [ ExportItem GhcRn ]
- declWith avail pats = do
+ declWith :: AvailInfo -> ErrMsgGhc [ ExportItem GhcRn ]
+ declWith avail = do
let t = availName avail
r <- findDecl avail
case r of
@@ -726,15 +715,15 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
-- fromJust is safe since we already checked in guards
-- that 't' is a name declared in this declaration.
let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig
- in return [ mkExportDecl avail newDecl pats docs_ ]
+ in availExportDecl avail newDecl docs_
L loc (TyClD cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
- return [ mkExportDecl avail
- (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ]
+ availExportDecl avail
+ (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_
- _ -> return [ mkExportDecl avail decl pats docs_ ]
+ _ -> availExportDecl avail decl docs_
-- Declaration from another package
([], _) -> do
@@ -750,42 +739,59 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
Nothing -> do
liftErrMsg $ tell
["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
- let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]
- return [ mkExportDecl avail decl pats (noDocForDecl, subs_) ]
+ let subs_ = [ (n, noDocForDecl)
+ | n <- availNamesWithSelectors avail
+ , n /= availName avail
+ ]
+ availExportDecl avail decl (noDocForDecl, subs_)
Just iface ->
- return [ mkExportDecl avail decl pats (lookupDocs avail warnings (instDocMap iface) (instArgMap iface)) ]
+ availExportDecl avail decl (lookupDocs avail warnings (instDocMap iface) (instArgMap iface))
_ -> return []
+ availExportDecl :: AvailInfo -> LHsDecl GhcRn
+ -> (DocForDecl Name, [(Name, DocForDecl Name)])
+ -> ErrMsgGhc [ ExportItem GhcRn ]
+ availExportDecl avail decl (doc, subs)
+ | availExportsDecl avail = do
+ -- bundled pattern synonyms only make sense if the declaration is
+ -- exported (otherwise there would be nothing to bundle to)
+ bundledPatSyns <- findBundledPatterns avail
+
+ let
+ patSynNames =
+ concatMap (getMainDeclBinder . fst) bundledPatSyns
+
+ fixities =
+ [ (n, f)
+ | n <- availName avail : fmap fst subs ++ patSynNames
+ , Just f <- [M.lookup n fixMap]
+ ]
- mkExportDecl :: AvailInfo -> LHsDecl GhcRn -> [(HsDecl GhcRn, DocForDecl Name)]
- -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem GhcRn
- mkExportDecl avail decl pats (doc, subs) =
- ExportDecl {
- expItemDecl = restrictTo sub_names (extractDecl avail decl)
- , expItemPats = pats'
- , expItemMbDoc = doc
- , expItemSubDocs = subs'
- , expItemInstances = []
- , expItemFixities = fixities
- , expItemSpliced = False
- }
- where
- name = availName avail
- -- all the exported names for this ExportItem
- exported_names = availNamesWithSelectors avail
- is_exported nm = nm `elem` exported_names
-
- subs' = filter (is_exported . fst) subs
- sub_names = map fst subs'
-
- pats' = filter (all is_exported . getMainDeclBinder . fst) pats
- pat_names = concatMap (getMainDeclBinder . fst) pats'
+ return [ ExportDecl {
+ expItemDecl = restrictTo (fmap fst subs)
+ (extractDecl (availName avail) decl)
+ , expItemPats = bundledPatSyns
+ , expItemMbDoc = doc
+ , expItemSubDocs = subs
+ , expItemInstances = []
+ , expItemFixities = fixities
+ , expItemSpliced = False
+ }
+ ]
- fixities = [ (n, f)
- | n <- name:sub_names ++ pat_names
- , Just f <- [M.lookup n fixMap]
- ]
+ | otherwise =
+ return [ ExportDecl {
+ expItemDecl = extractDecl sub decl
+ , expItemPats = []
+ , expItemMbDoc = sub_doc
+ , expItemSubDocs = []
+ , expItemInstances = []
+ , expItemFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ]
+ , expItemSpliced = False
+ }
+ | (sub, sub_doc) <- subs
+ ]
exportedNameSet = mkNameSet exportedNames
isExported n = elemNameSet n exportedNameSet
@@ -825,7 +831,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
mtyThing <- liftGhcToErrMsgGhc (lookupName name)
case mtyThing of
Just (AConLike PatSynCon{}) -> do
- export_items <- declWith (Avail.avail name) []
+ export_items <- declWith (Avail.avail name)
pure [ (unLoc patsyn_decl, patsyn_doc)
| ExportDecl {
expItemDecl = patsyn_decl
@@ -835,7 +841,15 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
_ -> pure []
pure (concat patsyns)
where
- constructor_names = filter isDataConName (availNames avail)
+ mightBeBundledPatSyn n = isDataConName n && n /= availName avail
+ constructor_names = filter mightBeBundledPatSyn (availNames avail)
+
+-- this heavily depends on the invariants stated in Avail
+availExportsDecl :: AvailInfo -> Bool
+availExportsDecl (AvailTC ty_name names _)
+ | n : _ <- names = ty_name == n
+ | otherwise = False
+availExportsDecl _ = True
-- | Given a 'Module' from a 'Name', convert it into a 'Module' that
-- we can actually find in the 'IfaceMap'.
@@ -969,14 +983,15 @@ fullModuleContents is_sig modMap thisMod semMod warnings exportedNames
splices instIfaceMap dflags avail
Nothing -> pure [])
+
-- | 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 :: AvailInfo -> LHsDecl GhcRn -> LHsDecl GhcRn
-extractDecl avail decl
- | availName avail `elem` getMainDeclBinder (unLoc decl) = decl
- | [name] <- availNamesWithSelectors avail =
+extractDecl :: Name -> LHsDecl GhcRn -> LHsDecl GhcRn
+extractDecl name decl
+ | name `elem` getMainDeclBinder (unLoc decl) = decl
+ | otherwise =
case unLoc decl of
TyClD d@ClassDecl {} ->
let matches = [ lsig
@@ -1014,10 +1029,10 @@ extractDecl avail decl
, selectorFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl avail (noLoc . InstD $ DataFamInstD d0)
+ [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
- | otherwise = decl
+
extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
extractPatternSyn nm t tvs cons =
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 03:39:38 +0000