aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-ghc.cabal7
-rw-r--r--src/Distribution/Haddock.hs17
-rw-r--r--src/Haddock/Exception.hs14
-rw-r--r--src/Haddock/InterfaceFile.hs50
-rw-r--r--src/HaddockTypes.hs12
-rw-r--r--src/Main.hs57
6 files changed, 97 insertions, 60 deletions
diff --git a/haddock-ghc.cabal b/haddock-ghc.cabal
index 4ec7fd26..10ee010a 100644
--- a/haddock-ghc.cabal
+++ b/haddock-ghc.cabal
@@ -9,6 +9,10 @@ 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, Cabal, FilePath>=0.11
+ghc-options: -fglasgow-exts
+hs-source-dirs: src
+exposed-modules:
+ Distribution.Haddock
data-files:
html/haddock-DEBUG.css
html/haddock.css
@@ -73,5 +77,6 @@ other-modules:
HaddockVersion
Html
GHCUtils
+ Haddock.InterfaceFile
+ Haddock.Exception
Main
-
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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 07:41:15 +0000