Skip to content
Snippets Groups Projects
Commit 1c4e35f9 authored by David Waern's avatar David Waern
Browse files

Add support for --read-interface again

parent 3242a415
No related branches found
No related tags found
No related merge requests found
...@@ -45,15 +45,19 @@ data InterfaceMod = InterfaceMod { ...@@ -45,15 +45,19 @@ data InterfaceMod = InterfaceMod {
} }
data InterfaceFile = InterfaceFile { data InterfaceFile = InterfaceFile {
ifLinkEnv :: LinkEnv ifLinkEnv :: LinkEnv,
-- ifModules :: [InterfaceMod] ifModules :: [Module]
} }
instance Binary InterfaceFile where instance Binary InterfaceFile where
put_ bh (InterfaceFile x) = put_ bh (Map.toList x) put_ bh (InterfaceFile env mods) = do
get bh = do put_ bh (Map.toList env)
env <- get bh put_ bh mods
return (InterfaceFile (Map.fromList env))
get bh = do
env <- get bh
mods <- get bh
return (InterfaceFile (Map.fromList env) mods)
iface2interface iface = InterfaceMod { iface2interface iface = InterfaceMod {
imModule = ifaceMod iface, imModule = ifaceMod iface,
......
...@@ -9,7 +9,8 @@ module Haddock.Options ( ...@@ -9,7 +9,8 @@ module Haddock.Options (
parseHaddockOpts, parseHaddockOpts,
Flag(..), Flag(..),
getUsage, getUsage,
makeGhcFlags getGhcFlags,
getIfacePairs
) where ) where
...@@ -36,14 +37,26 @@ parseHaddockOpts words = ...@@ -36,14 +37,26 @@ parseHaddockOpts words =
throwE (concat errors ++ usage) throwE (concat errors ++ usage)
makeGhcFlags :: [Flag] -> [String] getGhcFlags :: [Flag] -> [String]
makeGhcFlags flags = [ option | Flag_OptGhc option <- flags ] 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 data Flag
= Flag_CSS String = Flag_CSS String
| Flag_Debug | Flag_Debug
-- | Flag_DocBook -- | Flag_DocBook
| Flag_ReadInterface String
| Flag_DumpInterface String | Flag_DumpInterface String
| Flag_Heading String | Flag_Heading String
| Flag_Html | Flag_Html
...@@ -83,6 +96,8 @@ options backwardsCompat = ...@@ -83,6 +96,8 @@ options backwardsCompat =
"directory in which to put the output files", "directory in which to put the output files",
Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR") Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR")
"location of Haddock's auxiliary files", "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") Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE")
"interface file name", "interface file name",
-- Option ['S'] ["docbook"] (NoArg Flag_DocBook) -- Option ['S'] ["docbook"] (NoArg Flag_DocBook)
......
...@@ -8,6 +8,7 @@ ...@@ -8,6 +8,7 @@
module Haddock.Packages ( module Haddock.Packages (
HaddockPackage(..), HaddockPackage(..),
getHaddockPackages, getHaddockPackages,
getHaddockPackages',
combineLinkEnvs combineLinkEnvs
) where ) where
...@@ -15,6 +16,7 @@ module Haddock.Packages ( ...@@ -15,6 +16,7 @@ module Haddock.Packages (
import Haddock.Types import Haddock.Types
import Haddock.Exception import Haddock.Exception
import Haddock.InterfaceFile import Haddock.InterfaceFile
import qualified Distribution.Haddock as D
import Data.Maybe import Data.Maybe
import qualified Data.Map as Map import qualified Data.Map as Map
...@@ -38,6 +40,24 @@ data HaddockPackage = HaddockPackage { ...@@ -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, -- | 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 -- if it exists. Print a warning on stdout if it couldn't be found for a
-- package. -- package.
...@@ -65,7 +85,7 @@ getPackage pkgInfo = do ...@@ -65,7 +85,7 @@ getPackage pkgInfo = do
iface <- readInterfaceFile ifacePath iface <- readInterfaceFile ifacePath
return $ HaddockPackage { return $ HaddockPackage {
pdModules = packageModules pkgInfo, pdModules = ifModules iface,
pdLinkEnv = ifLinkEnv iface, pdLinkEnv = ifLinkEnv iface,
pdHtmlPath = html pdHtmlPath = html
} }
......
...@@ -105,14 +105,18 @@ main = handleTopExceptions $ do ...@@ -105,14 +105,18 @@ main = handleTopExceptions $ do
libDir <- handleEasyFlags flags fileArgs libDir <- handleEasyFlags flags fileArgs
-- initialize GHC -- initialize GHC
let ghcFlags = makeGhcFlags flags let ghcFlags = getGhcFlags flags
(session, dynflags) <- startGhc libDir ghcFlags (session, dynflags) <- startGhc libDir ghcFlags
-- get the -use-package packages, load them in GHC, -- get the -use-package packages, load them in GHC,
-- and try to get the corresponding installed HaddockPackages -- and try to get the corresponding installed HaddockPackages
let usePackages = [ pkg | Flag_UsePackage pkg <- flags ] let usePackages = [ pkg | Flag_UsePackage pkg <- flags ]
pkgInfos <- loadPackages session usePackages 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 -- typecheck argument modules using GHC
modules <- typecheckFiles session fileArgs modules <- typecheckFiles session fileArgs
...@@ -129,7 +133,7 @@ main = handleTopExceptions $ do ...@@ -129,7 +133,7 @@ main = handleTopExceptions $ do
render flags interfaces render flags interfaces
-- last but not least, dump the interface file! -- 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 ...@@ -217,14 +221,15 @@ render flags interfaces = do
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
dumpInterfaceFile :: LinkEnv -> [Flag] -> IO () dumpInterfaceFile :: [Module] -> LinkEnv -> [Flag] -> IO ()
dumpInterfaceFile homeLinks flags = dumpInterfaceFile modules homeLinks flags =
case [str | Flag_DumpInterface str <- flags] of case [str | Flag_DumpInterface str <- flags] of
[] -> return () [] -> return ()
fs -> let filename = last fs in writeInterfaceFile filename ifaceFile fs -> let filename = last fs in writeInterfaceFile filename ifaceFile
where where
ifaceFile = InterfaceFile { ifaceFile = InterfaceFile {
ifLinkEnv = homeLinks ifModules = modules,
ifLinkEnv = homeLinks
} }
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment