module Test.Chell.Types
( Test
, test
, testName
, TestOptions
, defaultTestOptions
, testOptionSeed
, testOptionTimeout
, TestResult(TestPassed, TestSkipped, TestFailed, TestAborted)
, Failure
, failure
, failureLocation
, failureMessage
, Location
, location
, locationFile
, locationModule
, locationLine
, Suite
, suite
, suiteName
, suiteTests
, SuiteOrTest
, skipIf
, skipWhen
, runTest
, handleJankyIO
) where
import qualified Control.Exception
import Control.Exception (SomeException, Handler(..), catches, throwIO)
import System.Timeout (timeout)
data Test =
Test String (TestOptions -> IO TestResult)
instance Show Test
where
showsPrec :: Int -> Test -> ShowS
showsPrec Int
d (Test String
name TestOptions -> IO TestResult
_) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"Test " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows String
name)
test :: String -> (TestOptions -> IO TestResult) -> Test
test :: String -> (TestOptions -> IO TestResult) -> Test
test = String -> (TestOptions -> IO TestResult) -> Test
Test
testName :: Test -> String
testName :: Test -> String
testName (Test String
name TestOptions -> IO TestResult
_) = String
name
data TestOptions =
TestOptions
{
TestOptions -> Int
testOptionSeed :: Int
, TestOptions -> Maybe Int
testOptionTimeout :: Maybe Int
}
deriving (Int -> TestOptions -> ShowS
[TestOptions] -> ShowS
TestOptions -> String
(Int -> TestOptions -> ShowS)
-> (TestOptions -> String)
-> ([TestOptions] -> ShowS)
-> Show TestOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestOptions] -> ShowS
$cshowList :: [TestOptions] -> ShowS
show :: TestOptions -> String
$cshow :: TestOptions -> String
showsPrec :: Int -> TestOptions -> ShowS
$cshowsPrec :: Int -> TestOptions -> ShowS
Show, TestOptions -> TestOptions -> Bool
(TestOptions -> TestOptions -> Bool)
-> (TestOptions -> TestOptions -> Bool) -> Eq TestOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestOptions -> TestOptions -> Bool
$c/= :: TestOptions -> TestOptions -> Bool
== :: TestOptions -> TestOptions -> Bool
$c== :: TestOptions -> TestOptions -> Bool
Eq)
defaultTestOptions :: TestOptions
defaultTestOptions :: TestOptions
defaultTestOptions =
TestOptions :: Int -> Maybe Int -> TestOptions
TestOptions
{ testOptionSeed :: Int
testOptionSeed = Int
0
, testOptionTimeout :: Maybe Int
testOptionTimeout = Maybe Int
forall a. Maybe a
Nothing
}
data TestResult
= TestPassed [(String, String)]
| TestSkipped
| TestFailed [(String, String)] [Failure]
| TestAborted [(String, String)] String
| TestResultCaseMustHaveDefault
deriving (Int -> TestResult -> ShowS
[TestResult] -> ShowS
TestResult -> String
(Int -> TestResult -> ShowS)
-> (TestResult -> String)
-> ([TestResult] -> ShowS)
-> Show TestResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestResult] -> ShowS
$cshowList :: [TestResult] -> ShowS
show :: TestResult -> String
$cshow :: TestResult -> String
showsPrec :: Int -> TestResult -> ShowS
$cshowsPrec :: Int -> TestResult -> ShowS
Show, TestResult -> TestResult -> Bool
(TestResult -> TestResult -> Bool)
-> (TestResult -> TestResult -> Bool) -> Eq TestResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestResult -> TestResult -> Bool
$c/= :: TestResult -> TestResult -> Bool
== :: TestResult -> TestResult -> Bool
$c== :: TestResult -> TestResult -> Bool
Eq)
data Failure =
Failure
{
Failure -> Maybe Location
failureLocation :: Maybe Location
, Failure -> String
failureMessage :: String
}
deriving (Int -> Failure -> ShowS
[Failure] -> ShowS
Failure -> String
(Int -> Failure -> ShowS)
-> (Failure -> String) -> ([Failure] -> ShowS) -> Show Failure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Failure] -> ShowS
$cshowList :: [Failure] -> ShowS
show :: Failure -> String
$cshow :: Failure -> String
showsPrec :: Int -> Failure -> ShowS
$cshowsPrec :: Int -> Failure -> ShowS
Show, Failure -> Failure -> Bool
(Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool) -> Eq Failure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Failure -> Failure -> Bool
$c/= :: Failure -> Failure -> Bool
== :: Failure -> Failure -> Bool
$c== :: Failure -> Failure -> Bool
Eq)
failure :: Failure
failure :: Failure
failure = Maybe Location -> String -> Failure
Failure Maybe Location
forall a. Maybe a
Nothing String
""
data Location =
Location
{
Location -> String
locationFile :: String
, Location -> String
locationModule :: String
, Location -> Maybe Integer
locationLine :: Maybe Integer
}
deriving (Int -> Location -> ShowS
[Location] -> ShowS
Location -> String
(Int -> Location -> ShowS)
-> (Location -> String) -> ([Location] -> ShowS) -> Show Location
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Location] -> ShowS
$cshowList :: [Location] -> ShowS
show :: Location -> String
$cshow :: Location -> String
showsPrec :: Int -> Location -> ShowS
$cshowsPrec :: Int -> Location -> ShowS
Show, Location -> Location -> Bool
(Location -> Location -> Bool)
-> (Location -> Location -> Bool) -> Eq Location
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Location -> Location -> Bool
$c/= :: Location -> Location -> Bool
== :: Location -> Location -> Bool
$c== :: Location -> Location -> Bool
Eq)
location :: Location
location :: Location
location = String -> String -> Maybe Integer -> Location
Location String
"" String
"" Maybe Integer
forall a. Maybe a
Nothing
data Suite =
Suite String [Test]
deriving Int -> Suite -> ShowS
[Suite] -> ShowS
Suite -> String
(Int -> Suite -> ShowS)
-> (Suite -> String) -> ([Suite] -> ShowS) -> Show Suite
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Suite] -> ShowS
$cshowList :: [Suite] -> ShowS
show :: Suite -> String
$cshow :: Suite -> String
showsPrec :: Int -> Suite -> ShowS
$cshowsPrec :: Int -> Suite -> ShowS
Show
class SuiteOrTest a
where
skipIf_ :: Bool -> a -> a
skipWhen_ :: IO Bool -> a -> a
instance SuiteOrTest Suite
where
skipIf_ :: Bool -> Suite -> Suite
skipIf_ Bool
skip s :: Suite
s@(Suite String
name [Test]
children) =
if Bool
skip
then String -> [Test] -> Suite
Suite String
name ((Test -> Test) -> [Test] -> [Test]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Test -> Test
forall a. SuiteOrTest a => Bool -> a -> a
skipIf_ Bool
skip) [Test]
children)
else Suite
s
skipWhen_ :: IO Bool -> Suite -> Suite
skipWhen_ IO Bool
p (Suite String
name [Test]
children) =
String -> [Test] -> Suite
Suite String
name ((Test -> Test) -> [Test] -> [Test]
forall a b. (a -> b) -> [a] -> [b]
map (IO Bool -> Test -> Test
forall a. SuiteOrTest a => IO Bool -> a -> a
skipWhen_ IO Bool
p) [Test]
children)
instance SuiteOrTest Test
where
skipIf_ :: Bool -> Test -> Test
skipIf_ Bool
skip t :: Test
t@(Test String
name TestOptions -> IO TestResult
_) =
if Bool
skip
then String -> (TestOptions -> IO TestResult) -> Test
Test String
name (\TestOptions
_ -> TestResult -> IO TestResult
forall (m :: * -> *) a. Monad m => a -> m a
return TestResult
TestSkipped)
else Test
t
skipWhen_ :: IO Bool -> Test -> Test
skipWhen_ IO Bool
p (Test String
name TestOptions -> IO TestResult
io) =
String -> (TestOptions -> IO TestResult) -> Test
Test String
name
(\TestOptions
opts ->
do
Bool
skip <- IO Bool
p
if Bool
skip then TestResult -> IO TestResult
forall (m :: * -> *) a. Monad m => a -> m a
return TestResult
TestSkipped else TestOptions -> IO TestResult
io TestOptions
opts
)
skipIf :: SuiteOrTest a => Bool -> a -> a
skipIf :: Bool -> a -> a
skipIf = Bool -> a -> a
forall a. SuiteOrTest a => Bool -> a -> a
skipIf_
skipWhen :: SuiteOrTest a => IO Bool -> a -> a
skipWhen :: IO Bool -> a -> a
skipWhen = IO Bool -> a -> a
forall a. SuiteOrTest a => IO Bool -> a -> a
skipWhen_
suite :: String -> [Test] -> Suite
suite :: String -> [Test] -> Suite
suite = String -> [Test] -> Suite
Suite
suiteName :: Suite -> String
suiteName :: Suite -> String
suiteName (Suite String
name [Test]
_) = String
name
suiteTests :: Suite -> [Test]
suiteTests :: Suite -> [Test]
suiteTests = String -> Suite -> [Test]
go String
""
where
prefixed :: String -> ShowS
prefixed String
prefix String
str =
if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
prefix
then String
str
else String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str
go :: String -> Suite -> [Test]
go String
prefix (Suite String
name [Test]
children) =
(Test -> [Test]) -> [Test] -> [Test]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> Test -> [Test]
step (String -> ShowS
prefixed String
prefix String
name)) [Test]
children
step :: String -> Test -> [Test]
step String
prefix (Test String
name TestOptions -> IO TestResult
io) = [String -> (TestOptions -> IO TestResult) -> Test
Test (String -> ShowS
prefixed String
prefix String
name) TestOptions -> IO TestResult
io]
runTest :: Test -> TestOptions -> IO TestResult
runTest :: Test -> TestOptions -> IO TestResult
runTest (Test String
_ TestOptions -> IO TestResult
io) TestOptions
options = TestOptions
-> IO TestResult -> IO [(String, String)] -> IO TestResult
handleJankyIO TestOptions
options (TestOptions -> IO TestResult
io TestOptions
options) ([(String, String)] -> IO [(String, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
handleJankyIO :: TestOptions -> IO TestResult -> IO [(String, String)] -> IO TestResult
handleJankyIO :: TestOptions
-> IO TestResult -> IO [(String, String)] -> IO TestResult
handleJankyIO TestOptions
opts IO TestResult
getResult IO [(String, String)]
getNotes =
do
let
withTimeout :: IO a -> IO (Maybe a)
withTimeout =
case TestOptions -> Maybe Int
testOptionTimeout TestOptions
opts of
Just Int
time -> Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
time Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
Maybe Int
Nothing -> (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just
let
hitTimeout :: String
hitTimeout = String
str
where
str :: String
str = String
"Test timed out after " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
time String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" milliseconds"
Just Int
time = TestOptions -> Maybe Int
testOptionTimeout TestOptions
opts
Maybe (Either String TestResult)
tried <- IO (Either String TestResult)
-> IO (Maybe (Either String TestResult))
forall a. IO a -> IO (Maybe a)
withTimeout (IO TestResult -> IO (Either String TestResult)
forall a. IO a -> IO (Either String a)
try IO TestResult
getResult)
case Maybe (Either String TestResult)
tried of
Just (Right TestResult
ret) -> TestResult -> IO TestResult
forall (m :: * -> *) a. Monad m => a -> m a
return TestResult
ret
Maybe (Either String TestResult)
Nothing ->
do
[(String, String)]
notes <- IO [(String, String)]
getNotes
TestResult -> IO TestResult
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, String)] -> String -> TestResult
TestAborted [(String, String)]
notes String
hitTimeout)
Just (Left String
err) ->
do
[(String, String)]
notes <- IO [(String, String)]
getNotes
TestResult -> IO TestResult
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, String)] -> String -> TestResult
TestAborted [(String, String)]
notes String
err)
try :: IO a -> IO (Either String a)
try :: IO a -> IO (Either String a)
try IO a
io = IO (Either String a)
-> [Handler (Either String a)] -> IO (Either String a)
forall a. IO a -> [Handler a] -> IO a
catches ((a -> Either String a) -> IO a -> IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either String a
forall a b. b -> Either a b
Right IO a
io) [(AsyncException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler AsyncException -> IO (Either String a)
forall a. AsyncException -> IO a
handleAsync, (SomeException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler SomeException -> IO (Either String a)
forall a. SomeException -> IO (Either String a)
handleExc]
where
handleAsync :: Control.Exception.AsyncException -> IO a
handleAsync :: AsyncException -> IO a
handleAsync = AsyncException -> IO a
forall e a. Exception e => e -> IO a
throwIO
handleExc :: SomeException -> IO (Either String a)
handleExc :: SomeException -> IO (Either String a)
handleExc SomeException
exc = Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left (String
"Test aborted due to exception: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
exc))