Start work on Haddock API

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)