diff options
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 129 |
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 = |