aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorDavid Waern <davve@dtek.chalmers.se>2007-10-18 22:03:20 +0000
committerDavid Waern <davve@dtek.chalmers.se>2007-10-18 22:03:20 +0000
commit3fdfcf2a507667327fc6b0e1c95cc9898fc1f9b6 (patch)
treec04142ff36153395424558d12540f9162654a8e3 /src
parent54d9edbb47657ba67b5b1c5248f295c772bf2948 (diff)
Add support for --read-interface again
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/InterfaceFile.hs16
-rw-r--r--src/Haddock/Options.hs21
-rw-r--r--src/Haddock/Packages.hs22
-rw-r--r--src/Main.hs17
4 files changed, 60 insertions, 16 deletions
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 6441c503..7f2fd6f4 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -45,15 +45,19 @@ data InterfaceMod = InterfaceMod {
}
data InterfaceFile = InterfaceFile {
- ifLinkEnv :: LinkEnv
--- ifModules :: [InterfaceMod]
+ ifLinkEnv :: LinkEnv,
+ ifModules :: [Module]
}
instance Binary InterfaceFile where
- put_ bh (InterfaceFile x) = put_ bh (Map.toList x)
- get bh = do
- env <- get bh
- return (InterfaceFile (Map.fromList env))
+ put_ bh (InterfaceFile env mods) = do
+ put_ bh (Map.toList env)
+ put_ bh mods
+
+ get bh = do
+ env <- get bh
+ mods <- get bh
+ return (InterfaceFile (Map.fromList env) mods)
iface2interface iface = InterfaceMod {
imModule = ifaceMod iface,
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 89850f9c..152b30d4 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -9,7 +9,8 @@ module Haddock.Options (
parseHaddockOpts,
Flag(..),
getUsage,
- makeGhcFlags
+ getGhcFlags,
+ getIfacePairs
) where
@@ -36,14 +37,26 @@ parseHaddockOpts words =
throwE (concat errors ++ usage)
-makeGhcFlags :: [Flag] -> [String]
-makeGhcFlags flags = [ option | Flag_OptGhc option <- flags ]
+getGhcFlags :: [Flag] -> [String]
+getGhcFlags flags = [ option | Flag_OptGhc option <- flags ]
+
+
+getIfacePairs :: [Flag] -> [(FilePath, FilePath)]
+getIfacePairs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
+
+
+parseIfaceOption :: String -> (FilePath, FilePath)
+parseIfaceOption s =
+ case break (==',') s of
+ (fpath,',':file) -> (fpath, file)
+ (file, _) -> ("", file)
data Flag
= Flag_CSS String
| Flag_Debug
-- | Flag_DocBook
+ | Flag_ReadInterface String
| Flag_DumpInterface String
| Flag_Heading String
| Flag_Html
@@ -83,6 +96,8 @@ options backwardsCompat =
"directory in which to put the output files",
Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR")
"location of Haddock's auxiliary files",
+ Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE")
+ "read an interface from FILE",
Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE")
"interface file name",
-- Option ['S'] ["docbook"] (NoArg Flag_DocBook)
diff --git a/src/Haddock/Packages.hs b/src/Haddock/Packages.hs
index d722bdfe..ba3ee841 100644
--- a/src/Haddock/Packages.hs
+++ b/src/Haddock/Packages.hs
@@ -8,6 +8,7 @@
module Haddock.Packages (
HaddockPackage(..),
getHaddockPackages,
+ getHaddockPackages',
combineLinkEnvs
) where
@@ -15,6 +16,7 @@ module Haddock.Packages (
import Haddock.Types
import Haddock.Exception
import Haddock.InterfaceFile
+import qualified Distribution.Haddock as D
import Data.Maybe
import qualified Data.Map as Map
@@ -38,6 +40,24 @@ data HaddockPackage = HaddockPackage {
}
+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.
@@ -65,7 +85,7 @@ getPackage pkgInfo = do
iface <- readInterfaceFile ifacePath
return $ HaddockPackage {
- pdModules = packageModules pkgInfo,
+ pdModules = ifModules iface,
pdLinkEnv = ifLinkEnv iface,
pdHtmlPath = html
}
diff --git a/src/Main.hs b/src/Main.hs
index c900529c..8ddea3e9 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -105,14 +105,18 @@ main = handleTopExceptions $ do
libDir <- handleEasyFlags flags fileArgs
-- initialize GHC
- let ghcFlags = makeGhcFlags flags
+ let ghcFlags = getGhcFlags flags
(session, dynflags) <- startGhc libDir ghcFlags
-- get the -use-package packages, load them in GHC,
-- and try to get the corresponding installed HaddockPackages
let usePackages = [ pkg | Flag_UsePackage pkg <- flags ]
pkgInfos <- loadPackages session usePackages
- packages <- getHaddockPackages pkgInfos
+ packages'' <- getHaddockPackages pkgInfos
+
+ -- get packages via --read-interface
+ packages' <- getHaddockPackages' (getIfacePairs flags)
+ let packages = packages'' ++ packages'
-- typecheck argument modules using GHC
modules <- typecheckFiles session fileArgs
@@ -129,7 +133,7 @@ main = handleTopExceptions $ do
render flags interfaces
-- last but not least, dump the interface file!
- dumpInterfaceFile homeLinks flags
+ dumpInterfaceFile (map ghcModule modules) homeLinks flags
-------------------------------------------------------------------------------
@@ -217,14 +221,15 @@ render flags interfaces = do
-------------------------------------------------------------------------------
-dumpInterfaceFile :: LinkEnv -> [Flag] -> IO ()
-dumpInterfaceFile homeLinks flags =
+dumpInterfaceFile :: [Module] -> LinkEnv -> [Flag] -> IO ()
+dumpInterfaceFile modules homeLinks flags =
case [str | Flag_DumpInterface str <- flags] of
[] -> return ()
fs -> let filename = last fs in writeInterfaceFile filename ifaceFile
where
ifaceFile = InterfaceFile {
- ifLinkEnv = homeLinks
+ ifModules = modules,
+ ifLinkEnv = homeLinks
}