module Run (
doctest
#ifdef TEST
, doctest_
, Summary
, stripOptGhc
#endif
) where
import Data.List
import Control.Monad (when, unless)
import System.Exit (exitFailure, exitSuccess)
import System.IO
import System.Environment (getEnvironment)
import Control.Applicative
import qualified Control.Exception as E
import Panic
import Parse
import Help
import Runner
import qualified Interpreter
ghcPackageDbFlag :: String
#if __GLASGOW_HASKELL__ >= 706
ghcPackageDbFlag = "-package-db"
#else
ghcPackageDbFlag = "-package-conf"
#endif
doctest :: [String] -> IO ()
doctest args
| "--help" `elem` args = putStr usage
| "--version" `elem` args = printVersion
| otherwise = do
packageConf <- lookup "HASKELL_PACKAGE_SANDBOX" <$> getEnvironment
let addPackageConf = case packageConf of
Nothing -> id
Just p -> \rest -> ghcPackageDbFlag : p : rest
i <- Interpreter.interpreterSupported
unless i $ do
hPutStrLn stderr "WARNING: GHC does not support --interactive, skipping tests"
exitSuccess
let (f, args_) = stripOptGhc args
when f $ do
hPutStrLn stderr "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly."
hFlush stderr
r <- doctest_ (addPackageConf args_) `E.catch` \e -> do
case fromException e of
Just (UsageError err) -> do
hPutStrLn stderr ("doctest: " ++ err)
hPutStrLn stderr "Try `doctest --help' for more information."
exitFailure
_ -> E.throwIO e
when (not $ isSuccess r) exitFailure
isSuccess :: Summary -> Bool
isSuccess s = sErrors s == 0 && sFailures s == 0
stripOptGhc :: [String] -> (Bool, [String])
stripOptGhc = go
where
go args = case args of
[] -> (False, [])
"--optghc" : opt : rest -> (True, opt : snd (go rest))
opt : rest -> maybe (fmap (opt :)) (\x (_, xs) -> (True, x :xs)) (stripPrefix "--optghc=" opt) (go rest)
doctest_ :: [String] -> IO Summary
doctest_ args = do
modules <- getDocTests args
Interpreter.withInterpreter args $ \repl -> do
runModules repl modules