diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 157 |
1 files changed, 114 insertions, 43 deletions
diff --git a/src/Main.hs b/src/Main.hs index fc6dc534..871f2339 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -17,7 +17,7 @@ import GHCUtils import Paths_haddock_ghc ( getDataDir, compilerPath ) import Prelude hiding ( catch ) -import Control.Exception ( catch ) +import Control.Exception import Control.Monad ( when, liftM, foldM ) import Control.Monad.Writer ( Writer, runWriter, tell ) import Data.Char ( isSpace ) @@ -27,6 +27,8 @@ import Data.List ( nub, nubBy, (\\), foldl', sortBy, foldl1, init, mapAccumL, find, isPrefixOf ) import Data.Maybe ( Maybe(..), isJust, isNothing, maybeToList, listToMaybe, fromJust, catMaybes ) +import Data.Word +import Data.Typeable import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..) ) import System.Environment ( getArgs ) @@ -34,6 +36,7 @@ import System.Directory ( doesDirectoryExist ) import System.FilePath import System.Cmd ( system ) import System.Exit ( ExitCode(..) ) +import System.IO import qualified Data.Map as Map import Data.Map (Map) @@ -54,6 +57,7 @@ import Var hiding ( varName ) import TyCon import PrelNames import Bag +import Binary import FastString #define FSLIT(x) (mkFastString# (x#)) @@ -99,31 +103,33 @@ main = do -- initialize GHC (session, dynflags) <- startGHC libDir - -- parse GHC flags given to the program - (dynflags', rest') <- if isGHCMode - then parseGHCFlags_GHCMode dynflags rest - else parseGHCFlags_HaddockMode dynflags rest - setSessionDynFlags session dynflags' + defaultErrorHandler dynflags $ do - -- parse Haddock specific flags - (flags, fileArgs) <- parseHaddockOpts rest' + -- parse GHC flags given to the program + (dynflags', rest') <- if isGHCMode + then parseGHCFlags_GHCMode dynflags rest + else parseGHCFlags_HaddockMode dynflags rest + setSessionDynFlags session dynflags' - -- try to sort and check the input files using the GHC API - modules <- sortAndCheckModules session dynflags' fileArgs + -- parse Haddock specific flags + (flags, fileArgs) <- parseHaddockOpts rest' - -- create a PackageData for each external package in the session - -- using the GHC API. The PackageData contains an html path, - -- a doc env and a list of module names. - packages <- getPackages session dynflags' + -- try to sort and check the input files using the GHC API + modules <- sortAndCheckModules session dynflags' fileArgs - -- update the html references (module -> html file mapping) - updateHTMLXRefs packages + -- create a PackageData for each external package in the session + -- using the GHC API. The PackageData contains an html path, + -- a doc env and a list of module names. + packages <- getPackages session dynflags' flags - -- combine the doc envs of the external packages into one - let env = packagesDocEnv packages + -- update the html references (module -> html file mapping) + updateHTMLXRefs packages - -- TODO: continue to break up the run function into parts - run flags modules env + -- combine the doc envs of the external packages into one + let env = packagesDocEnv packages + + -- TODO: continue to break up the run function into parts + run flags modules env parseModeFlag :: [String] -> (Bool, [String]) parseModeFlag ("--ghc-flags":rest) = (True, rest) @@ -146,12 +152,18 @@ parseGHCFlags dynflags args = case args of (flags, rest) <- parseGHCFlags dynflags xs return (flags, x:rest) where +{- worker strs = do + let (inside, _:outside) = break (=='"') (unwords strs) + (dynflags', rest) <- parseDynamicFlags dynflags (words inside) + when (rest == words inside) $ parseStaticFlags (words inside) >> return () + parseGHCFlags dynflags' (words outside) +-} worker rest = do (mbFlags, rest') <- parseGHCFlag dynflags rest case mbFlags of Just flags -> parseGHCFlags flags rest' Nothing -> parseGHCFlags dynflags rest' - + parseGHCFlag :: DynFlags -> [String] -> IO (Maybe DynFlags, [String]) parseGHCFlag _ [] = die "No GHC flag supplied\n" parseGHCFlag dynflags args = do @@ -210,7 +222,7 @@ startGHC libDir = do return (session, flags'') sortAndCheckModules :: Session -> DynFlags -> [FilePath] -> IO [CheckedMod] -sortAndCheckModules session flags files = defaultErrorHandler flags $ do +sortAndCheckModules session flags files = do --defaultErrorHandler flags $ do targets <- mapM (\s -> guessTarget s Nothing) files setTargets session targets mbModGraph <- depanal session [] True @@ -245,6 +257,8 @@ data Flag -- | Flag_DocBook | Flag_Heading String | Flag_Package String + | Flag_ReadInterface String + | Flag_DumpInterface String | Flag_Html | Flag_Hoogle | Flag_HtmlHelp String @@ -276,6 +290,10 @@ options backwardsCompat = [ Option ['o'] ["odir"] (ReqArg Flag_OutputDir "DIR") "directory in which to put the output files", + Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE") + "read an interface from FILE", + Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE") + "dump an interface for these modules in FILE", Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR") "location of Haddock's auxiliary files", -- Option ['S'] ["docbook"] (NoArg Flag_DocBook) @@ -440,6 +458,12 @@ run flags modules extEnv = do maybe_source_urls maybe_wiki_urls maybe_contents_url maybe_index_url copyHtmlBits odir libdir css_file + + case [str | Flag_DumpInterface str <- flags] of + [] -> return () + fs -> let filename = (last fs) in + savePackageFile filename homeEnv + {- instance Outputable (DocEntity Name) where ppr (DocEntity d) = ppr d @@ -1212,6 +1236,17 @@ type ErrMsgM a = Writer [ErrMsg] a -- Packages -------------------------------------------------------------------------------- +type PackageEnv = Map Name Name + +data PackageData = PackageData { + pdModules :: [Module], + pdDocEnv :: PackageEnv, + pdHtmlPath :: FilePath +} + +data HaddockException = HaddockException String deriving Typeable +throwE str = throwDyn (HaddockException str) + -- | Recreate exposed modules from an InstalledPackageInfo packageModules :: InstalledPackageInfo -> [Module] packageModules pkgInfo = map (mkModule (pkgId pkgInfo)) moduleNames @@ -1233,22 +1268,25 @@ moduleInfo session modules = do return (sequence mbModInfo) -- | Get the Haddock HTML directory path for a package -getHtml :: InstalledPackageInfo -> IO (Either String FilePath) +getHtml :: InstalledPackageInfo -> IO 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.") + if dirExists then return path else throwE $ + "HTML directory " ++ path ++ " does not exist." + _ -> throwE "No Haddock documentation installed." -data PackageData = PackageData { - pdModules :: [Module], - pdDocEnv :: [(Name, Name)], - pdHtmlPath :: FilePath -} +-- | Get the Haddock interface path for a package +getIface :: InstalledPackageInfo -> IO FilePath +getIface pkgInfo = case haddockInterfaces pkgInfo of + (path:_) | not (null path) -> do + dirExists <- doesDirectoryExist path + if dirExists then return path else throwE $ + "Interface directory " ++ path ++ " does not exist." + _ -> throwE "No Haddock interface installed." -- | Try to create a PackageData structure for a package -getPackage :: Session -> InstalledPackageInfo -> IO (Either String PackageData) +getPackage :: Session -> InstalledPackageInfo -> IO PackageData getPackage session pkgInfo = do -- try to get the html path to the documentation @@ -1284,31 +1322,64 @@ packageDocEnv mods infos = concatMap moduleDocEnv (zip mods infos) -- | Try to create a PackageData for each package in the session except for -- rts. Print a warning on stdout if a PackageData could not be created. -getPackages :: Session -> DynFlags -> IO [PackageData] -getPackages session dynflags = do +getPackages :: Session -> DynFlags -> [Flag] -> IO [PackageData] +getPackages session dynflags flags = do -- get InstalledPackageInfos for every package in the session pkgInfos <- getPreloadPackagesAnd dynflags [] -- return a list of those packages that we could create PackageDatas for let pkgInfos' = filter notRTS pkgInfos - liftM catMaybes (mapM tryGetPackage pkgInfos') + liftM catMaybes $ mapM tryGetPackage pkgInfos' where -- no better way to do this? notRTS p = pkgName (package p) /= packageIdString rtsPackageId -- try to get a PackageData, warn if we can't - tryGetPackage pkgInfo = do - result <- getPackage session pkgInfo - case result of - Left err -> do + tryGetPackage pkgInfo = + (getPackage session pkgInfo >>= return . Just) + `catchDyn` + (\(HaddockException e) -> do let pkgName = showPackageId (package pkgInfo) putStrLn ("Warning: Cannot use package " ++ pkgName ++ ":") - putStrLn (" " ++ show err) + putStrLn (" " ++ e) return Nothing - Right pkgInfo -> return (Just pkgInfo) + ) -- | Build one big doc env out of a list of packages -packagesDocEnv :: [PackageData] -> Map Name Name -packagesDocEnv packages = Map.fromList (concatMap pdDocEnv packages) +packagesDocEnv :: [PackageData] -> PackageEnv +packagesDocEnv packages = Map.unions (map pdDocEnv packages) + +-------------------------------------------------------------------------------- +-- Package/Interface files +-------------------------------------------------------------------------------- + +packageFileMagic = 0xDA303001 :: Word32 + +savePackageFile :: FilePath -> PackageEnv -> IO () +savePackageFile filename pkgEnv = do + h <- openBinaryFile filename WriteMode + bh <- openBinIO h + + ud <- newWriteState + bh <- return $ setUserData bh ud + + put_ bh packageFileMagic + put_ bh (Map.toList pkgEnv) + hClose h + +loadPackageFile :: FilePath -> IO PackageEnv +loadPackageFile filename = do + h <- openBinaryFile filename ReadMode + bh <- openBinIO h + + ud <- newReadState undefined + bh <- return (setUserData bh ud) + + magic <- get bh + when (magic /= packageFileMagic) $ throwE $ + "Magic number mismatch: couldn't load interface file: " ++ filename + + envList <- get bh + return (Map.fromList envList) |