diff options
| -rw-r--r-- | src/Haddock/InterfaceFile.hs | 16 | ||||
| -rw-r--r-- | src/Haddock/Options.hs | 21 | ||||
| -rw-r--r-- | src/Haddock/Packages.hs | 22 | ||||
| -rw-r--r-- | src/Main.hs | 17 |
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 } |