diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface/Create.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 519 |
1 files changed, 259 insertions, 260 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 87cdb01f..9bf21e52 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -30,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 @@ -43,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 @@ -58,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'. @@ -82,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) 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 @@ -134,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 @@ -183,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 @@ -230,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 :: @@ -288,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) @@ -307,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 @@ -315,14 +347,13 @@ type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) mkMaps :: DynFlags -> GlobalRdrEnv -> [Name] - -> [(LHsDecl Name, [HsDocString])] + -> [(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 @@ -335,11 +366,10 @@ mkMaps dflags gre instances decls = do filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] filterMapping p = map (filter (p . snd)) - mappings :: (LHsDecl Name, [HsDocString]) + mappings :: (LHsDecl GhcRn, [HsDocString]) -> ErrMsgM ( [(Name, MDoc Name)] , [(Name, Map Int (MDoc Name))] - , [(Name, [Name])] - , [(Name, [LHsDecl Name])] + , [(Name, [LHsDecl GhcRn])] ) mappings (ldecl, docStrs) = do let L l decl = ldecl @@ -363,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` @@ -371,12 +400,12 @@ 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 ] - names :: SrcSpan -> HsDecl Name -> [Name] + names :: SrcSpan -> HsDecl GhcRn -> [Name] names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. where loc = case d of TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs @@ -401,15 +430,17 @@ mkMaps dflags gre instances decls = do -- A subordinate declaration is something like the associate type or data -- family of a type class. subordinates :: InstMap - -> HsDecl Name + -> HsDecl GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do - DataFamInstDecl { dfid_tycon = L l _ - , dfid_defn = def } <- unLoc <$> cid_datafam_insts d - [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def + DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_tycon = L l _ + , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d + [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - InstD (DataFamInstD d) -> dataSubs (dfid_defn d) + InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d }))) + -> dataSubs (feqn_rhs d) TyClD d | isClassDecl d -> classSubs d | isDataDecl d -> dataSubs (tcdDataDefn d) _ -> [] @@ -417,7 +448,7 @@ subordinates instMap decl = case decl of classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] - dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)] + dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields ++ derivs where cons = map unL $ (dd_cons dd) @@ -434,7 +465,7 @@ subordinates instMap decl = case decl of , Just instName <- [M.lookup l instMap] ] -- | Extract function argument docs from inside types. -typeDocs :: HsDecl Name -> Map Int HsDocString +typeDocs :: HsDecl GhcRn -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of @@ -455,7 +486,7 @@ typeDocs d = -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. -classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] +classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats @@ -467,18 +498,18 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])] +topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Extract a map of fixity declarations only -mkFixMap :: HsGroup Name -> FixMap +mkFixMap :: HsGroup GhcRn -> FixMap mkFixMap group_ = M.fromList [ (n,f) | L _ (FixitySig ns f) <- hs_fixds group_, L _ n <- ns ] -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. -ungroup :: HsGroup Name -> [LHsDecl Name] +ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ = mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ @@ -578,57 +609,88 @@ mkExportItems -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) - -> [LHsDecl Name] -- renamed source declarations + -> [LHsDecl GhcRn] -- renamed source declarations -> Maps - -> Map Name [Name] -> FixMap + -> M.Map ModuleName [ModuleName] -> [SrcSpan] -- splice locations - -> Maybe [IE Name] + -> Maybe [(IE GhcRn, Avails)] + -> Avails -- exported stuff from this module -> InstIfaceMap -> DynFlags - -> ErrMsgGhc [ExportItem Name] + -> 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 Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ] - 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 @@ -664,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 @@ -689,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 Name -> [(HsDecl Name, DocForDecl Name)] - -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name - mkExportDecl name decl pats (doc, subs) = decl' + 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 - 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 Name], (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 @@ -732,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 Name, 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'. @@ -781,7 +849,7 @@ semToIdMod this_uid m | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m -hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) +hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t case mayTyThing of @@ -803,7 +871,7 @@ hiDecl dflags t = do -- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the -- declaration and use it instead - 'nLoc' here. hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool - -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) + -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn) hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of @@ -817,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 Name] -- ^ 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 Name] -- ^ 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 @@ -879,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 @@ -900,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 Name] -- ^ All the renamed declarations - -> ErrMsgGhc [ExportItem Name] -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 Name -> ErrMsgGhc (Maybe (ExportItem Name)) - 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)) - + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> Avails + -> ErrMsgGhc [ExportItem GhcRn] +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 Name -> LHsDecl Name -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 @@ -1003,32 +999,35 @@ 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)) - InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n - , dfid_pats = HsIB { hsib_body = tys } - , dfid_defn = defn }) -> + InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = + FamEqn { feqn_tycon = L _ n + , feqn_pats = tys + , feqn_rhs = defn }}))) -> SigD <$> extractRecSel name n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> - let matches = [ d | L _ d <- insts - -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) - , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d)) - , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) - , L _ n <- ns - , selectorFieldOcc n == name + let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) + <- insts + -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) + , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d)) + , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) + , L _ n <- ns + , 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 Name] -> [LConDecl Name] -> LSig Name +extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn extractPatternSyn nm t tvs cons = case filter matches cons of [] -> error "extractPatternSyn: constructor pattern not found" con:_ -> extract <$> con where - matches :: LConDecl Name -> Bool + matches :: LConDecl GhcRn -> Bool matches (L _ con) = nm `elem` (unLoc <$> getConNames con) - extract :: ConDecl Name -> Sig Name + extract :: ConDecl GhcRn -> Sig GhcRn extract con = let args = case getConDetails con of @@ -1050,8 +1049,8 @@ extractPatternSyn nm t tvs cons = | ConDeclGADT{} <- con = hsib_body $ con_type con | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs -extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name] - -> LSig Name +extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] + -> LSig GhcRn extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = @@ -1060,7 +1059,7 @@ extractRecSel nm t tvs (L _ con : rest) = L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where - matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] + matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds , L l n <- ns, selectorFieldOcc n == nm ] data_ty @@ -1069,15 +1068,15 @@ extractRecSel nm t tvs (L _ con : rest) = | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs -- | Keep export items with docs. -pruneExportItems :: [ExportItem Name] -> [ExportItem Name] +pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] pruneExportItems = filter hasDoc where hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True -mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name] -mkVisibleNames (_, _, _, _, instMap) exports opts +mkVisibleNames :: Maps -> [ExportItem GhcRn] -> [DocOption] -> [Name] +mkVisibleNames (_, _, _, instMap) exports opts | OptHide `elem` opts = [] | otherwise = let ns = concatMap exportName exports in seqList ns `seq` ns @@ -1122,7 +1121,7 @@ mkTokenizedSrc ms src = do return $ Hyperlinker.enrich src (Hyperlinker.parse (decodeUtf8 rawSrc)) -- | Find a stand-alone documentation comment by its name. -findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) +findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString) findNamedDoc name = search where search [] = do |