module Run (
doctest
#ifdef TEST
, doctest_
, Summary
, stripOptGhc
, expandDirs
#endif
) where
import Data.List
import Control.Applicative ((<$>))
import Control.Monad (when, unless)
import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)
import System.Environment (getEnvironment)
import System.Exit (exitFailure, exitSuccess)
import System.FilePath ((</>), takeExtension)
import System.IO
import qualified Control.Exception as E
import Panic
import PackageDBs
import Parse
import Help
import Runner
import qualified Interpreter
doctest :: [String] -> IO ()
doctest args0
| "--help" `elem` args0 = putStr usage
| "--version" `elem` args0 = printVersion
| otherwise = do
args <- concat <$> mapM expandDirs args0
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
packageDBArgs <- getPackageDBArgs
let addPackageConf = (packageDBArgs ++)
addDistArgs <- getAddDistArgs
r <- doctest_ (addDistArgs $ 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
expandDirs :: String -> IO [String]
expandDirs fp0 = do
isDir <- doesDirectoryExist fp0
if isDir
then findHaskellFiles fp0
else return [fp0]
where
findHaskellFiles dir = do
contents <- getDirectoryContents dir
concat <$> mapM go (filter (not . hidden) contents)
where
go name = do
isDir <- doesDirectoryExist fp
if isDir
then findHaskellFiles fp
else if isHaskellFile fp
then return [fp]
else return []
where
fp = dir </> name
hidden ('.':_) = True
hidden _ = False
isHaskellFile fp = takeExtension fp `elem` [".hs", ".lhs"]
getAddDistArgs :: IO ([String] -> [String])
getAddDistArgs = do
env <- getEnvironment
let dist =
case lookup "HASKELL_DIST_DIR" env of
Nothing -> "dist"
Just x -> x
autogen = dist ++ "/build/autogen/"
cabalMacros = autogen ++ "cabal_macros.h"
dirExists <- doesDirectoryExist autogen
if dirExists
then do
fileExists <- doesFileExist cabalMacros
return $ \rest ->
concat ["-i", dist, "/build/autogen/"]
: "-optP-include"
: (if fileExists
then (concat ["-optP", dist, "/build/autogen/cabal_macros.h"]:)
else id) rest
else return id
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