Commit 79a2b70a authored by ijones's avatar ijones
Browse files

added features to ./setup haddock

added title to ./setup haddock
added prolog to ./setup haddock
all commands take the --verbose argument, so fixed the parser
uncommented hooks stuff I hid for the 0.4 release
parent 0e9ca559
......@@ -7,8 +7,8 @@ Author: Isaac Jones <ijones@syntaxpolice.org>
Maintainer: Isaac Jones <ijones@syntaxpolice.org>
Homepage: http://www.haskell.org/cabal/
Description:
Common Architecture for Building Applications and Libraries:
a framework defining a common interface for authors to more
The Haskell Common Architecture for Building Applications and
Libraries: a framework defining a common interface for authors to more
easily build their Haskell applications in a portable way.
.
The Haskell Cabal is meant to be a part of a larger infrastructure
......
......@@ -122,7 +122,7 @@ defaultMainNoRead pkg_descr
exec "make"
CleanCmd -> do
(_, args) <- parseCleanArgs args []
(_, _, args) <- parseCleanArgs args []
no_extra_flags args
exec "make clean"
......@@ -139,7 +139,7 @@ defaultMainNoRead pkg_descr
exec "make register"
SDistCmd -> do
(_, args) <- parseSDistArgs args []
(_, _, args) <- parseSDistArgs args []
no_extra_flags args
exec "make dist"
......@@ -149,7 +149,7 @@ defaultMainNoRead pkg_descr
exec "make register"
UnregisterCmd -> do
(_, args) <- parseUnregisterArgs args []
(_, _, args) <- parseUnregisterArgs args []
no_extra_flags args
exec "make unregister"
......
......@@ -122,7 +122,7 @@ cmd_help = Option "h?" ["help"] (NoArg HelpFlag) "Show this help text"
cmd_verbose :: OptDescr (Flag a)
cmd_verbose = Option "v" ["verbose"] (OptArg verboseFlag "n") "Control verbosity (n is 0--5, normal verbosity level is 1, -v alone is equivalent to -v3)"
where
verboseFlag mb_s = Verbose (maybe 1 read mb_s)
verboseFlag mb_s = Verbose (maybe 3 read mb_s)
-- Do we have any other interesting global flags?
globalOptions :: [OptDescr (Flag a)]
......@@ -280,23 +280,8 @@ haddockCmd = Cmd {
cmdAction = HaddockCmd
}
parseHaddockArgs verbose args customOpts =
case getCmdOpt haddockCmd customOpts args of
(flags, _, []) | hasHelpFlag flags -> do
printCmdHelp haddockCmd customOpts
exitWith ExitSuccess
(flags, args', []) ->
return (updateBld flags verbose, unliftFlags flags, args')
(_, _, errs) -> do putStrLn "Errors: "
mapM_ putStrLn errs
exitWith (ExitFailure 1)
where
updateBld (fl:flags) verbose = updateBld flags $
case fl of
Verbose n -> n
_ -> error $ "Unexpected flag!"
updateBld [] t = t
parseHaddockArgs :: [String] -> [OptDescr a] -> IO (Int, [a], [String])
parseHaddockArgs = parseNoArgs haddockCmd
cleanCmd :: Cmd a
cleanCmd = Cmd {
......@@ -307,7 +292,7 @@ cleanCmd = Cmd {
cmdAction = CleanCmd
}
parseCleanArgs :: [String] -> [OptDescr a] -> IO ([a], [String])
parseCleanArgs :: [String] -> [OptDescr a] -> IO (Int, [a], [String])
parseCleanArgs = parseNoArgs cleanCmd
installCmd :: Cmd a
......@@ -391,7 +376,7 @@ sdistCmd = Cmd {
cmdAction = SDistCmd
}
parseSDistArgs :: [String] -> [OptDescr a] -> IO ([a], [String])
parseSDistArgs :: [String] -> [OptDescr a] -> IO (Int, [a], [String])
parseSDistArgs = parseNoArgs sdistCmd
registerCmd :: Cmd a
......@@ -437,21 +422,31 @@ unregisterCmd = Cmd {
cmdAction = UnregisterCmd
}
parseUnregisterArgs :: [String] -> [OptDescr a] -> IO ([a], [String])
parseUnregisterArgs :: [String] -> [OptDescr a] -> IO (Int, [a], [String])
parseUnregisterArgs = parseNoArgs unregisterCmd
-- |Helper function for commands with no arguments
parseNoArgs :: (Cmd a) -> [String] -> [OptDescr a] -> IO ([a], [String])
-- |Helper function for commands with no arguments except for verbose
-- and help.
parseNoArgs :: (Cmd a) -> [String] -> [OptDescr a] -> IO (Int, [a], [String])
parseNoArgs cmd args customOpts =
case getCmdOpt cmd customOpts args of
(flags, _, []) | hasHelpFlag flags -> do
printCmdHelp cmd customOpts
exitWith ExitSuccess
(flags, args', []) ->
return (unliftFlags flags, args')
return (updateCmd flags 0, unliftFlags flags, args')
(_, _, errs) -> do putStrLn "Errors: "
mapM_ putStrLn errs
exitWith (ExitFailure 1)
where
updateCmd (fl:flags) _ = updateCmd flags $
case fl of
Verbose n -> n
_ -> error $ "Unexpected flag!"
updateCmd [] t = t
#ifdef DEBUG
hunitTests :: [Test]
......
......@@ -48,7 +48,7 @@ module Distribution.Simple (
orLaterVersion, orEarlierVersion, betweenVersionsInclusive,
Extension(..), Dependency(..),
defaultMain, defaultMainNoRead, defaultMainWithHooks,
defaultUserHooks, -- UserHooks (..), emptyUserHooks, defaultHookedPackageDesc,
defaultUserHooks, UserHooks (..), emptyUserHooks, defaultHookedPackageDesc,
#ifdef DEBUG
simpleHunitTests
#endif
......@@ -189,7 +189,7 @@ defaultMainWorker pkg_descr_in action args hooks
writeInstalledConfig pkg_descr localbuildinfo
postHook postBuild
HaddockCmd -> do
(verbose, _, args) <- parseHaddockArgs 0 args []
(verbose, _, args) <- parseHaddockArgs args []
pkg_descr <- hookOrInput preBuild args
withLib pkg_descr ExitSuccess (\lib ->
do lbi <- getPersistBuildConfig
......@@ -201,15 +201,24 @@ defaultMainWorker pkg_descr_in action args hooks
inFiles <- sequence [moduleToFilePath [hsSourceDir bi] m ["hs", "lhs"]
| m <- exposedModules lib] >>= return . concat
mapM (mockCpp pkg_descr bi lbi tmpDir verbose) inFiles
setupMessage "Running Haddock" pkg_descr
let showPkg = showPackageId (package pkg_descr)
let prologName = showPkg ++ "-haddock-prolog.txt"
writeFile prologName ((description pkg_descr) ++ "\n")
setupMessage "Running Haddock for" pkg_descr
let outFiles = map (joinFileName tmpDir)
(map ((flip changeFileExt) "hs") inFiles)
code <- rawSystemPath verbose "haddock" (["-h", "-o", targetDir] ++ outFiles)
putStrLn $ "verbose: " ++ (show verbose)
code <- rawSystemPath verbose "haddock" (["-h",
"-o", targetDir,
"-t", showPkg,
"-p", prologName]
++ outFiles)
removeDirectoryRecursive tmpDir
-- removeFile prologName
when (code /= ExitSuccess) (exitWith code)
return code)
CleanCmd -> do
(_, args) <- parseCleanArgs args []
(verbose,_, args) <- parseCleanArgs args []
pkg_descr <- hookOrInput preClean args
localbuildinfo <- getPersistBuildConfig
let buildPref = buildDir localbuildinfo
......@@ -241,7 +250,7 @@ defaultMainWorker pkg_descr_in action args hooks
SDistCmd -> do
let distPref = "dist"
let srcPref = distPref `joinFileName` "src"
(_, args) <- parseSDistArgs args []
(verbose,_, args) <- parseSDistArgs args []
pkg_descr <- hookOrInput preSDist args
sdist srcPref distPref knownSuffixHandlers pkg_descr
postHook postSDist
......@@ -254,7 +263,7 @@ defaultMainWorker pkg_descr_in action args hooks
postHook postReg
UnregisterCmd -> do
(_, args) <- parseUnregisterArgs args []
(verbose,_, args) <- parseUnregisterArgs args []
pkg_descr <- hookOrInput preUnreg args
localbuildinfo <- getPersistBuildConfig
unregister pkg_descr localbuildinfo
......@@ -262,10 +271,6 @@ defaultMainWorker pkg_descr_in action args hooks
HelpCmd -> return ExitSuccess -- this is handled elsewhere
where
mJoinPaths :: Maybe FilePath -> FilePath -> Maybe FilePath
mJoinPaths f1 f2 = do f1' <- f1
let f2' = dropAbsolutePrefix f2
return $ (joinFileName f1' f2')
hookOrInput :: (UserHooks -> (b -> IO (Maybe PackageDescription)))
-> b
-> IO PackageDescription
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment