diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface/Create.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 204 |
1 files changed, 149 insertions, 55 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index cb855693..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 @@ -47,14 +51,18 @@ import Bag import RdrName import TcRnTypes import FastString (concatFS) -import BasicTypes ( StringLiteral(..) ) +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'. -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 @@ -62,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 @@ -83,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 ] @@ -104,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 @@ -130,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 @@ -156,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 @@ -163,16 +182,31 @@ mkAliasMap dflags mRenamedSource = Just (_,impDecls,_,_) -> M.fromList $ mapMaybe (\(SrcLoc.L _ impDecl) -> do - alias <- ideclAs impDecl + 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 = @@ -305,16 +339,16 @@ mkMaps dflags gre instances decls = where loc = case d of TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs _ -> getInstLoc d + names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl -- Note [2]: ------------ --- We relate ClsInsts to InstDecls using the SrcSpans buried inside them. --- That should work for normal user-written instances (from looking at GHC --- sources). We can assume that commented instances are user-written. --- This lets us relate Names (from ClsInsts) to comments (associated --- with InstDecls). - +-- We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried +-- inside them. That should work for normal user-written instances (from +-- looking at GHC sources). We can assume that commented instances are +-- user-written. This lets us relate Names (from ClsInsts) to comments +-- (associated with InstDecls and DerivDecls). -------------------------------------------------------------------------------- -- Declarations @@ -322,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 @@ -338,7 +374,7 @@ subordinates instMap decl = case decl of , name <- getMainDeclBinder d, not (isValD d) ] dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)] - dataSubs dd = constrs ++ fields + dataSubs dd = constrs ++ fields ++ derivs where cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) @@ -347,6 +383,11 @@ subordinates instMap decl = case decl of | RecCon flds <- map getConDetails cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ] + derivs = [ (instName, [unL doc], M.empty) + | HsIB { hsib_body = L l (HsDocTy _ doc) } + <- concatMap (unLoc . deriv_clause_tys . unLoc) $ + unLoc $ dd_derivs dd + , Just instName <- [M.lookup l instMap] ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString @@ -394,12 +435,12 @@ mkFixMap group_ = M.fromList [ (n,f) -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup Name -> [LHsDecl Name] ungroup group_ = - mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++ + mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ mkDecls hs_defds DefD group_ ++ mkDecls hs_fords ForD group_ ++ mkDecls hs_docs DocD group_ ++ - mkDecls hs_instds InstD group_ ++ + mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++ mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ where @@ -433,8 +474,9 @@ filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterDecls = filter (isHandled . unL . fst) where isHandled (ForD (ForeignImport {})) = True - isHandled (TyClD {}) = True - isHandled (InstD {}) = True + isHandled (TyClD {}) = True + isHandled (InstD {}) = True + isHandled (DerivD {}) = True isHandled (SigD d) = isUserLSig (reL d) isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs @@ -484,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 @@ -498,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 @@ -522,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 @@ -562,7 +612,7 @@ mkExportItems L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -576,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 @@ -591,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] ] @@ -601,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 @@ -673,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 @@ -687,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) @@ -704,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 @@ -725,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 @@ -756,11 +844,13 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap | otherwise = return Nothing mkExportItem decl@(L l (InstD d)) | Just name <- M.lookup (getInstLoc d) instMap = - let (doc, subs) = lookupDocs name warnings docMap argMap subMap in - return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) + 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 mempty . noLoc . fmap noLoc) mdef + 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 @@ -772,13 +862,17 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap 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)) + -- | 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 -> 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 @@ -800,11 +894,11 @@ extractDecl name mdl decl 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) @@ -814,19 +908,19 @@ 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 @@ -834,7 +928,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = hsib_body $ con_type con - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs -- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] |