{-# LANGUAGE CPP #-}
module Run (
doctest
, doctestWithRepl
, Config(..)
, defaultConfig
, doctestWith
, Result
, Summary(..)
, isSuccess
, evaluateResult
, doctestWithResult
, runDocTests
#ifdef TEST
, expandDirs
#endif
) where
import Imports
import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)
import System.Environment (getEnvironment)
import System.Exit (exitFailure, exitSuccess)
import System.FilePath ((</>), takeExtension)
import System.IO
import System.IO.CodePage (withCP65001)
import System.Process (rawSystem)
import qualified Control.Exception as E
#if __GLASGOW_HASKELL__ < 900
import Panic
#else
import GHC.Utils.Panic
#endif
import PackageDBs
import Parse
import Options hiding (Result(..))
import qualified Options
import Runner
import Location
import qualified Interpreter
doctest :: [String] -> IO ()
doctest :: [String] -> IO ()
doctest = (String, [String]) -> [String] -> IO ()
doctestWithRepl (Config -> (String, [String])
repl Config
defaultConfig)
doctestWithRepl :: (String, [String]) -> [String] -> IO ()
doctestWithRepl :: (String, [String]) -> [String] -> IO ()
doctestWithRepl (String, [String])
repl [String]
args0 = case [String] -> Result Run
parseOptions [String]
args0 of
Options.ProxyToGhc [String]
args -> String -> [String] -> IO ExitCode
rawSystem String
Interpreter.ghc [String]
args IO ExitCode -> (ExitCode -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExitCode -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO
Options.Output String
s -> String -> IO ()
putStr String
s
Options.Result (Run [String]
warnings Bool
magicMode Config
config) -> do
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
stderr) [String]
warnings
Handle -> IO ()
hFlush Handle
stderr
Bool
i <- IO Bool
Interpreter.interpreterSupported
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
i (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"WARNING: GHC does not support --interactive, skipping tests"
IO ()
forall a. IO a
exitSuccess
[String]
opts <- case Bool
magicMode of
Bool
False -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> [String]
ghcOptions Config
config)
Bool
True -> do
[String]
expandedArgs <- [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO [String]
expandDirs (Config -> [String]
ghcOptions Config
config)
[String]
packageDBArgs <- IO [String]
getPackageDBArgs
[String] -> [String]
addDistArgs <- IO ([String] -> [String])
getAddDistArgs
[String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
addDistArgs ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
packageDBArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
expandedArgs)
Config -> IO ()
doctestWith Config
config{(String, [String])
repl :: (String, [String])
repl :: (String, [String])
repl, ghcOptions :: [String]
ghcOptions = [String]
opts}
expandDirs :: String -> IO [String]
expandDirs :: String -> IO [String]
expandDirs String
fp0 = do
Bool
isDir <- String -> IO Bool
doesDirectoryExist String
fp0
if Bool
isDir
then String -> IO [String]
findHaskellFiles String
fp0
else [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
fp0]
where
findHaskellFiles :: String -> IO [String]
findHaskellFiles String
dir = do
[String]
contents <- String -> IO [String]
getDirectoryContents String
dir
[[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO [String]
go ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
hidden) [String]
contents)
where
go :: String -> IO [String]
go String
name = do
Bool
isDir <- String -> IO Bool
doesDirectoryExist String
fp
if Bool
isDir
then String -> IO [String]
findHaskellFiles String
fp
else if String -> Bool
isHaskellFile String
fp
then [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
fp]
else [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
where
fp :: String
fp = String
dir String -> String -> String
</> String
name
hidden :: String -> Bool
hidden (Char
'.':String
_) = Bool
True
hidden String
_ = Bool
False
isHaskellFile :: String -> Bool
isHaskellFile String
fp = String -> String
takeExtension String
fp String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".hs", String
".lhs"]
getAddDistArgs :: IO ([String] -> [String])
getAddDistArgs :: IO ([String] -> [String])
getAddDistArgs = do
[(String, String)]
env <- IO [(String, String)]
getEnvironment
let dist :: String
dist = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"dist" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"HASKELL_DIST_DIR" [(String, String)]
env
autogen :: String
autogen = String
dist String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/build/autogen/"
cabalMacros :: String
cabalMacros = String
autogen String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"cabal_macros.h"
Bool
dirExists <- String -> IO Bool
doesDirectoryExist String
autogen
if Bool
dirExists
then do
Bool
fileExists <- String -> IO Bool
doesFileExist String
cabalMacros
([String] -> [String]) -> IO ([String] -> [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([String] -> [String]) -> IO ([String] -> [String]))
-> ([String] -> [String]) -> IO ([String] -> [String])
forall a b. (a -> b) -> a -> b
$ \[String]
rest ->
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"-i", String
dist, String
"/build/autogen/"]
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"-optP-include"
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (if Bool
fileExists
then ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"-optP", String
dist, String
"/build/autogen/cabal_macros.h"]String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
else [String] -> [String]
forall a. a -> a
id) [String]
rest
else ([String] -> [String]) -> IO ([String] -> [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String] -> [String]
forall a. a -> a
id
doctestWith :: Config -> IO ()
doctestWith :: Config -> IO ()
doctestWith = Config -> IO Result
doctestWithResult (Config -> IO Result) -> (Result -> IO ()) -> Config -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Result -> IO ()
evaluateResult
type Result = Summary
isSuccess :: Result -> Bool
isSuccess :: Result -> Bool
isSuccess Result
s = Result -> Int
sErrors Result
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Result -> Int
sFailures Result
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
evaluateResult :: Result -> IO ()
evaluateResult :: Result -> IO ()
evaluateResult Result
r = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Result -> Bool
isSuccess Result
r) IO ()
forall a. IO a
exitFailure
doctestWithResult :: Config -> IO Result
doctestWithResult :: Config -> IO Result
doctestWithResult Config
config = do
([String] -> IO [Module [Located DocTest]]
extractDocTests (Config -> [String]
ghcOptions Config
config) IO [Module [Located DocTest]]
-> ([Module [Located DocTest]] -> IO Result) -> IO Result
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> [Module [Located DocTest]] -> IO Result
runDocTests Config
config) IO Result -> (SomeException -> IO Result) -> IO Result
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \SomeException
e -> do
case SomeException -> Maybe GhcException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just (UsageError String
err) -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"doctest: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Try `doctest --help' for more information."
IO Result
forall a. IO a
exitFailure
Maybe GhcException
_ -> SomeException -> IO Result
forall e a. Exception e => e -> IO a
E.throwIO SomeException
e
runDocTests :: Config -> [Module [Located DocTest]] -> IO Result
runDocTests :: Config -> [Module [Located DocTest]] -> IO Result
runDocTests Config{Bool
[String]
(String, [String])
repl :: Config -> (String, [String])
ghcOptions :: Config -> [String]
ghcOptions :: [String]
fastMode :: Bool
preserveIt :: Bool
verbose :: Bool
repl :: (String, [String])
fastMode :: Config -> Bool
preserveIt :: Config -> Bool
verbose :: Config -> Bool
..} [Module [Located DocTest]]
modules = do
(String, [String]) -> (Interpreter -> IO Result) -> IO Result
forall a. (String, [String]) -> (Interpreter -> IO a) -> IO a
Interpreter.withInterpreter (([String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
ghcOptions) ([String] -> [String]) -> (String, [String]) -> (String, [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String, [String])
repl) ((Interpreter -> IO Result) -> IO Result)
-> (Interpreter -> IO Result) -> IO Result
forall a b. (a -> b) -> a -> b
$ \ Interpreter
interpreter -> IO Result -> IO Result
forall a. IO a -> IO a
withCP65001 (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ do
Bool
-> Bool
-> Bool
-> Interpreter
-> [Module [Located DocTest]]
-> IO Result
runModules Bool
fastMode Bool
preserveIt Bool
verbose Interpreter
interpreter [Module [Located DocTest]]
modules