diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 236 |
1 files changed, 130 insertions, 106 deletions
diff --git a/src/Main.hs b/src/Main.hs index 7b68fc4e..550884f5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -17,7 +17,7 @@ import Paths_haddock ( getDataDir ) import Prelude hiding ( catch ) import Control.Exception ( catch ) -import Control.Monad ( when, liftM ) +import Control.Monad ( when, liftM, foldM ) import Control.Monad.Writer ( Writer, runWriter, tell ) import Data.Char ( isSpace ) import Data.IORef ( writeIORef ) @@ -58,7 +58,7 @@ import StaticFlags ( parseStaticFlags ) ----------------------------------------------------------------------------- -- Top-level stuff -type CheckedMod = (Module, FullyCheckedMod, FilePath) +type CheckedMod = (Module, FilePath, FullyCheckedMod) main :: IO () main = do @@ -208,16 +208,17 @@ sortAndCheckModules session flags files = defaultErrorHandler flags $ do checkedMod <- case mbMod of Just m -> return m Nothing -> die ("Failed to load module: " ++ moduleString mod) - return (mod, checkedMod, file)) modsAndFiles + return (mod, file, checkedMod)) modsAndFiles ensureFullyChecked checkedMods where ensureFullyChecked modules | length modules' == length modules = return modules' | otherwise = die "Failed to check all modules properly\n" - where modules' = [ (mod, (a,b,c,d), f) | - (mod, CheckedModule a (Just b) (Just c) (Just d), f) + where modules' = [ (mod, f, (a,b,c,d)) | + (mod, f, CheckedModule a (Just b) (Just c) (Just d)) <- modules ] + data Flag = Flag_CSS String | Flag_Debug @@ -389,8 +390,12 @@ run flags modules extEnv = do prologue <- getPrologue flags - let - (modMap, messages) = runWriter (pass1 modules flags) + let + -- collect the data from GHC that we need for each home module + ghcModuleData = map moduleDataGHC modules + -- run pass 1 on this data + (modMap, messages) = runWriter (pass1 ghcModuleData flags) + haddockMods = catMaybes [ Map.lookup mod modMap | (mod,_,_) <- modules ] homeEnv = buildGlobalDocEnv haddockMods env = homeEnv `Map.union` extEnv @@ -453,95 +458,115 @@ type FullyCheckedMod = (ParsedSource, printEntity (DocEntity doc) = show doc printEntity (DeclEntity name) = show $ ppr name defaultUserStyle -pass1 :: [CheckedMod] -> [Flag] -> ErrMsgM ModuleMap -pass1 modules flags = worker modules (Map.empty) flags - where - worker [] moduleMap _ = return moduleMap - worker ((mod, checked_mod, filename):rest_modules) moduleMap flags = do - - let (parsed_source, renamed_source, _, moduleInfo) = checked_mod - (mb_doc_opts, _, _) = getModuleStuff parsed_source - - opts <- mkDocOpts mb_doc_opts - - let (group, _, mb_exports, mbModDoc, haddockModInfo) = renamed_source +-- | This data structure collects all the information we need from the GHC API +-- about a home package module +data ModuleDataGHC = ModuleDataGHC { + ghcModule :: Module, + ghcFilename :: FilePath, + ghcMbDocOpts :: Maybe String, + ghcHaddockModInfo :: HaddockModInfo Name, + ghcMbDoc :: Maybe (HsDoc Name), + ghcGroup :: HsGroup Name, + ghcMbExports :: Maybe [LIE Name], + ghcExportedNames :: [Name], + ghcNamesInScope :: [Name], + ghcInstances :: [Instance] +} - entities = (reverse . nubBy sameName . hs_docs) group - exports = fmap (map unLoc) mb_exports +-- | Dig out what we want from the GHC API without altering anything +moduleDataGHC :: CheckedMod -> ModuleDataGHC +moduleDataGHC (mod, file, checkedMod) = ModuleDataGHC { + ghcModule = mod, + ghcFilename = file, + ghcMbDocOpts = mbOpts, + ghcHaddockModInfo = info, + ghcMbDoc = mbDoc, + ghcGroup = group, + ghcMbExports = mbExports, + ghcExportedNames = modInfoExports modInfo, + ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo, + ghcInstances = modInfoInstances modInfo +} + where + HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed + (group, _, mbExports, mbDoc, info) = renamed + (parsed, renamed, _, modInfo) = checkedMod + +-- | Massage the data in ModuleDataGHC to produce something closer to what +-- we want to render. To do this, we need access to modules before this one +-- in the topological sort, to which we have already done this conversion. +-- That's what's in the ModuleMap. +pass1data :: ModuleDataGHC -> [Flag] -> ModuleMap -> ErrMsgM HaddockModule +pass1data modData flags modMap = do + + let mod = ghcModule modData + + opts <- mkDocOpts (ghcMbDocOpts modData) mod + + let group = ghcGroup modData + entities = (reverse . nubBy sameName . hs_docs) group + exports = fmap (map unLoc) (ghcMbExports modData) + entityNames_ = entityNames entities + subNames = allSubNames group + localNames = entityNames_ ++ subNames + subMap = mkSubMap group + expDeclMap = mkDeclMap (ghcExportedNames modData) group + localDeclMap = mkDeclMap entityNames_ group + docMap = mkDocMap group + ignoreExps = Flag_IgnoreAllExports `elem` flags + + visibleNames <- mkVisibleNames mod modMap localNames (ghcNamesInScope modData) + subMap exports opts localDeclMap + + exportItems <- mkExportItems modMap mod (ghcExportedNames modData) + expDeclMap localDeclMap subMap entities + opts exports ignoreExps docMap + + -- prune the export list to just those declarations that have + -- documentation, if the 'prune' option is on. + let + prunedExportItems + | OptPrune `elem` opts = pruneExportItems exportItems + | otherwise = exportItems - -- lots of names - exportedNames = modInfoExports moduleInfo - theseEntityNames = entityNames entities - subNames = allSubnamesInGroup group - localNames = theseEntityNames ++ subNames - -- guaranteed to be Just, since the module has been compiled from - -- scratch - scopeNames = fromJust $ modInfoTopLevelScope moduleInfo - - subMap = mk_sub_map_from_group group - - exportedDeclMap = mkDeclMap exportedNames group - localDeclMap = mkDeclMap theseEntityNames group - docMap = mkDocMap group + return HM { + hmod_mod = mod, + hmod_orig_filename = ghcFilename modData, + hmod_info = ghcHaddockModInfo modData, + hmod_doc = ghcMbDoc modData, + hmod_rn_doc = Nothing, + hmod_options = opts, + hmod_locals = localNames, + hmod_doc_map = docMap, + hmod_rn_doc_map = Map.empty, + hmod_sub_map = subMap, + hmod_export_items = prunedExportItems, + hmod_rn_export_items = [], + hmod_exports = ghcExportedNames modData, + hmod_visible_exports = visibleNames, + hmod_exported_decl_map = expDeclMap, + hmod_instances = ghcInstances modData + } + where + mkDocOpts mbOpts mod = do + opts <- case mbOpts of + Just opts -> processOptions opts + Nothing -> return [] + let opts' = if Flag_HideModule (moduleString mod) `elem` flags + then OptHide : opts + else opts + return opts' + +-- | Produce a map of HaddockModules with information that is close to +-- renderable. What is lacking after this pass are the renamed export items. +pass1 :: [ModuleDataGHC] -> [Flag] -> ErrMsgM ModuleMap +pass1 modules flags = foldM produceAndInsert Map.empty modules + where + produceAndInsert modMap modData = do + resultMod <- pass1data modData flags modMap + let key = ghcModule modData + return (Map.insert key resultMod modMap) - ignoreAllExports = Flag_IgnoreAllExports `elem` flags - - packageId = modulePackageId mod - - theseVisibleNames <- visibleNames mod moduleMap localNames scopeNames - subMap exports opts localDeclMap - packageId - - exportItems <- mkExportItems moduleMap mod exportedNames - exportedDeclMap localDeclMap subMap entities - opts exports ignoreAllExports docMap - packageId - - -- prune the export list to just those declarations that have - -- documentation, if the 'prune' option is on. - let prunedExportItems - | OptPrune `elem` opts = pruneExportItems exportItems - | otherwise = exportItems - - instances = modInfoInstances moduleInfo - - haddock_module = HM { - hmod_mod = mod, - hmod_orig_filename = filename, - hmod_info = haddockModInfo, - hmod_doc = mbModDoc, - hmod_rn_doc = Nothing, - hmod_options = opts, - hmod_locals = localNames, - hmod_doc_map = docMap, - hmod_rn_doc_map = Map.empty, - hmod_sub_map = subMap, - hmod_export_items = prunedExportItems, - hmod_rn_export_items = [], - hmod_exports = exportedNames, - hmod_visible_exports = theseVisibleNames, - hmod_exported_decl_map = exportedDeclMap, - hmod_instances = instances - } - - moduleMap' = Map.insert mod haddock_module moduleMap - - worker rest_modules moduleMap' flags - - where - getModuleStuff source = - let HsModule _ _ _ _ _ mb_opts info mb_doc = unLoc source - in (mb_opts, info, mb_doc) - - mkDocOpts mbOpts = do - opts <- case mbOpts of - Just opts -> processOptions opts - Nothing -> return [] - let opts' = if Flag_HideModule (moduleString mod) `elem` flags - then OptHide : opts - else opts - return opts' - sameName (DocEntity _) _ = False sameName (DeclEntity _) (DocEntity _) = False sameName (DeclEntity a) (DeclEntity b) = a == b @@ -593,14 +618,13 @@ finishedDoc d DocEmpty rest = rest finishedDoc (DeclEntity name) doc rest = (name, doc) : rest finishedDoc _ _ rest = rest -allSubnamesInGroup :: HsGroup Name -> [Name] -allSubnamesInGroup group = +allSubNames :: HsGroup Name -> [Name] +allSubNames group = concat [ tail (map unLoc (tyClDeclNames tycld)) | L _ tycld <- hs_tyclds group ] -mk_sub_map_from_group :: HsGroup Name -> Map Name [Name] -mk_sub_map_from_group group = - Map.fromList [ (name, subs) | L _ tycld <- hs_tyclds group, - let name:subs = map unLoc (tyClDeclNames tycld) ] +mkSubMap :: HsGroup Name -> Map Name [Name] +mkSubMap group = Map.fromList [ (name, subs) | L _ tycld <- hs_tyclds group, + let name:subs = map unLoc (tyClDeclNames tycld) ] mkDeclMap :: [Name] -> HsGroup Name -> Map Name (LHsDecl Name) mkDeclMap names group = Map.fromList [ (n,d) | (n,Just d) <- maybeDecls ] @@ -757,11 +781,10 @@ mkExportItems -> Maybe [IE Name] -> Bool -- --ignore-all-exports flag -> Map Name (HsDoc Name) - -> PackageId -> ErrMsgM [ExportItem Name] mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_map entities - opts maybe_exps ignore_all_exports docMap packageId + opts maybe_exps ignore_all_exports docMap | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts = everything_local_exported | Just specs <- maybe_exps = do @@ -770,6 +793,8 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m where everything_local_exported = -- everything exported return (fullContentsOfThisModule this_mod entities localDeclMap docMap) + + packageId = modulePackageId this_mod lookupExport (IEVar x) = declWith x lookupExport (IEThingAbs t) = declWith t @@ -899,7 +924,7 @@ pruneExportItems items = filter hasDoc items -- ----------------------------------------------------------------------------- -- Gather a list of original names exported from this module -visibleNames :: Module +mkVisibleNames :: Module -> ModuleMap -> [Name] -> [Name] @@ -907,10 +932,9 @@ visibleNames :: Module -> Maybe [IE Name] -> [DocOption] -> Map Name (LHsDecl Name) - -> PackageId -> ErrMsgM [Name] -visibleNames mdl modMap localNames scope subMap maybeExps opts declMap packageId +mkVisibleNames mdl modMap localNames scope subMap maybeExps opts declMap -- if no export list, just return all local names | Nothing <- maybeExps = return (filter hasDecl localNames) | OptIgnoreExports `elem` opts = return localNames @@ -934,8 +958,8 @@ visibleNames mdl modMap localNames scope subMap maybeExps opts declMap packageId IEThingWith t cs -> return (t : cs) IEModuleContents m - | mkModule packageId m == mdl -> return localNames - | otherwise -> let m' = mkModule packageId m in + | mkModule (modulePackageId mdl) m == mdl -> return localNames + | otherwise -> let m' = mkModule (modulePackageId mdl) m in case Map.lookup m' modMap of Just mod | OptHide `elem` hmod_options mod -> |