aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Documentation/Haddock.hs4
-rw-r--r--src/Main.hs72
2 files changed, 51 insertions, 25 deletions
diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs
index 21400051..f277bf78 100644
--- a/src/Documentation/Haddock.hs
+++ b/src/Documentation/Haddock.hs
@@ -17,6 +17,7 @@ module Documentation.Haddock (
Interface(..),
InstalledInterface(..),
createInterfaces,
+ createInterfaces',
-- * Export items & declarations
ExportItem(..),
@@ -39,6 +40,7 @@ module Documentation.Haddock (
Example(..),
DocMarkup(..),
HaddockModInfo(..),
+ markup,
-- * Interface files
-- | (.haddock files)
@@ -59,3 +61,5 @@ import Haddock.InterfaceFile
import Haddock.Interface
import Haddock.Types
import Haddock.Options
+import Haddock.Utils
+import Main
diff --git a/src/Main.hs b/src/Main.hs
index 159cb48d..5c0d0174 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -15,7 +15,7 @@
--
-- Program entry point and top-level code.
-----------------------------------------------------------------------------
-module Main (main) where
+module Main (main, createInterfaces') where
import Haddock.Backends.Xhtml
@@ -115,6 +115,48 @@ 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
@@ -125,30 +167,10 @@ main = handleTopExceptions $ do
if not (null fileArgs)
then 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)
- liftIO $ do
- -- Render the interfaces.
- renderStep flags packages ifaces
-
- -- Dump an "interface file" (.haddock file), if requested.
- case optDumpInterfaceFile flags of
- Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
- Nothing -> return ()
+ (packages, ifaces) <- readPackagesAndCreateInterfaces flags fileArgs
+
+ -- Render the interfaces.
+ renderStep flags packages ifaces
else do
when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $