aboutsummaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
authorDavid Waern <david.waern@gmail.com>2010-08-26 20:31:58 +0000
committerDavid Waern <david.waern@gmail.com>2010-08-26 20:31:58 +0000
commit5a5c656c9817e1f0d83531cec4eeca38333519df (patch)
treea98396a5784e5e2717a3c380ab51facb858dcfb1 /src/Main.hs
parenta127473902c8d833f15ad7fd83f29cc786827f14 (diff)
Follow recent API additions with some refactorings
Simon Hegel's patch prompted me to do some refactorings in Main, Haddock.Documentation and Haddock.Interface.
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs76
1 files changed, 30 insertions, 46 deletions
diff --git a/src/Main.hs b/src/Main.hs
index 5c0d0174..1192b1fb 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -15,7 +15,7 @@
--
-- Program entry point and top-level code.
-----------------------------------------------------------------------------
-module Main (main, createInterfaces') where
+module Main (main, readPackagesAndProcessModules) where
import Haddock.Backends.Xhtml
@@ -115,59 +115,22 @@ handleGhcExceptions =
-------------------------------------------------------------------------------
--- | Create 'Interface' structures from a given list of Haddock command-line
--- flags and file or module names (as accepted by 'haddock' executable). Flags
--- that control documentation generation or show help or version information
--- are ignored.
---
--- This is a more high-level alternative to 'createInterfaces'.
-createInterfaces'
- :: [String] -- ^ A list of command-line flags and file or module names
- -> IO [Interface] -- ^ Resulting list of interfaces
-createInterfaces' args = do
- (flags, fileArgs) <- parseHaddockOpts args
- (_, ifaces) <- readPackagesAndCreateInterfaces flags fileArgs
- return ifaces
-
-
-readPackagesAndCreateInterfaces :: [Flag] -> [String] -> IO ([(InterfaceFile, FilePath)], [Interface])
-readPackagesAndCreateInterfaces flags fileArgs = do
- libDir <- getGhcLibDir flags
-
- -- Catches all GHC source errors, then prints and re-throws them.
- let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
- printExceptionAndWarnings err
- liftIO exitFailure
-
- -- Initialize GHC.
- withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
-
- -- Get packages supplied with --read-interface.
- packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)
-
- -- Create the interfaces -- this is the core part of Haddock.
- (ifaces, homeLinks) <- createInterfaces (verbosity flags) fileArgs flags
- (map fst packages)
-
- -- Dump an "interface file" (.haddock file), if requested.
- liftIO $ case optDumpInterfaceFile flags of
- Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
- Nothing -> return ()
-
- return (packages, ifaces)
-
-
main :: IO ()
main = handleTopExceptions $ do
-- Parse command-line flags and handle some of them initially.
args <- getArgs
- (flags, fileArgs) <- parseHaddockOpts args
+ (flags, files) <- parseHaddockOpts args
shortcutFlags flags
- if not (null fileArgs)
+ if not (null files)
then do
- (packages, ifaces) <- readPackagesAndCreateInterfaces flags fileArgs
+ (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
+
+ -- Dump an "interface file" (.haddock file), if requested.
+ case optDumpInterfaceFile flags of
+ Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
+ Nothing -> return ()
-- Render the interfaces.
renderStep flags packages ifaces
@@ -183,6 +146,27 @@ main = handleTopExceptions $ do
renderStep flags packages []
+readPackagesAndProcessModules flags files = do
+ libDir <- getGhcLibDir flags
+
+ -- Catches all GHC source errors, then prints and re-throws them.
+ let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
+ printExceptionAndWarnings err
+ liftIO exitFailure
+
+ -- Initialize GHC.
+ withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
+
+ -- Get packages supplied with --read-interface.
+ packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)
+
+ -- Create the interfaces -- this is the core part of Haddock.
+ let ifaceFiles = map fst packages
+ (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles
+
+ return (packages, ifaces, homeLinks)
+
+
renderStep :: [Flag] -> [(InterfaceFile, FilePath)] -> [Interface] -> IO ()
renderStep flags packages interfaces = do
updateHTMLXRefs packages