From 68478d9e11b545fc6b5f6771a35f9088837ed1ce Mon Sep 17 00:00:00 2001 From: davve Date: Fri, 15 Sep 2006 18:03:00 +0000 Subject: Remove interface reading/writing code and use the GHC api for creating package environments instead --- haddock.cabal | 2 +- src/Main.hs | 164 +++++++++++++++++++++++++++++++++++----------------------- 2 files changed, 101 insertions(+), 65 deletions(-) diff --git a/haddock.cabal b/haddock.cabal index 9e7d55fa..e6eb88cc 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -9,7 +9,7 @@ maintainer: Simon Marlow stability: stable homepage: http://www.haskell.org/haddock/ synopsis: Haddock is a documentation-generation tool for Haskell libraries -build-depends: base>=1.0, haskell98>=1.0, mtl>=1.0, ghc, network>=1.0 +build-depends: base>=1.0, haskell98>=1.0, mtl>=1.0, ghc, network>=1.0, Cabal data-files: html/haddock-DEBUG.css html/haddock.css diff --git a/src/Main.hs b/src/Main.hs index dad47fb5..7c6c9bc8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -39,6 +39,7 @@ import Foreign.C import qualified Data.Map as Map import Data.Map (Map) import Data.FunctorM ( fmapM ) +import Distribution.InstalledPackageInfo ( InstalledPackageInfo(..) ) import qualified GHC ( init ) import GHC hiding ( init ) @@ -60,7 +61,7 @@ import FastString import DynFlags hiding ( Option ) import StaticFlags ( parseStaticFlags ) import Unique ( mkUnique ) -import Packages +import Packages hiding ( package ) ----------------------------------------------------------------------------- -- Top-level stuff @@ -86,13 +87,14 @@ main = do Nothing -> dynflags' setSessionDynFlags session dynflags'' - - modules <- sortAndCheckModules session dynflags' fileArgs - (ifaces, htmls) <- getIfacesAndHtmls flags dynflags' - let (modss, envs) = unzip ifaces - updateHTMLXRefs htmls modss + modules <- sortAndCheckModules session dynflags'' fileArgs + + packages <- getPackages session dynflags'' + updateHTMLXRefs packages + let env = packagesDocEnv packages + -- TODO: continue to break up the run function into parts - run flags modules envs + run flags modules env parseModeFlag :: [String] -> (Bool, [String]) parseModeFlag ("--ghc-flags":rest) = (True, rest) @@ -214,25 +216,6 @@ sortAndCheckModules session flags files = defaultErrorHandler flags $ do (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 - files <- mapM (\(htmlPath, ifacePath) -> do - htmlExist <- doesDirectoryExist htmlPath - ifaceExist <- doesFileExist ifacePath - if htmlExist && ifaceExist - then do - iface <- readInterface ifacePath - return (Just (iface, htmlPath)) - else return Nothing - ) totalFiles - - return (unzip (catMaybes files)) - data Flag = Flag_CSS String | Flag_Debug @@ -352,8 +335,8 @@ handleEagerFlags flags = do where whenFlag flag action = when (flag `elem` flags) action -run :: [Flag] -> [CheckedMod] -> [Map Name Name] -> IO () -run flags modules extEnvs = do +run :: [Flag] -> [CheckedMod] -> Map Name Name -> IO () +run flags modules extEnv = do let title = case [str | Flag_Heading str <- flags] of [] -> "" @@ -408,7 +391,7 @@ run flags modules extEnvs = do (modMap, messages) = runWriter (pass1 modules flags) haddockMods = catMaybes [ Map.lookup mod modMap | (mod,_,_) <- modules ] homeEnv = buildGlobalDocEnv haddockMods - env = Map.unions (homeEnv:extEnvs) + env = homeEnv `Map.union` extEnv haddockMods' = attachInstances haddockMods (haddockMods'', messages') = runWriter $ mapM (renameModule env) haddockMods' @@ -696,12 +679,18 @@ parseIfaceOption s = case break (==',') s of (fpath,',':file) -> (fpath,file) (file, _) -> ("", file) - + +updateHTMLXRefs :: [PackageData] -> IO () +updateHTMLXRefs packages = writeIORef html_xrefs_ref (Map.fromList mapping) + where + mapping = [ (mod, html) | + (PackageData _ mods html) <- packages, (mod, _) <- mods ] +{- updateHTMLXRefs :: [FilePath] -> [[Module]] -> IO () updateHTMLXRefs paths modss = writeIORef html_xrefs_ref (Map.fromList mapping) where mapping = [ (mod, fpath) | (fpath, mods) <- zip paths modss, mod <- mods ] - +-} getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName)) getPrologue flags = case [filename | Flag_Prologue filename <- flags ] of @@ -1145,40 +1134,87 @@ type ErrMsgM a = Writer [ErrMsg] a -- Packages -------------------------------------------------------------------------------- -getPackageFiles :: DynFlags -> IO [(String, String)] -getPackageFiles dynflags = do - packages <- getExplicitPackagesAnd dynflags [] - mbFiles <- mapM check (filter notRTS packages) - return [ pair | Just pair <- mbFiles ] +-- | Recreate exposed modules from an InstalledPackageInfo +packageModules :: InstalledPackageInfo -> [Module] +packageModules pkgInfo = map (mkModule (pkgId pkgInfo)) moduleNames + where moduleNames = map mkModuleName (exposedModules pkgInfo) + +pkgId :: InstalledPackageInfo -> PackageId +pkgId = mkPackageId . package + +-- | Get the ModuleInfo for each exposed module in a package +getPackageModuleInfo :: Session -> InstalledPackageInfo -> + IO (Maybe [(Module, ModuleInfo)]) +getPackageModuleInfo session pkgInfo = do + mbInfos <- (flip mapM) (packageModules pkgInfo) $ \mod -> do + mbModInfo <- getModuleInfo session mod + case mbModInfo of + Nothing -> return Nothing + Just modInfo -> return (Just (mod, modInfo)) + return (sequence mbInfos) + +-- | Get the Haddock HTML directory path for a package +getHtml :: InstalledPackageInfo -> IO (Either String FilePath) +getHtml pkgInfo = case haddockHTMLs pkgInfo of + (path:_) | not (null path) -> do + dirExists <- doesDirectoryExist path + if dirExists then return (Right path) else return $ + Left ("HTML directory " ++ path ++ " does not exist.") + _ -> return (Left "No Haddock documentation installed.") + +data PackageData = PackageData { + pdPackageId :: PackageId, + pdModuleInfo :: [(Module, ModuleInfo)], + pdHtmlPath :: FilePath +} + +-- | Retrieve a PackageData for a package in the session +getPackageData :: Session -> InstalledPackageInfo -> + IO (Either String PackageData) +getPackageData session pkgInfo = do + eHtml <- getHtml pkgInfo + mbModInfo <- getPackageModuleInfo session pkgInfo + let eModInfo = toEither "Could not get ModuleInfo for all exposed modules." + mbModInfo + return $ do -- in the Either monad + html <- eHtml + modInfo <- eModInfo + return $ PackageData { + pdPackageId = pkgId pkgInfo, + pdModuleInfo = modInfo, + pdHtmlPath = html + } + where + toEither err = maybe (Left err) Right + +-- | Retrieve a PackageData for each package in the session except for rts. +-- Print a warning on stdout if a PackageData could not be retrieved. +getPackages :: Session -> DynFlags -> IO [PackageData] +getPackages session dynflags = do + pkgInfos <- getExplicitPackagesAnd dynflags [] + let pkgInfos' = filter notRTS pkgInfos + liftM catMaybes (mapM getPackage pkgInfos') where -- no better way to do this? notRTS p = pkgName (package p) /= packageIdString rtsPackageId - check p = (do - pair <- check' p - return (Just pair)) `catch` (\e -> do - putStrLn ("Warning: Cannot use package " ++ pkg ++ ":") - putStrLn (" " ++ show e) - return Nothing) - where - pkg = showPackageId (package p) - - check' p = do - when (null html || null iface) $ - throwIO (ErrorCall "No Haddock documentation installed.") - - htmlExists <- doesDirectoryExist html - when (not htmlExists) $ - throwIO (ErrorCall ("HTML directory " ++ html ++ " does not exist.")) - - ifaceExists <- doesFileExist iface - when (not ifaceExists) $ - throwIO (ErrorCall ("Interface " ++ iface ++ " does not exist.")) - - return (html, iface) - where - html = first (haddockHTMLs p) - iface = first (haddockInterfaces p) - - first [] = [] - first (x:_) = x + getPackage pkgInfo = do + result <- getPackageData session pkgInfo + case result of + Left err -> do + let pkgName = showPackageId (package pkgInfo) + putStrLn ("Warning: Cannot use package " ++ pkgName ++ ":") + putStrLn (" " ++ show err) + return Nothing + Right pkgInfo -> return (Just pkgInfo) + +packagesDocEnv :: [PackageData] -> Map Name Name +packagesDocEnv packages = Map.fromList (concatMap packageDocEnv packages) + +packageDocEnv :: PackageData -> [(Name, Name)] +packageDocEnv package = concatMap moduleInfoDocEnv modInfo + where modInfo = pdModuleInfo package + +moduleInfoDocEnv :: (Module, ModuleInfo) -> [(Name, Name)] +moduleInfoDocEnv (mod, modInfo) = [ (n, nameSetMod n mod) | n <- names ] + where names = modInfoExports modInfo -- cgit v1.2.3