diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface/Create.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 867 |
1 files changed, 867 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs new file mode 100644 index 00000000..b66773ae --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -0,0 +1,867 @@ +{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} +{-# OPTIONS_GHC -Wwarn #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.Create +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Interface.Create (createInterface) where + +import Documentation.Haddock.Doc (docAppend) +import Haddock.Types +import Haddock.Options +import Haddock.GhcUtils +import Haddock.Utils +import Haddock.Convert +import Haddock.Interface.LexParseRn + +import qualified Data.Map as M +import Data.Map (Map) +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Ord +import Control.Applicative +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 +import qualified SrcLoc +import GHC +import HscTypes +import Name +import Bag +import RdrName +import TcRnTypes +import FastString (concatFS) + + +-- | 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 tm flags modMap instIfaceMap = do + + let ms = pm_mod_summary . tm_parsed_module $ tm + mi = moduleInfo tm + L _ hsm = parsedSource tm + !safety = modInfoSafe mi + mdl = ms_mod ms + dflags = ms_hspp_opts ms + !instances = modInfoInstances mi + !fam_instances = md_fam_insts md + !exportedNames = modInfoExports mi + + (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, 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) <- + 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) + + opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl + let opts + | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 + | otherwise = opts0 + + (!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 + -- Locations of all TH splices + splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] + + maps@(!docMap, !argMap, !subMap, !declMap, _) = + mkMaps dflags gre localInsts declsWithDocs + + let exports0 = fmap (reverse . map unLoc) mayExports + exports + | OptIgnoreExports `elem` opts = Nothing + | otherwise = exports0 + warningMap = mkWarningMap dflags warnings gre exportedNames + + let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) + + exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls + maps fixMap splices exports instIfaceMap dflags + + let !visibleNames = mkVisibleNames maps exportItems opts + + -- Measure haddock documentation coverage. + let prunedExportItems0 = pruneExportItems exportItems + !haddockable = 1 + length exportItems -- module + exports + !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 + !coverage = (haddockable, haddocked) + + -- Prune the export list to just those declarations that have + -- documentation, if the 'prune' option is on. + let prunedExportItems' + | OptPrune `elem` opts = prunedExportItems0 + | otherwise = exportItems + !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' + + let !aliases = + mkAliasMap dflags $ tm_renamed_source tm + modWarn = moduleWarning dflags gre warnings + + return $! Interface { + ifaceMod = mdl + , ifaceOrigFilename = msHsFilePath ms + , ifaceInfo = info + , ifaceDoc = Documentation mbDoc modWarn + , ifaceRnDoc = Documentation Nothing Nothing + , ifaceOptions = opts + , ifaceDocMap = docMap + , ifaceArgMap = argMap + , ifaceRnDocMap = M.empty + , ifaceRnArgMap = M.empty + , ifaceExportItems = prunedExportItems + , ifaceRnExportItems = [] + , ifaceExports = exportedNames + , ifaceVisibleExports = visibleNames + , ifaceDeclMap = declMap + , ifaceSubMap = subMap + , ifaceFixMap = fixMap + , ifaceModuleAliases = aliases + , ifaceInstances = instances + , ifaceFamInstances = fam_instances + , ifaceHaddockCoverage = coverage + , ifaceWarningMap = warningMap + } + +mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName +mkAliasMap dflags mRenamedSource = + case mRenamedSource of + Nothing -> M.empty + Just (_,impDecls,_,_) -> + M.fromList $ + mapMaybe (\(SrcLoc.L _ impDecl) -> do + alias <- ideclAs impDecl + return $ + (lookupModuleDyn dflags + (fmap Module.fsToPackageId $ + ideclPkgQual impDecl) + (case ideclName impDecl of SrcLoc.L _ name -> name), + alias)) + impDecls + +-- similar to GHC.lookupModule +lookupModuleDyn :: + DynFlags -> Maybe PackageId -> ModuleName -> Module +lookupModuleDyn _ (Just pkgId) mdlName = + Module.mkModule pkgId mdlName +lookupModuleDyn dflags Nothing mdlName = + flip Module.mkModule mdlName $ + case filter snd $ + Packages.lookupModuleInAllPackages dflags mdlName of + (pkgId,_):_ -> Packages.packageConfigId pkgId + [] -> Module.mainPackageId + + +------------------------------------------------------------------------------- +-- Warnings +------------------------------------------------------------------------------- + +mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap +mkWarningMap dflags warnings gre exps = case warnings of + NoWarnings -> M.empty + WarnAll _ -> M.empty + WarnSome ws -> + let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ + , let n = gre_name elt, n `elem` exps ] + in M.fromList $ map (second $ parseWarning dflags gre) ws' + +moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name) +moduleWarning _ _ NoWarnings = Nothing +moduleWarning _ _ (WarnSome _) = Nothing +moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w + +parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name +parseWarning dflags gre w = force $ case w of + DeprecatedTxt msg -> format "Deprecated: " (concatFS msg) + WarningTxt msg -> format "Warning: " (concatFS msg) + where + format x xs = DocWarning . DocParagraph . DocAppend (DocString x) + . processDocString dflags gre $ HsDocString xs + + +------------------------------------------------------------------------------- +-- Doc options +-- +-- Haddock options that are embedded in the source file +------------------------------------------------------------------------------- + + +mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption] +mkDocOpts mbOpts flags mdl = do + opts <- case mbOpts of + Just opts -> case words $ replace ',' ' ' opts of + [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return [] + xs -> liftM catMaybes (mapM parseOption xs) + Nothing -> return [] + 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 + + +parseOption :: String -> ErrMsgM (Maybe DocOption) +parseOption "hide" = return (Just OptHide) +parseOption "prune" = return (Just OptPrune) +parseOption "ignore-exports" = return (Just OptIgnoreExports) +parseOption "not-home" = return (Just OptNotHome) +parseOption "show-extensions" = return (Just OptShowExtensions) +parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing + + +-------------------------------------------------------------------------------- +-- Maps +-------------------------------------------------------------------------------- + + +type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) + +-- | Create 'Maps' by looping through the declarations. For each declaration, +-- find its names, its subordinates, and its doc strings. Process doc strings +-- into 'Doc's. +mkMaps :: DynFlags + -> GlobalRdrEnv + -> [Name] + -> [(LHsDecl Name, [HsDocString])] + -> Maps +mkMaps dflags gre instances decls = + let (a, b, c, d) = unzip4 $ map mappings decls + in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap) + where + f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b + f = M.fromListWith (<>) . concat + + f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name) + f' = M.fromListWith docAppend . concat + + mappings :: (LHsDecl Name, [HsDocString]) + -> ( [(Name, Doc Name)] + , [(Name, Map Int (Doc Name))] + , [(Name, [Name])] + , [(Name, [LHsDecl Name])] + ) + mappings (ldecl, docStrs) = + let L l decl = ldecl + declDoc :: [HsDocString] -> Map Int HsDocString + -> (Maybe (Doc Name), Map Int (Doc Name)) + declDoc strs m = + let doc' = processDocStrings dflags gre strs + m' = M.map (processDocStringParas dflags gre) m + in (doc', m') + (doc, args) = declDoc docStrs (typeDocs decl) + subs :: [(Name, [HsDocString], Map Int HsDocString)] + subs = subordinates instanceMap decl + (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs + ns = names l decl + 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 ] + in seqList ns `seq` + seqList subNs `seq` + doc `seq` + seqList subDocs `seq` + seqList subArgs `seq` + (dm, am, sm, cm) + + instanceMap :: Map SrcSpan Name + instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] + + names :: SrcSpan -> HsDecl Name -> [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 + _ -> getInstLoc d + 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). + + +-------------------------------------------------------------------------------- +-- Declarations +-------------------------------------------------------------------------------- + + +-- | Get all subordinate declarations inside a declaration, and their docs. +subordinates :: InstMap -> HsDecl Name -> [(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 + + InstD (DataFamInstD d) -> dataSubs (dfid_defn d) + TyClD d | isClassDecl d -> classSubs d + | isDataDecl d -> dataSubs (tcdDataDefn d) + _ -> [] + where + classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd + , name <- getMainDeclBinder d, not (isValD d) + ] + dataSubs dd = constrs ++ fields + where + cons = map unL $ (dd_cons dd) + constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) + | c <- cons ] + fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) + | RecCon flds <- map con_details cons + , ConDeclField n _ doc <- flds ] + +-- | Extract function argument docs from inside types. +typeDocs :: HsDecl Name -> Map Int HsDocString +typeDocs d = + let docs = go 0 in + case d of + SigD (TypeSig _ ty) -> docs (unLoc ty) + SigD (PatSynSig _ arg_tys ty req prov) -> + let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ] + in F.foldMap (docs . unLoc) allTys + ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) + TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) + _ -> M.empty + where + go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) + go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty + go n (HsFunTy _ ty) = go (n+1) (unLoc ty) + go n (HsDocTy _ (L _ doc)) = M.singleton n doc + go _ _ = M.empty + + +-- | 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 class_ = filterDecls . collectDocs . sortByLoc $ decls + where + decls = docs ++ defs ++ sigs ++ ats + docs = mkDecls tcdDocs DocD class_ +#if MIN_VERSION_ghc(7,8,3) + defs = mkDecls (bagToList . tcdMeths) ValD class_ +#else + defs = mkDecls (map snd . bagToList . tcdMeths) ValD class_ +#endif + sigs = mkDecls tcdSigs SigD class_ + ats = mkDecls tcdATs (TyClD . FamDecl) class_ + + +-- | 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 = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup + +-- | Extract a map of fixity declarations only +mkFixMap :: HsGroup Name -> FixMap +mkFixMap group_ = M.fromList [ (n,f) + | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ] + + +-- | 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 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 (typesigs . hs_valds) SigD group_ ++ +#if MIN_VERSION_ghc(7,8,3) + mkDecls (valbinds . hs_valds) ValD group_ +#else + mkDecls (map snd . valbinds . hs_valds) ValD group_ +#endif + where + typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs + typesigs _ = error "expected ValBindsOut" + + valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds + valbinds _ = error "expected ValBindsOut" + + +-- | Take a field of declarations from a data structure and create HsDecls +-- using the given constructor +mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] +mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ] + + +-- | Sort by source location +sortByLoc :: [Located a] -> [Located a] +sortByLoc = sortBy (comparing getLoc) + + +-------------------------------------------------------------------------------- +-- Filtering of declarations +-- +-- We filter out declarations that we don't intend to handle later. +-------------------------------------------------------------------------------- + + +-- | Filter out declarations that we don't handle in Haddock +filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterDecls = filter (isHandled . unL . fst) + where + isHandled (ForD (ForeignImport {})) = True + isHandled (TyClD {}) = True + isHandled (InstD {}) = True + isHandled (SigD d) = isVanillaLSig (reL d) + isHandled (ValD _) = True + -- we keep doc declarations to be able to get at named docs + isHandled (DocD _) = True + isHandled _ = False + + +-- | Go through all class declarations and filter their sub-declarations +filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x + | x@(L loc d, doc) <- decls ] + where + filterClass (TyClD c) = + TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c } + filterClass _ = error "expected TyClD" + + +-------------------------------------------------------------------------------- +-- Collect docs +-- +-- To be able to attach the right Haddock comment to the right declaration, +-- we sort the declarations by their SrcLoc and "collect" the docs for each +-- declaration. +-------------------------------------------------------------------------------- + + +-- | Collect docs and attach them to the right declarations. +collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])] +collectDocs = go Nothing [] + where + go Nothing _ [] = [] + go (Just prev) docs [] = finished prev docs [] + go prev docs (L _ (DocD (DocCommentNext str)) : ds) + | Nothing <- prev = go Nothing (str:docs) ds + | Just decl <- prev = finished decl docs (go Nothing [str] ds) + go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds + go Nothing docs (d:ds) = go (Just d) docs ds + go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) + + finished decl docs rest = (decl, reverse docs) : rest + + +-- | Build the list of items that will become the documentation, from the +-- export list. At this point, the list of ExportItems is in terms of +-- original names. +-- +-- 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 + -> Module -- this module + -> WarningMap + -> GlobalRdrEnv + -> [Name] -- exported names (orig) + -> [LHsDecl Name] + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> Maybe [IE Name] + -> InstIfaceMap + -> DynFlags + -> ErrMsgGhc [ExportItem Name] +mkExportItems + modMap thisMod 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 x) = declWith x + lookupExport (IEThingAbs t) = declWith t + lookupExport (IEThingAll t) = declWith t + lookupExport (IEThingWith t _) = declWith t + lookupExport (IEModuleContents m) = + 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 + + lookupExport (IEDoc docStr) = return $ + return . ExportDoc $ processDocStringParas dflags gre docStr + + lookupExport (IEDocNamed str) = liftErrMsg $ + findNamedDoc str [ unL d | d <- decls ] >>= return . \case + Nothing -> [] + Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc + + declWith :: Name -> ErrMsgGhc [ ExportItem Name ] + declWith t = + case findDecl t of + ([L l (ValD _)], (doc, _)) -> do + -- Top-level binding without type signature + export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap + return [export] + (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> + let declNames = getMainDeclBinder (unL decl) + in case () of + _ + -- temp hack: we filter out separately exported ATs, since we haven't decided how + -- to handle them yet. We should really give an warning message also, and filter the + -- name out in mkVisibleNames... + | t `elem` declATs (unL decl) -> return [] + + -- We should not show a subordinate by itself if any of its + -- parents is also exported. See note [1]. + | t `notElem` declNames, + Just p <- find isExported (parents t $ unL decl) -> + do liftErrMsg $ tell [ + "Warning: " ++ moduleString thisMod ++ ": " ++ + pretty dflags (nameOccName t) ++ " is exported separately but " ++ + "will be documented under " ++ pretty dflags (nameOccName p) ++ + ". Consider exporting it together with its parent(s)" ++ + " for code clarity." ] + return [] + + -- normal case + | otherwise -> case decl of + -- A single signature might refer to many names, but we + -- create an export item for a single name only. So we + -- modify the signature to contain only that single name. + L loc (SigD sig) -> + -- 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 docs_ ] + + L loc (TyClD cl@ClassDecl{}) -> do + mdef <- liftGhcToErrMsgGhc $ minimalDef t + let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef + return [ mkExportDecl t + (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] + + _ -> return [ mkExportDecl t decl docs_ ] + + -- Declaration from another package + ([], _) -> do + mayDecl <- hiDecl dflags t + case mayDecl of + Nothing -> return [ ExportNoDecl t [] ] + Just decl -> + -- We try to get the subs and docs + -- from the installed .haddock file for that package. + case M.lookup (nameModule t) instIfaceMap of + Nothing -> do + 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 (noDocForDecl, subs_) ] + Just iface -> + return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + + _ -> return [] + + + 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 + subs' = filter (isExported . fst) subs + sub_names = map fst subs' + fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ] + + + isExported = (`elem` exportedNames) + + + findDecl :: Name -> ([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, [])) + where + m = nameModule n + + +hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) +hiDecl dflags t = do + mayTyThing <- liftGhcToErrMsgGhc $ lookupName t + case mayTyThing of + Nothing -> do + liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] + return Nothing + Just x -> return (Just (tyThingToLHsDecl x)) + + +hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) +hiValExportItem dflags name doc splice fixity = do + mayDecl <- hiDecl dflags name + case mayDecl of + Nothing -> return (ExportNoDecl name []) + Just decl -> return (ExportDecl decl doc [] [] fixities splice) + where + fixities = case fixity of + Just f -> [(name, f)] + Nothing -> [] + + +-- | Lookup docs for a declaration from maps. +lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs n warnings docMap argMap subMap = + 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 + (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 + -> 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 + -> 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 + | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls + | otherwise = + case M.lookup m ifaceMap of + Just iface + | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) + | otherwise -> return [ ExportModule m ] + + Nothing -> -- We have to try to find it in the installed interfaces + -- (external packages). + case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of + Just iface -> return [ ExportModule (instMod iface) ] + Nothing -> do + liftErrMsg $ + tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty dflags expMod] + return [] + where + m = mkModule packageId expMod + packageId = modulePackageId thisMod + + +-- Note [1]: +------------ +-- It is unnecessary to document a subordinate by itself at the top level if +-- any of its parents is also documented. Furthermore, if the subordinate is a +-- record field or a class method, documenting it under its parent +-- indicates its special status. +-- +-- A user might expect that it should show up separately, so we issue a +-- warning. It's a fine opportunity to also tell the user she might want to +-- export the subordinate through the parent export item for clarity. +-- +-- The code removes top-level subordinates also when the parent is exported +-- through a 'module' export. I think that is fine. +-- +-- (For more information, see Trac #69) + + +fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan] + -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] +fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = + liftM catMaybes $ mapM mkExportItem (expandSig 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! + expandSig :: [LHsDecl name] -> [LHsDecl name] + expandSig = foldr f [] + where + f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] + f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names + f x xs = x : xs + + mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) + mkExportItem (L _ (DocD (DocGroup lev docStr))) = do + return . Just . ExportGroup lev "" $ processDocString dflags gre docStr + mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do + return . Just . ExportDoc $ processDocStringParas dflags gre docStr + 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 doc (l `elem` splices) $ M.lookup name fixMap) + | 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)) + mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do + mdef <- liftGhcToErrMsgGhc $ minimalDef name + let sig = maybeToList $ fmap (noLoc . MinimalSig . 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 + + +-- | 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 + | name `elem` getMainDeclBinder (unLoc decl) = decl + | otherwise = + case unLoc decl of + TyClD d@ClassDecl {} -> + let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, + isVanillaLSig sig ] -- TODO: document fixity + in case matches of + [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d) + L pos sig = extractClassDecl n tyvar_names s0 + in L pos (SigD sig) + _ -> error "internal: extractDecl (ClassDecl)" + TyClD d@DataDecl {} -> + let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d) + in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) + InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n + , dfid_pats = HsWB { hswb_cts = tys } + , dfid_defn = defn }) -> + SigD <$> extractRecSel name mdl 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) + , ConDeclField { cd_fld_name = L _ n } <- rec + , n == name + ] + in case matches of + [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) + _ -> error "internal: extractDecl (ClsInstD)" + _ -> error "internal: extractDecl" + where + getTyVars = hsLTyVarLocNames . tyClDeclTyVars + + +toTypeNoLoc :: Located Name -> LHsType Name +toTypeNoLoc = noLoc . HsTyVar . unLoc + + +extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name +extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of + L _ (HsForAllTy expl tvs (L _ preds) ty) -> + L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty))) + _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype))) + where + lctxt = noLoc . ctxt + ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds +extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" + + +extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] + -> LSig Name +extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" + +extractRecSel nm mdl t tvs (L _ con : rest) = + case con_details con of + RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields -> + L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty)))) + _ -> extractRecSel nm mdl t tvs rest + where + matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] + data_ty + | ResTyGADT ty <- con_res con = ty + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs + + +-- | Keep export items with docs. +pruneExportItems :: [ExportItem Name] -> [ExportItem Name] +pruneExportItems = filter hasDoc + where + hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d + hasDoc _ = True + + +mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name] +mkVisibleNames (_, _, _, _, instMap) exports opts + | OptHide `elem` opts = [] + | otherwise = let ns = concatMap exportName exports + in seqList ns `seq` ns + where + exportName e@ExportDecl {} = name ++ subs + where subs = map fst (expItemSubDocs e) + name = case unLoc $ expItemDecl e of + InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap + decl -> getMainDeclBinder decl + exportName ExportNoDecl {} = [] -- we don't count these as visible, since + -- we don't want links to go to them. + exportName _ = [] + +seqList :: [a] -> () +seqList [] = () +seqList (x : xs) = x `seq` seqList xs + +-- | Find a stand-alone documentation comment by its name. +findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) +findNamedDoc name = search + where + search [] = do + tell ["Cannot find documentation for: $" ++ name] + return Nothing + search (DocD (DocCommentNamed name' doc) : rest) + | name == name' = return (Just doc) + | otherwise = search rest + search (_other_decl : rest) = search rest |