diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface/Create.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 434 |
1 files changed, 214 insertions, 220 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d9f37a4f..9bf21e52 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -31,6 +31,7 @@ import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker +import Data.Bifunctor import Data.Bitraversable import qualified Data.ByteString as BS import qualified Data.Map as M @@ -44,9 +45,12 @@ import Control.Exception (evaluate) import Control.Monad import Data.Traversable +import Avail hiding (avail) +import qualified Avail import qualified Packages import qualified Module import qualified SrcLoc +import ConLike (ConLike(..)) import GHC import HscTypes import Name @@ -59,6 +63,7 @@ import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O import HsDecls ( getConDetails ) + -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. @@ -83,47 +88,36 @@ createInterface tm flags modMap instIfaceMap = do (TcGblEnv { tcg_rdr_env = gre , tcg_warns = warnings - , tcg_patsyns = patsyns + , tcg_exports = all_exports }, md) = tm_internals_ tm -- The renamed source should always be available to us, but it's best -- to be on the safe side. - (group_, mayExports, mayDocHeader) <- + (group_, imports, mayExports, mayDocHeader) <- case renamedSource tm of Nothing -> do liftErrMsg $ tell [ "Warning: Renamed source is not available." ] - return (emptyRnGroup, Nothing, Nothing) - Just (x, _, y, z) -> return (x, y, z) + return (emptyRnGroup, [], Nothing, Nothing) + Just x -> return x - opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl - let opts - | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 - | otherwise = opts0 + opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl -- Process the top-level module header documentation. (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ - exports0 = fmap (reverse . map (unLoc . fst)) mayExports + exports0 = fmap (reverse . map (first unLoc)) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - localBundledPatSyns :: Map Name [Name] - localBundledPatSyns = - case exports of - Nothing -> M.empty - Just ies -> - M.map (nubByName id) $ - M.fromListWith (++) [ (ieWrappedName ty_name, bundled_patsyns) - | IEThingWith (L _ ty_name) _ exported _ <- ies - , let bundled_patsyns = - filter is_patsyn (map (ieWrappedName . unLoc) exported) - , not (null bundled_patsyns) - ] - where - is_patsyn name = elemNameSet name (mkNameSet (map getName patsyns)) + unrestrictedImportedMods + -- module re-exports are only possible with + -- explicit export list + | Just _ <- exports + = unrestrictedModuleImports (map unLoc imports) + | otherwise = M.empty fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs @@ -135,15 +129,16 @@ createInterface tm flags modMap instIfaceMap = do warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) - maps@(!docMap, !argMap, !subMap, !declMap, _) <- + maps@(!docMap, !argMap, !declMap, _) <- liftErrMsg (mkMaps dflags gre localInsts declsWithDocs) let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) -- The MAIN functionality: compute the export items which will -- each be the actual documentation of this module. - exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls - maps localBundledPatSyns fixMap splices exports instIfaceMap dflags + exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre + exportedNames decls maps fixMap unrestrictedImportedMods + splices exports all_exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -184,8 +179,6 @@ createInterface tm flags modMap instIfaceMap = do , ifaceExports = exportedNames , ifaceVisibleExports = visibleNames , ifaceDeclMap = declMap - , ifaceBundledPatSynMap = localBundledPatSyns - , ifaceSubMap = subMap , ifaceFixMap = fixMap , ifaceModuleAliases = aliases , ifaceInstances = instances @@ -231,6 +224,41 @@ mkAliasMap dflags mRenamedSource = alias)) impDecls +-- We want to know which modules are imported without any qualification. This +-- way we can display module reexports more compactly. This mapping also looks +-- through aliases: +-- +-- module M (module X) where +-- import M1 as X +-- import M2 as X +-- +-- With our mapping we know that we can display exported modules M1 and M2. +-- +unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName] +unrestrictedModuleImports idecls = + M.map (map (unLoc . ideclName)) + $ M.filter (all isInteresting) impModMap + where + impModMap = + M.fromListWith (++) (concatMap moduleMapping idecls) + + moduleMapping idecl = + concat [ [ (unLoc (ideclName idecl), [idecl]) ] + , [ (unLoc mod_name, [idecl]) + | Just mod_name <- [ideclAs idecl] + ] + ] + + isInteresting idecl = + case ideclHiding idecl of + -- i) no subset selected + Nothing -> True + -- ii) an import with a hiding clause + -- without any names + Just (True, L _ []) -> True + -- iii) any other case of qualification + _ -> False + -- Similar to GHC.lookupModule -- ezyang: Not really... lookupModuleDyn :: @@ -289,10 +317,13 @@ mkDocOpts mbOpts flags mdl = do hm <- if Flag_HideModule (moduleString mdl) `elem` flags then return $ OptHide : opts else return opts - if Flag_ShowExtensions (moduleString mdl) `elem` flags - then return $ OptShowExtensions : hm - else return hm - + ie <- if Flag_IgnoreAllExports `elem` flags + then return $ OptIgnoreExports : hm + else return hm + se <- if Flag_ShowExtensions (moduleString mdl) `elem` flags + then return $ OptShowExtensions : ie + else return ie + return se parseOption :: String -> ErrMsgM (Maybe DocOption) parseOption "hide" = return (Just OptHide) @@ -308,7 +339,7 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing -------------------------------------------------------------------------------- -type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) +type Maps = (DocMap Name, ArgMap Name, DeclMap, InstMap) -- | Create 'Maps' by looping through the declarations. For each declaration, -- find its names, its subordinates, and its doc strings. Process doc strings @@ -319,11 +350,10 @@ mkMaps :: DynFlags -> [(LHsDecl GhcRn, [HsDocString])] -> ErrMsgM Maps mkMaps dflags gre instances decls = do - (a, b, c, d) <- unzip4 <$> traverse mappings decls + (a, b, c) <- unzip3 <$> traverse mappings decls pure ( f' (map (nubByName fst) a) , f (filterMapping (not . M.null) b) , f (filterMapping (not . null) c) - , f (filterMapping (not . null) d) , instanceMap ) where @@ -339,7 +369,6 @@ mkMaps dflags gre instances decls = do mappings :: (LHsDecl GhcRn, [HsDocString]) -> ErrMsgM ( [(Name, MDoc Name)] , [(Name, Map Int (MDoc Name))] - , [(Name, [Name])] , [(Name, [LHsDecl GhcRn])] ) mappings (ldecl, docStrs) = do @@ -364,7 +393,6 @@ mkMaps dflags gre instances decls = do subNs = [ n | (n, _, _) <- subs ] dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] am = [ (n, args) | n <- ns ] ++ zip subNs subArgs - sm = [ (n, subNs) | n <- ns ] cm = [ (n, [ldecl]) | n <- ns ++ subNs ] seqList ns `seq` @@ -372,7 +400,7 @@ mkMaps dflags gre instances decls = do doc `seq` seqList subDocs `seq` seqList subArgs `seq` - pure (dm, am, sm, cm) + pure (dm, am, cm) instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] @@ -583,55 +611,86 @@ mkExportItems -> [Name] -- exported names (orig) -> [LHsDecl GhcRn] -- renamed source declarations -> Maps - -> Map Name [Name] -> FixMap + -> M.Map ModuleName [ModuleName] -> [SrcSpan] -- splice locations - -> Maybe [IE GhcRn] + -> Maybe [(IE GhcRn, Avails)] + -> Avails -- exported stuff from this module -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem GhcRn] mkExportItems is_sig modMap thisMod semMod warnings gre exportedNames decls - maps@(docMap, argMap, subMap, declMap, instMap) patSynMap fixMap splices optExports instIfaceMap dflags = - case optExports of - Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls + maps fixMap unrestricted_imp_mods splices exportList allExports + instIfaceMap dflags = + case exportList of + Nothing -> + fullModuleContents is_sig modMap thisMod semMod warnings exportedNames + maps fixMap splices instIfaceMap dflags allExports Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEVar (L _ x)) = declWith [] $ ieWrappedName x - lookupExport (IEThingAbs (L _ t)) = declWith [] $ ieWrappedName t - lookupExport (IEThingAll (L _ t)) = do - let name = ieWrappedName t - pats <- findBundledPatterns name - declWith pats name - lookupExport (IEThingWith (L _ t) _ _ _) = do - let name = ieWrappedName t - pats <- findBundledPatterns name - declWith pats name - lookupExport (IEModuleContents (L _ m)) = - -- TODO: We could get more accurate reporting here if IEModuleContents - -- also recorded the actual names that are exported here. We CAN - -- compute this info using @gre@ but 'moduleExports does not seem to - -- do so. - -- NB: Pass in identity module, so we can look it up in index correctly - moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices - lookupExport (IEGroup lev docStr) = liftErrMsg $ do + lookupExport (IEGroup lev docStr, _) = liftErrMsg $ do doc <- processDocString dflags gre docStr return [ExportGroup lev "" doc] - lookupExport (IEDoc docStr) = liftErrMsg $ do + lookupExport (IEDoc docStr, _) = liftErrMsg $ do doc <- processDocStringParas dflags gre docStr return [ExportDoc doc] - lookupExport (IEDocNamed str) = liftErrMsg $ + lookupExport (IEDocNamed str, _) = liftErrMsg $ findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do doc <- processDocStringParas dflags gre docStr return [ExportDoc doc] - declWith :: [(HsDecl GhcRn, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem GhcRn ] - declWith pats t = do - r <- findDecl t + lookupExport (IEModuleContents (L _ mod_name), _) + -- only consider exporting a module if we are sure we + -- are really exporting the whole module and not some + -- subset. We also look through module aliases here. + | Just mods <- M.lookup mod_name unrestricted_imp_mods + , not (null mods) + = concat <$> traverse (moduleExport thisMod dflags modMap instIfaceMap) mods + + lookupExport (_, avails) = + concat <$> traverse availExport (nubAvails avails) + + availExport avail = + availExportItem is_sig modMap thisMod semMod warnings exportedNames + maps fixMap splices instIfaceMap dflags avail + +availExportItem :: Bool -- is it a signature + -> IfaceMap + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> [Name] -- exported names (orig) + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> 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 + where + declWith :: AvailInfo + -> [(HsDecl GhcRn, DocForDecl Name)] + -> ErrMsgGhc [ ExportItem GhcRn ] + declWith avail pats = do + let t = availName avail + r <- findDecl avail case r of ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature @@ -667,15 +726,15 @@ mkExportItems -- 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 t newDecl pats docs_ ] + in return [ mkExportDecl avail newDecl pats docs_ ] L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef - return [ mkExportDecl t + return [ mkExportDecl avail (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ] - _ -> return [ mkExportDecl t decl pats docs_ ] + _ -> return [ mkExportDecl avail decl pats docs_ ] -- Declaration from another package ([], _) -> do @@ -692,33 +751,55 @@ mkExportItems liftErrMsg $ tell ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ] - return [ mkExportDecl t decl pats (noDocForDecl, subs_) ] + return [ mkExportDecl avail decl pats (noDocForDecl, subs_) ] Just iface -> - return [ mkExportDecl t decl pats (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl avail decl pats (lookupDocs avail warnings (instDocMap iface) (instArgMap iface)) ] _ -> return [] - mkExportDecl :: Name -> LHsDecl GhcRn -> [(HsDecl GhcRn, DocForDecl Name)] + mkExportDecl :: AvailInfo -> LHsDecl GhcRn -> [(HsDecl GhcRn, DocForDecl Name)] -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem GhcRn - mkExportDecl name decl pats (doc, subs) = decl' + 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 - decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) pats' doc subs' [] fixities False - subs' = filter (isExported . fst) subs - pats' = [ d | d@(patsyn_decl, _) <- pats - , all isExported (getMainDeclBinder patsyn_decl) ] + name = availName avail + -- all the exported names for this ExportItem + exported_names = availNamesWithSelectors avail + subs' = [ sub + | sub@(sub_name, _) <- subs + , sub_name `elem` exported_names + ] + pats' = [ patsyn + | patsyn@(patsyn_decl, _) <- pats + , all (`elem` exported_names) (getMainDeclBinder patsyn_decl) + ] sub_names = map fst subs' - pat_names = [ n | (patsyn_decl, _) <- pats', n <- getMainDeclBinder patsyn_decl] - fixities = [ (n, f) | n <- name:sub_names++pat_names, Just f <- [M.lookup n fixMap] ] + pat_names = [ n + | (patsyn_decl, _) <- pats' + , n <- getMainDeclBinder patsyn_decl + ] + fixities = [ (n, f) + | n <- name:sub_names ++ pat_names + , Just f <- [M.lookup n fixMap] + ] exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet - findDecl :: Name -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) - findDecl n + findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl avail | m == semMod = case M.lookup n declMap of - Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap) + Just ds -> return (ds, lookupDocs avail warnings docMap argMap) Nothing | is_sig -> do -- OK, so it wasn't in the local declaration map. It could @@ -735,47 +816,31 @@ mkExportItems return ([], (noDocForDecl, [])) | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap , Just ds <- M.lookup n (ifaceDeclMap iface) = - return (ds, lookupDocs n warnings + return (ds, lookupDocs avail warnings (ifaceDocMap iface) - (ifaceArgMap iface) - (ifaceSubMap iface)) + (ifaceArgMap iface)) | otherwise = return ([], (noDocForDecl, [])) where + n = availName avail m = nameModule n - findBundledPatterns :: Name -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)] - findBundledPatterns t = - let - m = nameModule t - - local_bundled_patsyns = - M.findWithDefault [] t patSynMap - - iface_bundled_patsyns - | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap - , Just patsyns <- M.lookup t (ifaceBundledPatSynMap iface) - = patsyns - - | Just iface <- M.lookup m instIfaceMap - , Just patsyns <- M.lookup t (instBundledPatSynMap iface) - = patsyns - - | otherwise - = [] - - patsyn_decls = do - for (local_bundled_patsyns ++ iface_bundled_patsyns) $ \patsyn_name -> do - -- call declWith here so we don't have to prepare the pattern synonym for - -- showing ourselves. - export_items <- declWith [] patsyn_name + findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)] + findBundledPatterns avail = do + patsyns <- for constructor_names $ \name -> do + mtyThing <- liftGhcToErrMsgGhc (lookupName name) + case mtyThing of + Just (AConLike PatSynCon{}) -> do + export_items <- declWith (Avail.avail name) [] pure [ (unLoc patsyn_decl, patsyn_doc) | ExportDecl { expItemDecl = patsyn_decl , expItemMbDoc = patsyn_doc } <- export_items ] - - in concat <$> patsyn_decls + _ -> pure [] + pure (concat patsyns) + where + constructor_names = filter isDataConName (availNames avail) -- | Given a 'Module' from a 'Name', convert it into a 'Module' that -- we can actually find in the 'IfaceMap'. @@ -820,48 +885,29 @@ hiValExportItem dflags name nLoc doc splice fixity = do -- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap +lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs n warnings docMap argMap subMap = +lookupDocs avail warnings docMap argMap = + let n = availName avail in let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in - let subs = M.findWithDefault [] n subMap in - let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in + let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) + | s <- availNamesWithSelectors avail + , s /= n ] in (doc, subDocs) where lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) --- | Return all export items produced by an exported module. That is, we're --- interested in the exports produced by \"module B\" in such a scenario: --- --- > module A (module B) where --- > import B (...) hiding (...) --- --- There are three different cases to consider: --- --- 1) B is hidden, in which case we return all its exports that are in scope in A. --- 2) B is visible, but not all its exports are in scope in A, in which case we --- only return those that are. --- 3) B is visible and all its exports are in scope, in which case we return --- a single 'ExportModule' item. -moduleExports :: Module -- ^ Module A (identity, NOT semantic) - -> ModuleName -- ^ The real name of B, the exported module - -> DynFlags -- ^ The flags used when typechecking A - -> WarningMap - -> GlobalRdrEnv -- ^ The renaming environment used for A - -> [Name] -- ^ All the exports of A - -> [LHsDecl GhcRn] -- ^ All the renamed declarations in A - -> IfaceMap -- ^ Already created interfaces - -> InstIfaceMap -- ^ Interfaces in other packages - -> Maps - -> FixMap - -> [SrcSpan] -- ^ Locations of all TH splices - -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items -moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices - | expMod == moduleName thisMod - = fullModuleContents dflags warnings gre maps fixMap splices decls - | otherwise = +-- | Export the given module as `ExportModule`. We are not concerned with the +-- single export items of the given module. +moduleExport :: Module -- ^ Module A (identity, NOT semantic) + -> DynFlags -- ^ The flags used when typechecking A + -> IfaceMap -- ^ Already created interfaces + -> InstIfaceMap -- ^ Interfaces in other packages + -> ModuleName -- ^ The exported module + -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items +moduleExport thisMod dflags ifaceMap instIfaceMap expMod = -- NB: we constructed the identity module when looking up in -- the IfaceMap. case M.lookup m ifaceMap of @@ -882,7 +928,6 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa m = mkModule unitId expMod -- Identity module! unitId = moduleUnitId thisMod - -- Note [1]: ------------ -- It is unnecessary to document a subordinate by itself at the top level if @@ -903,87 +948,35 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa -- | Simplified variant of 'mkExportItems', where we can assume that -- every locally defined declaration is exported; thus, we just -- zip through the renamed declarations. -fullModuleContents :: DynFlags + +fullModuleContents :: Bool -- is it a signature + -> IfaceMap + -> Module -- this module + -> Module -- semantic module -> WarningMap - -> GlobalRdrEnv -- ^ The renaming environment + -> [Name] -- exported names (orig) -> Maps -> FixMap - -> [SrcSpan] -- ^ Locations of all TH splices - -> [LHsDecl GhcRn] -- ^ All the renamed declarations + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> Avails -> ErrMsgGhc [ExportItem GhcRn] -fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = - liftM catMaybes $ mapM mkExportItem (expandSigDecls decls) - where - -- A type signature can have multiple names, like: - -- foo, bar :: Types.. - -- - -- We go through the list of declarations and expand type signatures, so - -- that every type signature has exactly one name! - expandSigDecls :: [LHsDecl name] -> [LHsDecl name] - expandSigDecls = concatMap f - where - f (L l (SigD sig)) = [ L l (SigD s) | s <- expandSig sig ] - - -- also expand type signatures for class methods - f (L l (TyClD cls@ClassDecl{})) = - [ L l (TyClD cls { tcdSigs = concatMap expandLSig (tcdSigs cls) }) ] - f x = [x] - - expandLSig :: LSig name -> [LSig name] - expandLSig (L l sig) = [ L l s | s <- expandSig sig ] - - expandSig :: Sig name -> [Sig name] - expandSig (TypeSig names t) = [ TypeSig [n] t | n <- names ] - expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ] - expandSig (PatSynSig names t) = [ PatSynSig [n] t | n <- names ] - expandSig x = [x] - - mkExportItem :: LHsDecl GhcRn -> ErrMsgGhc (Maybe (ExportItem GhcRn)) - mkExportItem (L _ (DocD (DocGroup lev docStr))) = do - doc <- liftErrMsg (processDocString dflags gre docStr) - return . Just . ExportGroup lev "" $ doc - mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do - doc <- liftErrMsg (processDocStringParas dflags gre docStr) - return . Just . ExportDoc $ doc - mkExportItem (L l (ValD d)) - | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = - -- Top-level binding without type signature. - let (doc, _) = lookupDocs name warnings docMap argMap subMap in - fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap) - | otherwise = return Nothing - mkExportItem decl@(L l (InstD d)) - | Just name <- M.lookup (getInstLoc d) instMap = - expInst decl l name - mkExportItem decl@(L l (DerivD {})) - | Just name <- M.lookup l instMap = - expInst decl l name - mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do - mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef - expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name - mkExportItem decl@(L l d) - | name:_ <- getMainDeclBinder d = expDecl decl l name - | otherwise = return Nothing - - fixities name subs = [ (n,f) | n <- name : map fst subs - , Just f <- [M.lookup n fixMap] ] - - expDecl decl l name = return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) - where (doc, subs) = lookupDocs name warnings docMap argMap subMap - - expInst decl l name = - let (doc, subs) = lookupDocs name warnings docMap argMap subMap in - return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) +fullModuleContents is_sig modMap thisMod semMod warnings exportedNames + maps fixMap splices instIfaceMap dflags avails = + concat <$> traverse (availExportItem is_sig modMap thisMod + semMod warnings exportedNames maps fixMap + splices instIfaceMap dflags) avails -- | 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 - | name `elem` getMainDeclBinder (unLoc decl) = decl - | otherwise = +extractDecl :: AvailInfo -> LHsDecl GhcRn -> LHsDecl GhcRn +extractDecl avail decl + | availName avail `elem` getMainDeclBinder (unLoc decl) = decl + | [name] <- availNamesWithSelectors avail = case unLoc decl of TyClD d@ClassDecl {} -> let matches = [ lsig @@ -1021,9 +1014,10 @@ extractDecl name decl , selectorFieldOcc n == name ] in case matches of - [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0) + [d0] -> extractDecl avail (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 = @@ -1082,7 +1076,7 @@ pruneExportItems = filter hasDoc mkVisibleNames :: Maps -> [ExportItem GhcRn] -> [DocOption] -> [Name] -mkVisibleNames (_, _, _, _, instMap) exports opts +mkVisibleNames (_, _, _, instMap) exports opts | OptHide `elem` opts = [] | otherwise = let ns = concatMap exportName exports in seqList ns `seq` ns |