aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs175
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs3
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs3
4 files changed, 137 insertions, 46 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 4e1a9b3a..e594feae 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -11,6 +11,10 @@
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
+--
+-- This module provides a single function 'createInterface',
+-- which creates a Haddock 'Interface' from the typechecking
+-- results 'TypecheckedModule' from GHC.
-----------------------------------------------------------------------------
module Haddock.Interface.Create (createInterface) where
@@ -36,7 +40,6 @@ import Control.Arrow (second)
import Control.DeepSeq
import Control.Monad
import Data.Function (on)
-import qualified Data.Foldable as F
import qualified Packages
import qualified Module
@@ -50,12 +53,16 @@ import TcRnTypes
import FastString (concatFS)
import BasicTypes ( StringLiteral(..), SourceText(..) )
import qualified Outputable as O
-import HsDecls ( gadtDeclDetails,getConDetails )
+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'.
-createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface
+createInterface :: TypecheckedModule
+ -> [Flag] -- Boolean flags
+ -> IfaceMap -- Locally processed modules
+ -> InstIfaceMap -- External, already installed interfaces
+ -> ErrMsgGhc Interface
createInterface tm flags modMap instIfaceMap = do
let ms = pm_mod_summary . tm_parsed_module $ tm
@@ -63,6 +70,8 @@ createInterface tm flags modMap instIfaceMap = do
L _ hsm = parsedSource tm
!safety = modInfoSafe mi
mdl = ms_mod ms
+ sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm))
+ is_sig = ms_hsc_src ms == HsigFile
dflags = ms_hspp_opts ms
!instances = modInfoInstances mi
!fam_instances = md_fam_insts md
@@ -84,13 +93,15 @@ createInterface tm flags modMap instIfaceMap = do
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
+ -- Process the top-level module header documentation.
(!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
let declsWithDocs = topDecls group_
fixMap = mkFixMap group_
(decls, _) = unzip declsWithDocs
- localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances
- ++ map getName fam_instances
+ localInsts = filter (nameIsLocalOrFrom sem_mdl)
+ $ map getName instances
+ ++ map getName fam_instances
-- Locations of all TH splices
splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
@@ -105,7 +116,9 @@ createInterface tm flags modMap instIfaceMap = do
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
- exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls
+ -- 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 fixMap splices exports instIfaceMap dflags
let !visibleNames = mkVisibleNames maps exportItems opts
@@ -131,6 +144,7 @@ createInterface tm flags modMap instIfaceMap = do
return $! Interface {
ifaceMod = mdl
+ , ifaceIsSig = is_sig
, ifaceOrigFilename = msHsFilePath ms
, ifaceInfo = info
, ifaceDoc = Documentation mbDoc modWarn
@@ -157,6 +171,10 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceTokenizedSrc = tokenizedSrc
}
+-- | Given all of the @import M as N@ declarations in a package,
+-- create a mapping from the module identity of M, to an alias N
+-- (if there are multiple aliases, we pick the last one.) This
+-- will go in 'ifaceModuleAliases'.
mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
mkAliasMap dflags mRenamedSource =
case mRenamedSource of
@@ -167,13 +185,28 @@ mkAliasMap dflags mRenamedSource =
SrcLoc.L _ alias <- ideclAs impDecl
return $
(lookupModuleDyn dflags
+ -- TODO: This is supremely dodgy, because in general the
+ -- UnitId isn't going to look anything like the package
+ -- qualifier (even with old versions of GHC, the
+ -- IPID would be p-0.1, but a package qualifier never
+ -- has a version number it. (Is it possible that in
+ -- Haddock-land, the UnitIds never have version numbers?
+ -- I, ezyang, have not quite understand Haddock's package
+ -- identifier model.)
+ --
+ -- Additionally, this is simulating some logic GHC already
+ -- has for deciding how to qualify names when it outputs
+ -- them to the user. We should reuse that information;
+ -- or at least reuse the renamed imports, which know what
+ -- they import!
(fmap Module.fsToUnitId $
fmap sl_fs $ ideclPkgQual impDecl)
(case ideclName impDecl of SrcLoc.L _ name -> name),
alias))
impDecls
--- similar to GHC.lookupModule
+-- Similar to GHC.lookupModule
+-- ezyang: Not really...
lookupModuleDyn ::
DynFlags -> Maybe UnitId -> ModuleName -> Module
lookupModuleDyn _ (Just pkgId) mdlName =
@@ -323,6 +356,8 @@ mkMaps dflags gre instances decls =
-- | Get all subordinate declarations inside a declaration, and their docs.
+-- A subordinate declaration is something like the associate type or data
+-- family of a type class.
subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
InstD (ClsInstD d) -> do
@@ -491,12 +526,14 @@ collectDocs = go Nothing []
-- We create the export items even if the module is hidden, since they
-- might be useful when creating the export items for other modules.
mkExportItems
- :: IfaceMap
+ :: Bool -- is it a signature
+ -> IfaceMap
-> Module -- this module
+ -> Module -- semantic module
-> WarningMap
-> GlobalRdrEnv
-> [Name] -- exported names (orig)
- -> [LHsDecl Name]
+ -> [LHsDecl Name] -- renamed source declarations
-> Maps
-> FixMap
-> [SrcSpan] -- splice locations
@@ -505,17 +542,22 @@ mkExportItems
-> DynFlags
-> ErrMsgGhc [ExportItem Name]
mkExportItems
- modMap thisMod warnings gre exportedNames decls
+ is_sig modMap thisMod semMod warnings gre exportedNames decls
maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
case optExports of
Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
Just exports -> liftM concat $ mapM lookupExport exports
where
- lookupExport (IEVar (L _ x)) = declWith x
- lookupExport (IEThingAbs (L _ t)) = declWith t
- lookupExport (IEThingAll (L _ t)) = declWith t
- lookupExport (IEThingWith (L _ t) _ _ _) = declWith t
+ lookupExport (IEVar (L _ x)) = declWith $ ieWrappedName x
+ lookupExport (IEThingAbs (L _ t)) = declWith $ ieWrappedName t
+ lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t
+ lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t
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) = return $
return . ExportGroup lev "" $ processDocString dflags gre docStr
@@ -529,8 +571,9 @@ mkExportItems
Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
- declWith t =
- case findDecl t of
+ declWith t = do
+ r <- findDecl t
+ case r of
([L l (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
@@ -583,6 +626,8 @@ mkExportItems
Just decl ->
-- We try to get the subs and docs
-- from the installed .haddock file for that package.
+ -- TODO: This needs to be more sophisticated to deal
+ -- with signature inheritance
case M.lookup (nameModule t) instIfaceMap of
Nothing -> do
liftErrMsg $ tell
@@ -598,8 +643,7 @@ mkExportItems
mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
mkExportDecl name decl (doc, subs) = decl'
where
- decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False
- mdl = nameModule name
+ decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False
subs' = filter (isExported . fst) subs
sub_names = map fst subs'
fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
@@ -608,16 +652,41 @@ mkExportItems
isExported = (`elem` exportedNames)
- findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
+ findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
findDecl n
- | m == thisMod, Just ds <- M.lookup n declMap =
- (ds, lookupDocs n warnings docMap argMap subMap)
- | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
- (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
- | otherwise = ([], (noDocForDecl, []))
+ | m == semMod =
+ case M.lookup n declMap of
+ Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap)
+ Nothing
+ | is_sig -> do
+ -- OK, so it wasn't in the local declaration map. It could
+ -- have been inherited from a signature. Reconstitute it
+ -- from the type.
+ mb_r <- hiDecl dflags n
+ case mb_r of
+ Nothing -> return ([], (noDocForDecl, []))
+ -- TODO: If we try harder, we might be able to find
+ -- a Haddock! Look in the Haddocks for each thing in
+ -- requirementContext (pkgState)
+ Just decl -> return ([decl], (noDocForDecl, []))
+ | otherwise ->
+ return ([], (noDocForDecl, []))
+ | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap
+ , Just ds <- M.lookup n (ifaceDeclMap iface) =
+ return (ds, lookupDocs n warnings
+ (ifaceDocMap iface)
+ (ifaceArgMap iface)
+ (ifaceSubMap iface))
+ | otherwise = return ([], (noDocForDecl, []))
where
m = nameModule n
+-- | Given a 'Module' from a 'Name', convert it into a 'Module' that
+-- we can actually find in the 'IfaceMap'.
+semToIdMod :: UnitId -> Module -> Module
+semToIdMod this_uid m
+ | Module.isHoleModule m = mkModule this_uid (moduleName m)
+ | otherwise = m
hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
hiDecl dflags t = do
@@ -680,13 +749,13 @@ lookupDocs n warnings docMap argMap subMap =
-- 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
+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 declarations in A
+ -> [LHsDecl Name] -- ^ All the renamed declarations in A
-> IfaceMap -- ^ Already created interfaces
-> InstIfaceMap -- ^ Interfaces in other packages
-> Maps
@@ -694,8 +763,11 @@ moduleExports :: Module -- ^ Module A
-> [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
- | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls
+ | expMod == moduleName thisMod
+ = fullModuleContents dflags warnings gre maps fixMap splices decls
| otherwise =
+ -- NB: we constructed the identity module when looking up in
+ -- the IfaceMap.
case M.lookup m ifaceMap of
Just iface
| OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)
@@ -711,7 +783,7 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
"documentation for exported module: " ++ pretty dflags expMod]
return []
where
- m = mkModule unitId expMod
+ m = mkModule unitId expMod -- Identity module!
unitId = moduleUnitId thisMod
@@ -732,8 +804,17 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
-- (For more information, see Trac #69)
-fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]
- -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+-- | 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
+ -> WarningMap
+ -> GlobalRdrEnv -- ^ The renaming environment
+ -> 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 (expandSig decls)
where
@@ -790,26 +871,34 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
-- 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 -> Module -> LHsDecl Name -> LHsDecl Name
-extractDecl name mdl decl
+extractDecl :: Name -> LHsDecl Name -> LHsDecl Name
+extractDecl name decl
| name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
case unLoc decl of
TyClD d@ClassDecl {} ->
- let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
- isTypeLSig sig ] -- TODO: document fixity
+ let matches = [ lsig
+ | lsig <- tcdSigs d
+ , ClassOpSig False _ _ <- pure $ unLoc lsig
+ -- Note: exclude `default` declarations (see #505)
+ , name `elem` sigName lsig
+ ]
+ -- TODO: document fixity
in case matches of
[s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
L pos sig = addClassContext n tyvar_names s0
in L pos (SigD sig)
- _ -> error "internal: extractDecl (ClassDecl)"
+ _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:"
+ O.$$ O.nest 4 (O.ppr d)
+ O.$$ O.text "Matches:"
+ O.$$ O.nest 4 (O.ppr matches))
TyClD d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
- in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d))
+ in 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 }) ->
- SigD <$> extractRecSel name mdl n tys (dd_cons 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)
@@ -819,25 +908,25 @@ extractDecl name mdl decl
, selectorFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
+ [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
-extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
+extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name]
-> LSig Name
-extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
+extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
-extractRecSel nm mdl t tvs (L _ con : rest) =
+extractRecSel nm t tvs (L _ con : rest) =
case getConDetails con of
RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
- _ -> extractRecSel nm mdl t tvs rest
+ _ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
, L l n <- ns, selectorFieldOcc n == nm ]
data_ty
- -- | ResTyGADT _ ty <- con_res con = ty
+ -- ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = hsib_body $ con_type con
| otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 4f6b2c09..608344ad 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -31,6 +31,7 @@ import Haddock.Types
import Name
import Outputable ( showPpr )
import RdrName
+import EnumSet
import RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
@@ -67,7 +68,7 @@ processModuleHeader dflags gre safety mayStr = do
let flags :: [LangExt.Extension]
-- We remove the flags implied by the language setting and we display the language instead
- flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags)
+ flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags)
return (hmi { hmi_safety = Just $ showPpr dflags safety
, hmi_language = language dflags
, hmi_extensions = flags
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index e7d2a085..768a31ce 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -76,7 +76,7 @@ parseKey :: String -> String -> Maybe (String,String)
parseKey key toParse0 =
do
let
- (spaces0,toParse1) = extractLeadingSpaces toParse0
+ (spaces0,toParse1) = extractLeadingSpaces (dropWhile (`elem` ['\r', '\n']) toParse0)
indentation = spaces0
afterKey0 <- extractPrefix key toParse1
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index f88d9f4e..b43860fb 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -577,7 +577,8 @@ renameImplicit :: (in_thing -> RnM out_thing)
renameImplicit rn_thing (HsIB { hsib_body = thing })
= do { thing' <- rn_thing thing
; return (HsIB { hsib_body = thing'
- , hsib_vars = PlaceHolder }) }
+ , hsib_vars = PlaceHolder
+ , hsib_closed = PlaceHolder }) }
renameWc :: (in_thing -> RnM out_thing)
-> HsWildCardBndrs Name in_thing
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 13:55:00 +0000