diff options
Diffstat (limited to 'src/Haddock')
| -rw-r--r-- | src/Haddock/InterfaceFile.hs | 72 | ||||
| -rw-r--r-- | src/Haddock/Packages.hs | 126 |
2 files changed, 38 insertions, 160 deletions
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 7f2fd6f4..93d6fe4c 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -114,47 +114,51 @@ writeInterfaceFile filename iface = do -- snd send the result to the file writeBinMem bh filename return () + -readInterfaceFile :: FilePath -> IO InterfaceFile +readInterfaceFile :: FilePath -> IO (Either String InterfaceFile) readInterfaceFile filename = do bh <- readBinMem filename - magic <- get bh - when (magic /= binaryInterfaceMagic) $ throwE $ - "Magic number mismatch: couldn't load interface file: " ++ filename - + magic <- get bh version <- get bh - when (version /= binaryInterfaceVersion) $ throwE $ - "Interface file is of wrong version: " ++ filename - -- get the dictionary - dict_p <- get bh - data_p <- tellBin bh - seekBin bh dict_p - dict <- getDictionary bh - seekBin bh data_p - - -- initialise the user-data field of bh - ud <- newReadState dict - bh <- return (setUserData bh ud) + case () of + _ | magic /= binaryInterfaceMagic -> return . Left $ + "Magic number mismatch: couldn't load interface file: " ++ filename + | version /= binaryInterfaceVersion -> return . Left $ + "Interface file is of wrong version: " ++ filename + | otherwise -> do + + -- get the dictionary + dict_p <- get bh + data_p <- tellBin bh + seekBin bh dict_p + dict <- getDictionary bh + seekBin bh data_p + + -- initialise the user-data field of bh + ud <- newReadState dict + bh <- return (setUserData bh ud) - -- get the symbol table - symtab_p <- get bh - data_p <- tellBin bh - seekBin bh symtab_p - -- (construct an empty name cache) - u <- mkSplitUniqSupply 'a' -- ?? - let nc = initNameCache u [] - (_, symtab) <- getSymbolTable bh nc - seekBin bh data_p - - -- set the symbol table - let ud = getUserData bh - bh <- return $! setUserData bh ud{ud_symtab = symtab} - - -- load the actual data - iface <- get bh - return iface + -- get the symbol table + symtab_p <- get bh + data_p <- tellBin bh + seekBin bh symtab_p + -- (construct an empty name cache) + u <- mkSplitUniqSupply 'a' -- ?? + let nc = initNameCache u [] + (_, symtab) <- getSymbolTable bh nc + seekBin bh data_p + + -- set the symbol table + let ud = getUserData bh + bh <- return $! setUserData bh ud{ud_symtab = symtab} + + -- load the actual data + iface <- get bh + return (Right iface) + ------------------------------------------------------------------------------- -- Symbol table diff --git a/src/Haddock/Packages.hs b/src/Haddock/Packages.hs deleted file mode 100644 index ba3ee841..00000000 --- a/src/Haddock/Packages.hs +++ /dev/null @@ -1,126 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - - -module Haddock.Packages ( - HaddockPackage(..), - getHaddockPackages, - getHaddockPackages', - combineLinkEnvs -) where - - -import Haddock.Types -import Haddock.Exception -import Haddock.InterfaceFile -import qualified Distribution.Haddock as D - -import Data.Maybe -import qualified Data.Map as Map -import Control.Monad -import Control.Exception -import System.Directory - -import GHC -import DynFlags -import Module -import Packages - - --- | This structure represents the installed Haddock information for a --- package. This is basically the contents of the .haddock file, the path --- to the html files and the list of modules in the package -data HaddockPackage = HaddockPackage { - pdModules :: [Module], - pdLinkEnv :: LinkEnv, - pdHtmlPath :: FilePath -} - - -getHaddockPackages' :: [(FilePath, FilePath)] -> IO [HaddockPackage] -getHaddockPackages' pairs = do - mbPackages <- mapM tryReadIface pairs - return (catMaybes mbPackages) - where - -- try to get a HaddockPackage, warn if we can't - tryReadIface (html, iface) = do - eIface <- D.readInterfaceFile iface - case eIface of - Left err -> do - putStrLn ("Warning: Cannot read " ++ iface ++ ":") - putStrLn (" " ++ show err) - putStrLn "Skipping this interface." - return Nothing - Right iface -> return $ Just $ - HaddockPackage (ifModules iface) (ifLinkEnv iface) html - - --- | Try to read the installed Haddock information for the given packages, --- if it exists. Print a warning on stdout if it couldn't be found for a --- package. -getHaddockPackages :: [InstalledPackageInfo] -> IO [HaddockPackage] -getHaddockPackages pkgInfos = liftM catMaybes $ mapM tryGetPackage pkgInfos - where - -- try to get a HaddockPackage, warn if we can't - tryGetPackage pkgInfo = - (getPackage pkgInfo >>= return . Just) - `catchDyn` - (\(e::HaddockException) -> do - let pkgName = showPackageId (package pkgInfo) - putStrLn ("Warning: Cannot use package " ++ pkgName ++ ":") - putStrLn (" " ++ show e) - return Nothing - ) - - --- | Try to read a HaddockPackage structure for a package -getPackage :: InstalledPackageInfo -> IO HaddockPackage -getPackage pkgInfo = do - - html <- getHtml pkgInfo - ifacePath <- getIface pkgInfo - iface <- readInterfaceFile ifacePath - - return $ HaddockPackage { - pdModules = ifModules iface, - pdLinkEnv = ifLinkEnv iface, - pdHtmlPath = html - } - - --- | Recreate exposed modules from an InstalledPackageInfo -packageModules :: InstalledPackageInfo -> [Module] -packageModules pkgInfo = map (mkModule (pkgId pkgInfo)) moduleNames - where - moduleNames = map mkModuleName (exposedModules pkgInfo) - pkgId = mkPackageId . package - - --- | Get the Haddock HTML directory path for a package -getHtml :: InstalledPackageInfo -> IO FilePath -getHtml pkgInfo = case haddockHTMLs pkgInfo of - (path:_) | not (null path) -> do - dirExists <- doesDirectoryExist path - if dirExists then return path else throwE $ - "HTML directory " ++ path ++ " does not exist." - _ -> throwE "No Haddock documentation installed." - - --- | Get the Haddock interface path for a package -getIface :: InstalledPackageInfo -> IO FilePath -getIface pkgInfo = case haddockInterfaces pkgInfo of - (file:_) | not (null file) -> do - fileExists <- doesFileExist file - if fileExists then return file else throwE $ - "Interface file " ++ file ++ " does not exist." - _ -> throwE "No Haddock interface installed." - - --- | Build one big link env out of a list of packages. If multiple packages --- export the same (original) name, we just pick one of the packages as the --- documentation site. -combineLinkEnvs :: [HaddockPackage] -> LinkEnv -combineLinkEnvs packages = Map.unions (map pdLinkEnv packages) |