aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs6
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs434
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs3
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs11
-rw-r--r--haddock-api/src/Haddock/Types.hs10
5 files changed, 220 insertions, 244 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 0e5811b1..2231ce7e 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -118,12 +118,12 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
where
attachFixities e@ExportDecl{ expItemDecl = L _ d
, expItemPats = patsyns
+ , expItemSubDocs = subDocs
} = e { expItemFixities =
nubByName fst $ expItemFixities e ++
[ (n',f) | n <- getMainDeclBinder d
- , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap <|> Just []]
- , n' <- n : (subs ++ patsyn_names)
- , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
+ , n' <- n : (map fst subDocs ++ patsyn_names)
+ , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
] }
where
patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
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
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 9a569204..636d3e19 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -37,8 +37,6 @@ jsonInstalledInterface InstalledInterface{..} = jsonObject properties
, ("exports" , jsonArray (map jsonName instExports))
, ("visible_exports" , jsonArray (map jsonName instVisibleExports))
, ("options" , jsonArray (map (jsonString . show) instOptions))
- , ("sub_map" , jsonMap nameStableString (jsonArray . map jsonName) instSubMap)
- , ("bundled_patsyns" , jsonMap nameStableString (jsonArray . map jsonName) instBundledPatSynMap)
, ("fix_map" , jsonMap nameStableString jsonFixity instFixMap)
]
@@ -106,4 +104,3 @@ jsonInt = JSInt
jsonBool :: Bool -> JsonDoc
jsonBool = JSBool
-
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 3b1a5f33..59582fd2 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805)
-binaryInterfaceVersion = 31
+binaryInterfaceVersion = 32
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -373,7 +373,7 @@ instance Binary InterfaceFile where
instance Binary InstalledInterface where
put_ bh (InstalledInterface modu is_sig info docMap argMap
- exps visExps opts subMap patSynMap fixMap) = do
+ exps visExps opts fixMap) = do
put_ bh modu
put_ bh is_sig
put_ bh info
@@ -381,8 +381,6 @@ instance Binary InstalledInterface where
put_ bh exps
put_ bh visExps
put_ bh opts
- put_ bh subMap
- put_ bh patSynMap
put_ bh fixMap
get bh = do
@@ -393,12 +391,9 @@ instance Binary InstalledInterface where
exps <- get bh
visExps <- get bh
opts <- get bh
- subMap <- get bh
- patSynMap <- get bh
fixMap <- get bh
-
return (InstalledInterface modu is_sig info docMap argMap
- exps visExps opts subMap patSynMap fixMap)
+ exps visExps opts fixMap)
instance Binary DocOption where
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 3ad90912..188611a0 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -101,9 +101,6 @@ data Interface = Interface
-- names of subordinate declarations mapped to their parent declarations.
, ifaceDeclMap :: !(Map Name [LHsDecl GhcRn])
- -- | Bundled pattern synonym declarations for specific types.
- , ifaceBundledPatSynMap :: !(Map Name [Name])
-
-- | Documentation of declarations originating from the module (including
-- subordinates).
, ifaceDocMap :: !(DocMap Name)
@@ -114,7 +111,6 @@ data Interface = Interface
, ifaceRnDocMap :: !(DocMap DocName)
, ifaceRnArgMap :: !(ArgMap DocName)
- , ifaceSubMap :: !(Map Name [Name])
, ifaceFixMap :: !(Map Name Fixity)
, ifaceExportItems :: ![ExportItem GhcRn]
@@ -184,10 +180,6 @@ data InstalledInterface = InstalledInterface
-- | Haddock options for this module (prune, ignore-exports, etc).
, instOptions :: [DocOption]
- , instSubMap :: Map Name [Name]
-
- , instBundledPatSynMap :: Map Name [Name]
-
, instFixMap :: Map Name Fixity
}
@@ -203,8 +195,6 @@ toInstalledIface interface = InstalledInterface
, instExports = ifaceExports interface
, instVisibleExports = ifaceVisibleExports interface
, instOptions = ifaceOptions interface
- , instSubMap = ifaceSubMap interface
- , instBundledPatSynMap = ifaceBundledPatSynMap interface
, instFixMap = ifaceFixMap interface
}
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 01:27:56 +0000