diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 288 |
1 files changed, 101 insertions, 187 deletions
diff --git a/src/Main.hs b/src/Main.hs index 7223b8f6..e7b52e4d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -19,6 +19,7 @@ import Haddock.Version import Haddock.InterfaceFile import Haddock.Exception import Haddock.Options +import Haddock.Typecheck import Haddock.Utils.GHC import Paths_haddock @@ -55,7 +56,6 @@ import Distribution.Simple.Utils import GHC import Outputable import SrcLoc -import Digraph import Name import Module import InstEnv @@ -68,7 +68,6 @@ import Bag import HscTypes import Util (handleDyn) import ErrUtils (printBagOfErrors) -import BasicTypes import UniqFM import FastString @@ -129,9 +128,9 @@ handleGhcExceptions inner = ) inner --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- Top-level --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- main :: IO () @@ -165,7 +164,7 @@ main = handleTopExceptions $ do packages <- getPackages session exposedPackages -- typechecking - modules <- sortAndCheckModules session fileArgs + modules <- typecheckFiles session fileArgs -- update the html references for rendering phase (global variable) updateHTMLXRefs packages @@ -177,84 +176,6 @@ main = handleTopExceptions $ do run flags modules env -handleFlags flags fileArgs = do - usage <- getUsage - - when (Flag_Help `elem` flags) (bye usage) - when (Flag_Version `elem` flags) byeVersion - when (null fileArgs) (bye usage) - - let ghcLibDir = case [ dir | Flag_GhcLibDir dir <- flags ] of - [] -> throwE "no GHC lib dir specified" - xs -> last xs - - when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) - && Flag_Html `elem` flags) $ - throwE ("-h cannot be used with --gen-index or --gen-contents") - - return ghcLibDir - - --- | Handle the -use-package flags --- --- Returns the names of the packages (without version number), if parsing --- succeeded. --- --- It would be better to try to get the "exposed" packages from GHC instead. --- This would make the -use-package flag unnecessary. But currently it --- seems all you can get from the GHC api is all packages that are linked in --- (i.e the closure of the exposed packages). -getUsePackages :: [Flag] -> Session -> IO [String] -getUsePackages flags session = do - - -- get the packages from the commandline flags - let packages = [ pkg | Flag_UsePackage pkg <- flags ] - - -- expose these packages - -- (makes "-use-package pkg" equal to "-g '-package pkg'") - - dfs <- getSessionDynFlags session - let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage packages } - setSessionDynFlags session dfs' - - -- try to parse these packages into PackageIndentifiers - - mapM (handleParse . unpackPackageId . stringToPackageId) packages - where - handleParse (Just pkg) = return (pkgName pkg) - handleParse Nothing = throwE "Could not parse package identifier" - - -------------------------------------------------------------------------------- --- Flags -------------------------------------------------------------------------------- - - --- | Filter out the GHC specific flags and try to parse and set them as static --- flags. Return a list of flags that couldn't be parsed. -tryParseStaticFlags flags = do - let ghcFlags = [ str | Flag_GhcFlag str <- flags ] - parseStaticFlags ghcFlags - - --- | Try to parse dynamic GHC flags -parseGhcFlags session ghcFlags = do - dflags <- getSessionDynFlags session - foldlM parseFlag dflags (map words ghcFlags) - where - -- try to parse a flag as either a dynamic or static GHC flag - parseFlag dynflags ghcFlag = do - (dynflags', rest) <- parseDynamicFlags dynflags ghcFlag - when (rest == ghcFlag) $ - throwE ("Couldn't parse GHC flag: " ++ (unwords ghcFlag)) - return dynflags' - - -byeVersion = - bye ("Haddock version " ++ projectVersion ++ - ", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n") - - startGHC :: String -> IO (Session, DynFlags) startGHC libDir = do session <- newSession (Just libDir) @@ -268,57 +189,8 @@ startGHC libDir = do setSessionDynFlags session flags'' return (session, flags'') - --- | Get the sorted graph of all loaded modules and their dependencies -getSortedModuleGraph :: Session -> IO [(Module, FilePath)] -getSortedModuleGraph session = do - mbModGraph <- depanal session [] True - moduleGraph <- case mbModGraph of - Just mg -> return mg - Nothing -> throwE "Failed to load all modules" - let - getModFile = fromJust . ml_hs_file . ms_location - sortedGraph = topSortModuleGraph False moduleGraph Nothing - sortedModules = concatMap flattenSCC sortedGraph - modsAndFiles = [ (ms_mod modsum, getModFile modsum) | - modsum <- sortedModules ] - return modsAndFiles - - --- TODO: make it handle cleanup -sortAndCheckModules :: Session -> [FilePath] -> IO [CheckedMod] -sortAndCheckModules session files = do - - -- load all argument files - - targets <- mapM (\f -> guessTarget f Nothing) files - setTargets session targets - - -- compute the dependencies and load them as well - - allMods <- getSortedModuleGraph session - targets' <- mapM (\(_, f) -> guessTarget f Nothing) allMods - setTargets session targets' - - flag <- load session LoadAllTargets - when (failed flag) $ - throwE "Failed to load all needed modules" - - -- typecheck the argument modules - - let argMods = filter ((`elem` files) . snd) allMods - - checkedMods <- forM argMods $ \(mod, file) -> do - mbMod <- checkModule session (moduleName mod) False - case mbMod of - Just (CheckedModule a (Just b) (Just c) (Just d) _) - -> return (mod, file, (a,b,c,d)) - _ -> throwE ("Failed to check module: " ++ moduleString mod) - - return checkedMods - - -run :: [Flag] -> [CheckedMod] -> Map Name Name -> IO () + +run :: [Flag] -> [GhcModule] -> Map Name Name -> IO () run flags modules extEnv = do let title = case [str | Flag_Heading str <- flags] of @@ -366,12 +238,10 @@ run flags modules extEnv = do prologue <- getPrologue 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) + (modMap, messages) = runWriter (pass1 modules flags) - haddockMods = catMaybes [ Map.lookup mod modMap | (mod,_,_) <- modules ] + haddockMods = catMaybes [ Map.lookup (ghcModule m) modMap | m <- modules ] homeEnv = buildGlobalDocEnv haddockMods env = homeEnv `Map.union` extEnv haddockMods' = attachInstances haddockMods @@ -418,55 +288,105 @@ run flags modules extEnv = do writeInterfaceFile filename iface -type CheckedMod = (Module, FilePath, FullyCheckedMod) +------------------------------------------------------------------------------- +-- Flags +------------------------------------------------------------------------------- + -type FullyCheckedMod = (ParsedSource, - RenamedSource, - TypecheckedSource, - ModuleInfo) +handleFlags flags fileArgs = do + usage <- getUsage + when (Flag_Help `elem` flags) (bye usage) + when (Flag_Version `elem` flags) byeVersion + when (null fileArgs) (bye usage) --- | This data structure collects all the information we need 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] -} + let ghcLibDir = case [ dir | Flag_GhcLibDir dir <- flags ] of + [] -> throwE "no GHC lib dir specified" + xs -> last xs + when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) + && Flag_Html `elem` flags) $ + throwE ("-h cannot be used with --gen-index or --gen-contents") --- | 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 -} + return ghcLibDir + + +-- | Handle the -use-package flags +-- +-- Returns the names of the packages (without version number), if parsing +-- succeeded. +-- +-- It would be better to try to get the "exposed" packages from GHC instead. +-- This would make the -use-package flag unnecessary. But currently it +-- seems all you can get from the GHC api is all packages that are linked in +-- (i.e the closure of the exposed packages). +getUsePackages :: [Flag] -> Session -> IO [String] +getUsePackages flags session = do + + -- get the packages from the commandline flags + let packages = [ pkg | Flag_UsePackage pkg <- flags ] + + -- expose these packages + -- (makes "-use-package pkg" equal to "-g '-package pkg'") + + dfs <- getSessionDynFlags session + let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage packages } + setSessionDynFlags session dfs' + + -- try to parse these packages into PackageIndentifiers + + mapM (handleParse . unpackPackageId . stringToPackageId) packages where - HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed - (group, _, mbExports, mbDoc, info) = renamed - (parsed, renamed, _, modInfo) = checkedMod + handleParse (Just pkg) = return (pkgName pkg) + handleParse Nothing = throwE "Could not parse package identifier" --- | Massage the data in ModuleDataGHC to produce something closer to what +-- | Filter out the GHC specific flags and try to parse and set them as static +-- flags. Return a list of flags that couldn't be parsed. +tryParseStaticFlags flags = do + let ghcFlags = [ str | Flag_GhcFlag str <- flags ] + parseStaticFlags ghcFlags + + +-- | Try to parse dynamic GHC flags +parseGhcFlags session ghcFlags = do + dflags <- getSessionDynFlags session + foldlM parseFlag dflags (map words ghcFlags) + where + -- try to parse a flag as either a dynamic or static GHC flag + parseFlag dynflags ghcFlag = do + (dynflags', rest) <- parseDynamicFlags dynflags ghcFlag + when (rest == ghcFlag) $ + throwE ("Couldn't parse GHC flag: " ++ (unwords ghcFlag)) + return dynflags' + + +byeVersion = + bye ("Haddock version " ++ projectVersion ++ + ", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n") + + +------------------------------------------------------------------------------- +-- Phase 1 +------------------------------------------------------------------------------- + + +-- | Produce a map of HaddockModules with information that is close to +-- renderable. What is lacking after this pass are the renamed export items. +pass1 :: [GhcModule] -> [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) + + +-- | Massage the data in GhcModule 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 :: GhcModule -> [Flag] -> ModuleMap -> ErrMsgM HaddockModule pass1data modData flags modMap = do let mod = ghcModule modData @@ -528,17 +448,6 @@ pass1data modData flags modMap = do 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) - - sameName (DocEntity _) _ = False sameName (DeclEntity _) (DocEntity _) = False sameName (DeclEntity a) (DeclEntity b) = a == b @@ -610,6 +519,11 @@ collectEntities group = sortByLoc (docs ++ declarations) forName (ForeignExport name _ _) = unLoc name +-------------------------------------------------------------------------------- +-- Collect docs +-------------------------------------------------------------------------------- + + -- | Collect the docs and attach them to the right name collectDocs :: [Entity] -> [(Name, HsDoc Name)] collectDocs entities = collect Nothing DocEmpty entities |