aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsimonmar <unknown>2005-02-03 13:42:19 +0000
committersimonmar <unknown>2005-02-03 13:42:19 +0000
commit1cce71d01e78da65ae67ab9b67959970b89b919d (patch)
treeb2b2a969b968c16b6fb042d7052403411f4aa55d
parentd8450a233a8e9e0fabcd34e9daf53c82db4dd3bd (diff)
[haddock @ 2005-02-03 13:42:19 by simonmar]
- add --ignore-all-exports flag, which behaves as if every module has the ignore-exports attribute (requested by Chris Ryder). - add --hide option to hide a module on the command line. - add --use-package option to get Haddock info for a package from ghc-pkg (largely untested). - remove reexports from the .haddock file, they aren't used any more.
-rw-r--r--src/Main.hs145
1 files changed, 121 insertions, 24 deletions
diff --git a/src/Main.hs b/src/Main.hs
index bce33a5f..68214164 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -29,7 +29,7 @@ import Control.Monad.Writer ( Writer, runWriter, tell )
import Data.Char ( isSpace )
import Data.IORef ( writeIORef )
import Data.List ( nub, (\\), foldl' )
-import Data.Maybe ( isJust, maybeToList )
+import Data.Maybe ( isJust, isNothing, maybeToList )
--import Debug.Trace
import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..) )
import System.Environment ( getArgs )
@@ -39,6 +39,15 @@ import Foreign
import Foreign.C
#endif
+#if __GLASGOW_HASKELL__ >= 603
+import System.Process
+import System.Exit
+import Control.Exception ( Exception(..), throwIO, catch )
+import Prelude hiding (catch)
+import System.Directory ( doesDirectoryExist, doesFileExist )
+import Control.Concurrent
+#endif
+
-----------------------------------------------------------------------------
-- Top-level stuff
main :: IO ()
@@ -75,6 +84,9 @@ data Flag
| Flag_GenContents
| Flag_UseIndex String
| Flag_GenIndex
+ | Flag_IgnoreAllExports
+ | Flag_HideModule String
+ | Flag_UsePackage String
deriving (Eq)
options :: [OptDescr Flag]
@@ -121,7 +133,13 @@ options =
Option [] ["use-index"] (ReqArg Flag_UseIndex "URL")
"use a separately-generated HTML index",
Option [] ["gen-index"] (NoArg Flag_GenIndex)
- "generate an HTML index from specified interfaces"
+ "generate an HTML index from specified interfaces",
+ Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)
+ "behave as if all modules have the ignore-exports atribute",
+ Option [] ["hide"] (ReqArg Flag_HideModule "M")
+ "behave as if module M has the hide attribute",
+ Option [] ["use-package"] (ReqArg Flag_UsePackage "P")
+ "the modules being processed depend on package P"
]
run :: [Flag] -> [FilePath] -> IO ()
@@ -145,6 +163,8 @@ run flags files = do
[] -> Nothing
(t:_) -> Just t
+ verbose = Flag_Verbose `elem` flags
+
libdir <- case [str | Flag_Lib str <- flags] of
[] -> do maybe_exec_dir <- getBaseDir
-- Get directory of executable
@@ -165,12 +185,9 @@ run flags files = do
[] -> Nothing
fs -> Just (last fs)
- ifaces_to_read = [ parseIfaceOption str
+ read_iface_flags = [ parseIfaceOption str
| Flag_ReadInterface str <- flags ]
- no_implicit_prelude = Flag_NoImplicitPrelude `elem` flags
- verbose = Flag_Verbose `elem` flags
-
maybe_contents_url =
case [url | Flag_UseContents url <- flags] of
[] -> Nothing
@@ -188,6 +205,11 @@ run flags files = do
prologue <- getPrologue flags
+ -- grok the --use-package flags
+ pkg_ifaces_to_read <- getPackageIfaces flags verbose
+
+ let ifaces_to_read = read_iface_flags ++ pkg_ifaces_to_read
+
read_iface_stuff <- mapM readIface (map snd ifaces_to_read)
let
@@ -229,8 +251,7 @@ run flags files = do
loop mod_env ifaces [] = return (reverse ifaces)
loop mod_env ifaces ((hsmod,file):mdls) = do
let (iface,msgs) = runWriter $
- mkInterfacePhase1 no_implicit_prelude verbose mod_env
- file package hsmod
+ mkInterfacePhase1 flags verbose mod_env file package hsmod
new_mod_env = Map.insert (iface_module iface) iface mod_env
mapM_ (hPutStrLn stderr) msgs
loop new_mod_env (iface:ifaces) mdls
@@ -321,6 +342,69 @@ getPrologue flags
Right doc -> return (Just doc)
_otherwise -> dieMsg "multiple -p/--prologue options"
+-- ---------------------------------------------------------------------------
+-- External packages
+
+getPackageIfaces :: [Flag] -> Bool -> IO [(String,String)]
+getPackageIfaces flags verbose =
+ let
+ pkgs = [pkg | Flag_UsePackage pkg <- flags]
+ in
+#if __GLASGOW_HASKELL__ < 603
+ if (not (null pkgs))
+ then die ("-use-package not supported; recompile Haddock with GHC 6.4 or later")
+ else return ()
+#else
+ do
+ mb_iface_details <- mapM getPkgIface pkgs
+ return [ ok | Just ok <- mb_iface_details ]
+ where
+ hc_pkg = "ghc-pkg" -- ToDo: flag
+
+ getPkgIface pkg = do
+ when verbose $
+ putStrLn ("querying ghc-pkg for " ++ pkg ++ "...")
+ getPkgIface' pkg
+ `catch` (\e -> do
+ putStrLn ("Warning: cannot use package " ++ pkg ++ ":")
+ putStrLn (" " ++ show e)
+ return Nothing)
+
+ getPkgIface' pkg = do
+ (hin,hout,herr,p) <- runInteractiveProcess hc_pkg
+ ["field", "haddock-interfaces", pkg]
+ Nothing Nothing
+ hClose hin
+ out <- hGetContents hout
+ forkIO (hGetContents herr >> return ()) -- just sink the stderr
+ r <- waitForProcess p
+ when (r /= ExitSuccess) $
+ throwIO (ErrorCall ("ghc-pkg failed"))
+ let iface = dropWhile isSpace (tail (dropWhile (/=':') out))
+
+ (hin,hout,herr,p) <- runInteractiveProcess hc_pkg
+ ["field", "haddock-html", pkg]
+ Nothing Nothing
+ hClose hin
+ forkIO (hGetContents herr >> return ()) -- just sink the stderr
+ out <- hGetContents hout
+ r <- waitForProcess p
+ when (r /= ExitSuccess) $
+ throwIO (ErrorCall ("ghc-pkg failed"))
+ let html = dropWhile isSpace (tail (dropWhile (/=':') out))
+
+ when verbose $
+ putStrLn (" interface: " ++ iface ++ "\n html: " ++ html)
+
+ iface_exists <- doesFileExist iface
+ when (not iface_exists) $ do
+ throwIO (ErrorCall ("interface " ++ iface ++ " does not exist."))
+ html_exists <- doesDirectoryExist html
+ when (not html_exists) $ do
+ throwIO (ErrorCall ("HTML directory " ++ html ++ " does not exist."))
+ return (Just (iface, html))
+#endif
+
-----------------------------------------------------------------------------
-- Figuring out the definitions that are exported from a module
@@ -333,18 +417,28 @@ getPrologue flags
-- the names we want to link to in the documentation.
mkInterfacePhase1
- :: Bool -- no implicit prelude
+ :: [Flag]
-> Bool -- verbose
-> ModuleMap -> FilePath -> Maybe String -> HsModule
-> ErrMsgM Interface -- the "interface" of the module
-mkInterfacePhase1 no_implicit_prelude verbose mod_map filename package
+mkInterfacePhase1 flags verbose mod_map filename package
(HsModule mdl exps imps decls maybe_opts maybe_info maybe_doc) = do
+ let
+ no_implicit_prelude = Flag_NoImplicitPrelude `elem` flags
+ ignore_all_exports = Flag_IgnoreAllExports `elem` flags
+
-- Process the options, if available
- opts <- case maybe_opts of
+ opts0 <- case maybe_opts of
Just opt_str -> processOptions opt_str
Nothing -> return []
+ let
+ -- check for a --hide option
+ Module mod_str = mdl
+ opts
+ | Flag_HideModule mod_str `elem` flags = OptHide : opts0
+ | otherwise = opts0
let
-- expand type signatures with multiple variables into multiple
@@ -418,7 +512,8 @@ mkInterfacePhase1 no_implicit_prelude verbose mod_map filename package
-- make the "export items", which will be converted into docs later
orig_export_items <- mkExportItems mod_map mdl exported_names decl_map sub_map
- orig_decls opts orig_exports
+ orig_decls opts orig_exports
+ ignore_all_exports
let
-- prune the export list to just those declarations that have
-- documentation, if the 'prune' option is on.
@@ -612,13 +707,17 @@ mkExportItems
-> [HsDecl] -- decls in the current module
-> [DocOption]
-> Maybe [HsExportSpec]
+ -> Bool -- --ignore-all-exports flag
-> ErrMsgM [ExportItem]
mkExportItems mod_map this_mod exported_names decl_map sub_map decls
- opts maybe_exps
- | Nothing <- maybe_exps = everything_local_exported
- | OptIgnoreExports `elem` opts = everything_local_exported
- | Just specs <- maybe_exps = do
+ opts maybe_exps ignore_all_exports
+ | isNothing maybe_exps
+ || ignore_all_exports
+ || OptIgnoreExports `elem` opts
+ = everything_local_exported
+ | Just specs <- maybe_exps
+ = do
exps <- mapM lookupExport specs
return (concat exps)
where
@@ -1140,8 +1239,7 @@ thisFormatVersion = mkFormatVersion 2
-- | How we store interfaces. Not everything is stored.
type StoredInterface2 =
- (Module,Maybe Doc,Maybe String,Bool,[(HsName,Module)],[HsName],
- [(HsName,[HsName])])
+ (Module,Maybe Doc,Maybe String,Bool,[(HsName,Module)], [(HsName,[HsName])])
-- | How we store interfaces. Not everything is stored.
type StoredInterface1 =
@@ -1196,7 +1294,6 @@ from_interface iface =
OptHide `elem` iface_options iface,
[(n,mdl) | (n,Qual mdl n') <- Map.toAscList (iface_env iface),
if n /= n' then error "help!" else True],
- iface_reexported iface,
Map.toAscList (iface_sub iface)
)
@@ -1214,14 +1311,14 @@ putDocEnv bh env = do
to_interface1 :: StoredInterface1 -> Interface
-to_interface1 (mdl,descriptionOpt,package, hide, env, reexported, sub) =
+to_interface1 (mdl,descriptionOpt,package, hide, env, _, sub) =
Interface {
iface_module = mdl,
iface_filename = "",
iface_package = package,
iface_env = Map.fromList env,
iface_sub = Map.fromList sub,
- iface_reexported = map fst reexported,
+ iface_reexported = [],
iface_exports = [],
iface_orig_exports = [],
iface_insts = [],
@@ -1232,7 +1329,7 @@ to_interface1 (mdl,descriptionOpt,package, hide, env, reexported, sub) =
}
to_interface2 :: StoredInterface2 -> Interface
-to_interface2 (mdl,descriptionOpt,package, hide, env, reexported, sub) =
+to_interface2 (mdl,descriptionOpt,package, hide, env, sub) =
Interface {
iface_module = mdl,
iface_filename = "",
@@ -1240,7 +1337,7 @@ to_interface2 (mdl,descriptionOpt,package, hide, env, reexported, sub) =
iface_env =
Map.fromList [(n,Qual mdl n) | (n,mdl) <- env],
iface_sub = Map.fromList sub,
- iface_reexported = reexported,
+ iface_reexported = [],
iface_exports = [],
iface_orig_exports = [],
iface_insts = [],
@@ -1258,7 +1355,7 @@ nullVersion_to_interface (mdl, package, hide, env, reexported, sub) =
iface_package = package,
iface_env = Map.fromList env,
iface_sub = Map.fromList sub,
- iface_reexported = map fst reexported,
+ iface_reexported = [],
iface_exports = [],
iface_orig_exports = [],
iface_insts = [],