diff options
| -rw-r--r-- | src/Main.hs | 183 |
1 files changed, 89 insertions, 94 deletions
diff --git a/src/Main.hs b/src/Main.hs index 1043482a..c0e9745f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -60,13 +60,21 @@ import Packages ----------------------------------------------------------------------------- -- Top-level stuff +type CheckedMods = [(Module, FullyCheckedMod, FilePath)] + main :: IO () main = do args <- getArgs - (libDir, rest) <- getLibDir args - (session, nonGHCOpts) <- startGHC libDir rest - (flags, args) <- parseHaddockOpts nonGHCOpts - run flags args session + (libDir, rest) <- getLibDir args + (session, ghcFlags, nonGHCOpts) <- startGHC libDir rest + (flags, args) <- parseHaddockOpts nonGHCOpts + handleEagerFlags flags + modules <- sortAndCheckModules session ghcFlags args + (ifaces, htmls) <- getIfacesAndHtmls flags ghcFlags + let (modss, envs) = unzip ifaces + updateHTMLXRefs htmls modss + -- TODO: continue to break up the run function into parts + run flags modules envs parseHaddockOpts :: [String] -> IO ([Flag], [String]) parseHaddockOpts words = @@ -76,15 +84,18 @@ parseHaddockOpts words = prog <- getProgramName die (concat errors ++ usageInfo (usageHeader prog) (options False)) +usageHeader :: String -> String +usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n" + getLibDir :: [String] -> IO (String, [String]) getLibDir ("-B":dir:rest) = return (dir, rest) getLibDir (('-':'B':dir):rest) | not (null dir) = return (dir, rest) getLibDir _ = die "Missing GHC lib dir option: -B <dir>\n" --- | Initialize GHC, then parse the passed in strings and set the corresponding +-- | Initialize GHC, parse the passed in strings and set the corresponding -- GHC flags (if any). Also add the -haddock flag. Return the Session handle -- and the strings that were not GHC flags. -startGHC :: String -> [String] -> IO (Session, [String]) +startGHC :: String -> [String] -> IO (Session, DynFlags, [String]) startGHC libDir possibleOpts = do GHC.init (Just libDir) let ghcMode = JustTypecheck @@ -94,10 +105,48 @@ startGHC libDir possibleOpts = do (flags'', nonOpts) <- parseDynamicFlags flags' possibleOpts let flags''' = dopt_set flags'' Opt_Haddock setSessionDynFlags session flags''' - return (session, nonOpts) - -usageHeader :: String -> String -usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n" + return (session, flags''', nonOpts) + +sortAndCheckModules :: Session -> DynFlags -> [FilePath] -> + IO [(Module, FullyCheckedMod, FilePath)] +sortAndCheckModules session flags files = defaultErrorHandler flags $ do + targets <- mapM (\s -> guessTarget s Nothing) files + setTargets session targets + mbModGraph <- depanal session [] True + moduleGraph <- case mbModGraph of + Just mg -> return mg + Nothing -> die "Failed to load all modules\n" + let + modSumFile = fromJust . ml_hs_file . ms_location + sortedGraph = topSortModuleGraph False moduleGraph Nothing + sortedModules = concatMap Digraph.flattenSCC sortedGraph + modsAndFiles = [ (ms_mod modsum, modSumFile modsum) | + modsum <- sortedModules, + modSumFile modsum `elem` files ] + checkedMods <- mapM (\(mod, file) -> do + mbMod <- checkModule session mod + checkedMod <- case mbMod of + Just m -> return m + Nothing -> die ("Failed to load module: " ++ moduleString mod) + return (mod, checkedMod, file)) modsAndFiles + ensureFullyChecked checkedMods + where + ensureFullyChecked modules + | length modules' == length modules = return modules' + | otherwise = die "Fail to check all modules properly\n" + where modules' = [ (mod, (a,b,c,d), f) | + (mod, CheckedModule a (Just b) (Just c) (Just d), f) + <- modules ] + +getIfacesAndHtmls :: [Flag] -> DynFlags -> IO ([Interface], [FilePath]) +getIfacesAndHtmls flags dynflags = do + packageFiles <- getPackageFiles dynflags + let + readIfaceFlags = [ parseIfaceOption str | Flag_ReadInterface str <- flags ] + totalFiles = packageFiles ++ readIfaceFlags + (htmlPaths, ifacePaths) = unzip totalFiles + ifaces <- mapM readIface ifacePaths + return (ifaces, htmlPaths) data Flag = Flag_CSS String @@ -198,19 +247,23 @@ options backwardsCompat = "the modules being processed depend on PACKAGE" ] -run :: [Flag] -> [FilePath] -> Session -> IO () -run flags files session = do - +handleEagerFlags flags = do whenFlag Flag_Help $ do prog <- getProgramName bye (usageInfo (usageHeader prog) (options False)) - whenFlag Flag_Version $ bye ("Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2003; port to GHC-api by David Waern 2006\n") + when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) + && Flag_Html `elem` flags) $ + die ("-h cannot be used with --gen-index or --gen-contents") + where + whenFlag flag action = when (flag `elem` flags) action - let +run :: [Flag] -> CheckedMods -> [Map Name Name] -> IO () +run flags modules extEnvs = do + let title = case [str | Flag_Heading str <- flags] of [] -> "" (t:_) -> t @@ -245,8 +298,6 @@ run flags files session = do [] -> Nothing fs -> Just (last fs) - readIfaceFlags = [ parseIfaceOption str | Flag_ReadInterface str <- flags ] - maybe_contents_url = case [url | Flag_UseContents url <- flags] of [] -> Nothing @@ -264,88 +315,36 @@ run flags files session = do prologue <- getPrologue flags - when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) - && Flag_Html `elem` flags) $ - die ("-h cannot be used with --gen-index or --gen-contents") - - ghcFlags <- getSessionDynFlags session - - sorted_checked_modules <- defaultErrorHandler ghcFlags $ do - targets <- mapM (\s -> guessTarget s Nothing) files - setTargets session targets - maybe_module_graph <- depanal session [] True - module_graph <- case maybe_module_graph of - Just module_graph -> return module_graph - Nothing -> die "Failed to load modules 1\n" - - let - modSumFile = fromJust . ml_hs_file . ms_location - sorted_modules = concatMap Digraph.flattenSCC (topSortModuleGraph False module_graph Nothing) - (modules, filenames) = unzip [ (ms_mod modsum, modSumFile modsum) | modsum <- sorted_modules, - modSumFile modsum `elem` files ] - - --print_ modules - mb_checked_modules <- mapM (checkModule session) modules - let checked_modules = catMaybes mb_checked_modules - if length checked_modules /= length mb_checked_modules - then die "Failed to load all modules 2\n" - else return (zip3 modules checked_modules filenames) - - sorted_checked_modules' <- remove_maybes sorted_checked_modules - - let (modMap, messages) = runWriter (pass1 sorted_checked_modules' flags package) - - haddockModules = catMaybes [ Map.lookup mod modMap | - (mod, _, file) <- sorted_checked_modules', - file `elem` files ] - - packageFiles <- getPackageFiles ghcFlags - --print packageFiles let - totalFiles = packageFiles ++ readIfaceFlags - (htmlPaths, ifacePaths) = unzip totalFiles - ifaces <- mapM readIface ifacePaths - - let - (moduless, extEnvs) = unzip ifaces - homeEnv = buildGlobalDocEnv haddockModules + (modMap, messages) = runWriter (pass1 modules flags package) + haddockMods = catMaybes [ Map.lookup mod modMap | (mod,_,_) <- modules ] + homeEnv = buildGlobalDocEnv haddockMods env = Map.unions (homeEnv:extEnvs) - haddockModules' = attachInstances haddockModules - (haddockModules'', messages') = runWriter $ mapM (renameModule env) haddockModules' + haddockMods' = attachInstances haddockMods + (haddockMods'', messages') = runWriter $ mapM (renameModule env) haddockMods' - updateHTMLXRefs htmlPaths moduless - --- putStrLn "pass 1 messages:" mapM_ putStrLn messages -{- putStrLn "pass 1 export items:" - printSDoc (ppr (map hmod_export_items haddockModules')) defaultUserStyle - - putStrLn "pass 2 env:" - printSDoc (ppr (Map.toList env)) defaultUserStyle - - putStrLn "pass 2 export items:" - printSDoc (ppr (map hmod_rn_export_items haddockModules'')) defaultUserStyle -} mapM_ putStrLn messages' - let visibleModules = [ m | m <- haddockModules'', OptHide `notElem` (hmod_options m) ] + let visibleMods = [ m | m <- haddockMods'', OptHide `notElem` (hmod_options m) ] when (Flag_GenIndex `elem` flags) $ do ppHtmlIndex odir title package maybe_html_help_format maybe_contents_url maybe_source_urls maybe_wiki_urls - visibleModules + visibleMods copyHtmlBits odir libdir css_file when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do - ppHtmlHelpFiles title package visibleModules odir maybe_html_help_format [] + ppHtmlHelpFiles title package visibleMods odir maybe_html_help_format [] when (Flag_GenContents `elem` flags) $ do ppHtmlContents odir title package maybe_html_help_format maybe_index_url maybe_source_urls maybe_wiki_urls - visibleModules prologue + visibleMods prologue copyHtmlBits odir libdir css_file when (Flag_Html `elem` flags) $ do - ppHtml title package visibleModules odir + ppHtml title package visibleMods odir prologue maybe_html_help_format maybe_source_urls maybe_wiki_urls maybe_contents_url maybe_index_url @@ -356,18 +355,12 @@ run flags files session = do -- dump an interface if requested case dumpIface of Nothing -> return () - Just fn -> dumpInterfaces env (map hmod_mod visibleModules) fn + Just fn -> dumpInterfaces env (map hmod_mod visibleMods) fn where - whenFlag flag action = when (flag `elem` flags) action - pprList [] = [] pprList [x] = show x pprList (x:xs) = show x ++ ", " ++ pprList xs - remove_maybes modules | length modules' == length modules = return modules' - | otherwise = die "Missing checked module phase information\n" - where modules' = [ (mod, (a,b,c,d), f) | (mod, CheckedModule a (Just b) (Just c) (Just d), f) <- modules ] - print_ x = printSDoc (ppr x) defaultUserStyle instance Outputable (DocEntity Name) where @@ -382,18 +375,18 @@ instance Show a => Show (DocDecl a) where show (DocCommentPrev doc) = "prev" ++ show doc show _ = "other" -type FullyCheckedModule = (ParsedSource, - RenamedSource, - TypecheckedSource, - ModuleInfo) +type FullyCheckedMod = (ParsedSource, + RenamedSource, + TypecheckedSource, + ModuleInfo) printEntity (DocEntity doc) = show doc printEntity (DeclEntity name) = show $ ppr name defaultUserStyle -pass1 :: [(Module, FullyCheckedModule, FilePath)] -> [Flag] -> Maybe String -> ErrMsgM ModuleMap2 +pass1 :: [(Module, FullyCheckedMod, FilePath)] -> [Flag] -> Maybe String -> ErrMsgM ModuleMap2 pass1 modules flags package = worker modules (Map.empty) flags where - worker :: [(Module, FullyCheckedModule, FilePath)] -> ModuleMap2 -> [Flag] -> ErrMsgM ModuleMap2 + worker :: [(Module, FullyCheckedMod, FilePath)] -> ModuleMap2 -> [Flag] -> ErrMsgM ModuleMap2 worker [] moduleMap _ = return moduleMap worker ((mod, checked_mod, filename):rest_modules) moduleMap flags = do @@ -1075,7 +1068,7 @@ getPackageFiles dynflags = do ifaceExists <- doesFileExist iface when (not ifaceExists) $ - throwIO (ErrorCall ("Interace " ++ iface ++ " does not exist.")) + throwIO (ErrorCall ("Interface " ++ iface ++ " does not exist.")) return (html, iface) where @@ -1117,7 +1110,9 @@ mkName mdl occ = mkExternalName (mkUnique 'X' 0) mdl occ Nothing noSrcLoc --type StoredInterface2 = -- (Module,Maybe Doc,Maybe String,Bool,[(HsName,Module)], [(HsName,[HsName])]) -readIface :: FilePath -> IO ([Module], Map Name Name) +type Interface = ([Module], Map Name Name) + +readIface :: FilePath -> IO Interface readIface fileName = do bh <- readBinMem fileName formatVersion <- get bh |