diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Distribution/Haddock.hs | 17 | ||||
| -rw-r--r-- | src/Haddock/Exception.hs | 14 | ||||
| -rw-r--r-- | src/Haddock/InterfaceFile.hs | 50 | ||||
| -rw-r--r-- | src/HaddockTypes.hs | 12 | ||||
| -rw-r--r-- | src/Main.hs | 57 |
5 files changed, 91 insertions, 59 deletions
diff --git a/src/Distribution/Haddock.hs b/src/Distribution/Haddock.hs new file mode 100644 index 00000000..c6e2dd3b --- /dev/null +++ b/src/Distribution/Haddock.hs @@ -0,0 +1,17 @@ +module Distribution.Haddock ( + readInterfaceFile, + H.writeInterfaceFile, + H.InterfaceFile +) where + +import Haddock.Exception +import qualified Haddock.InterfaceFile as H + +import Control.Exception +import Control.Monad + +readInterfaceFile :: FilePath -> IO (Either String H.InterfaceFile) +readInterfaceFile f = + liftM Right (H.readInterfaceFile f) + `catchDyn` + (\(e::HaddockException) -> return $ Left $ show e) diff --git a/src/Haddock/Exception.hs b/src/Haddock/Exception.hs new file mode 100644 index 00000000..73ec2c5d --- /dev/null +++ b/src/Haddock/Exception.hs @@ -0,0 +1,14 @@ +module Haddock.Exception ( + HaddockException, + throwE +)where + +import Data.Typeable +import Control.Exception + +data HaddockException = HaddockException String deriving Typeable +throwE str = throwDyn (HaddockException str) + +instance Show HaddockException where + show (HaddockException str) = str + diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs new file mode 100644 index 00000000..becd40df --- /dev/null +++ b/src/Haddock/InterfaceFile.hs @@ -0,0 +1,50 @@ +module Haddock.InterfaceFile ( + InterfaceFile(..), + writeInterfaceFile, + readInterfaceFile +) where + +import HaddockTypes +import Haddock.Exception + +import Binary +import System.IO +import Data.Word +import qualified Data.Map as Map +import Control.Monad + +data InterfaceFile = InterfaceFile { + ifDocEnv :: DocEnv +} + +instance Binary InterfaceFile where + put_ bh (InterfaceFile docEnv) = put_ bh (Map.toList docEnv) + get bh = do + envList <- get bh + return (InterfaceFile (Map.fromList envList)) + +packageFileMagic = 0xDA303001 :: Word32 +packageFileVersion = 0 :: Word16 + +writeInterfaceFile :: FilePath -> InterfaceFile -> IO () +writeInterfaceFile filename iface = do + h <- openBinaryFile filename WriteMode + bh <- openBinIO h + ud <- newWriteState + bh <- return $ setUserData bh ud + put_ bh packageFileMagic + put_ bh packageFileVersion + put_ bh iface + hClose h + +readInterfaceFile :: FilePath -> IO InterfaceFile +readInterfaceFile 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 + (version :: Word16) <- get bh + get bh diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs index 9c04c6e2..4200e89f 100644 --- a/src/HaddockTypes.hs +++ b/src/HaddockTypes.hs @@ -6,16 +6,7 @@ -- Ported to use the GHC API by David Waern 2006 -- -module HaddockTypes ( - ExportItem(..), - ModuleMap, - DocMap, - HaddockModule(..), - DocOption(..), - InstHead, - DocName(..), - DocMarkup(..) - ) where +module HaddockTypes where import GHC import Outputable @@ -58,6 +49,7 @@ data ExportItem name type InstHead name = ([HsPred name], name, [HsType name]) type ModuleMap = Map Module HaddockModule type DocMap = Map Name (HsDoc DocName) +type DocEnv = Map Name Name data DocName = Link Name | NoLink Name diff --git a/src/Main.hs b/src/Main.hs index 5bbbc842..1e543bc3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,6 +14,8 @@ import HaddockRename import HaddockTypes import HaddockUtil import HaddockVersion +import Haddock.InterfaceFile +import Haddock.Exception import GHCUtils import Paths_haddock_ghc ( getDataDir ) @@ -28,7 +30,6 @@ 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 Data.Graph hiding ( flattenSCC ) import Data.Dynamic @@ -61,7 +62,6 @@ import Var hiding ( varName ) import TyCon import PrelNames import Bag -import Binary import HscTypes import Util ( handleDyn ) import ErrUtils ( printBagOfErrors ) @@ -77,9 +77,6 @@ import StaticFlags ( parseStaticFlags ) -- Exception handling -------------------------------------------------------------------------------- -data HaddockException = HaddockException String deriving Typeable -throwE str = throwDyn (HaddockException str) - handleTopExceptions = handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions @@ -97,8 +94,8 @@ handleNormalExceptions inner = ) inner handleHaddockExceptions inner = - handleDyn (\(HaddockException str) -> do - putStrLn $ "haddock: " ++ str + handleDyn (\(e::HaddockException) -> do + putStrLn $ "haddock: " ++ (show e) exitFailure ) inner @@ -433,7 +430,7 @@ run flags modules extEnv = do case [str | Flag_DumpInterface str <- flags] of [] -> return () fs -> let filename = (last fs) in - writePackageFile filename homeEnv + writeInterfaceFile filename (InterfaceFile homeEnv) type CheckedMod = (Module, FilePath, FullyCheckedMod) @@ -1184,8 +1181,6 @@ type ErrMsgM a = Writer [ErrMsg] a -- Packages -------------------------------------------------------------------------------- -type DocEnv = Map Name Name - data PackageData = PackageData { pdModules :: [Module], pdDocEnv :: DocEnv, @@ -1244,7 +1239,7 @@ getPackage :: Session -> InstalledPackageInfo -> IO PackageData getPackage session pkgInfo = do html <- getHtml pkgInfo iface <- getIface pkgInfo - docEnv <- readPackageFile iface + InterfaceFile docEnv <- readInterfaceFile iface let modules = packageModules pkgInfo @@ -1301,10 +1296,10 @@ getPackages session dynflags flags = do tryGetPackage pkgInfo = (getPackage session pkgInfo >>= return . Just) `catchDyn` - (\(HaddockException e) -> do + (\(e::HaddockException) -> do let pkgName = showPackageId (package pkgInfo) putStrLn ("Warning: Cannot use package " ++ pkgName ++ ":") - putStrLn (" " ++ e) + putStrLn (" " ++ show e) return Nothing ) @@ -1313,39 +1308,3 @@ getPackages session dynflags flags = do -- documentation site. packagesDocEnv :: [PackageData] -> DocEnv packagesDocEnv packages = Map.unions (map pdDocEnv packages) - --------------------------------------------------------------------------------- --- Package/Interface files --------------------------------------------------------------------------------- - -packageFileMagic = 0xDA303001 :: Word32 -packageFileVersion = 0 :: Word16 - -writePackageFile :: FilePath -> DocEnv -> IO () -writePackageFile filename pkgEnv = do - h <- openBinaryFile filename WriteMode - bh <- openBinIO h - - ud <- newWriteState - bh <- return $ setUserData bh ud - - put_ bh packageFileMagic - put_ bh packageFileVersion - put_ bh (Map.toList pkgEnv) - hClose h - -readPackageFile :: FilePath -> IO DocEnv -readPackageFile 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 - - (version :: Word16) <- get bh - envList <- get bh - return (Map.fromList envList) |