module Test.Chell.Types where
import qualified Control.Exception
import Control.Exception (SomeException, Handler(..), catches, throwIO)
import qualified Data.Text
import Data.Text (Text)
import System.Timeout (timeout)
data Test = Test Text (TestOptions -> IO TestResult)
instance Show Test where
show (Test name _) = "<Test " ++ show name ++ ">"
data TestOptions = TestOptions
{
testOptionSeed :: Int
, testOptionTimeout :: Maybe Int
}
deriving (Show, Eq)
defaultTestOptions :: TestOptions
defaultTestOptions = TestOptions
{ testOptionSeed = 0
, testOptionTimeout = Nothing
}
testName :: Test -> Text
testName (Test name _) = name
runTest :: Test -> TestOptions -> IO TestResult
runTest (Test _ io) options = handleJankyIO options (io options) (return [])
handleJankyIO :: TestOptions -> IO TestResult -> IO [(Text, Text)] -> IO TestResult
handleJankyIO opts getResult getNotes = do
let withTimeout = case testOptionTimeout opts of
Just time -> timeout (time * 1000)
Nothing -> fmap Just
let hitTimeout = Data.Text.pack str where
str = "Test timed out after " ++ show time ++ " milliseconds"
Just time = testOptionTimeout opts
tried <- withTimeout (try getResult)
case tried of
Just (Right ret) -> return ret
Nothing -> do
notes <- getNotes
return (TestAborted notes hitTimeout)
Just (Left err) -> do
notes <- getNotes
return (TestAborted notes (Data.Text.pack err))
try :: IO a -> IO (Either String a)
try io = catches (fmap Right io) [Handler handleAsync, Handler handleExc] where
handleAsync :: Control.Exception.AsyncException -> IO a
handleAsync = throwIO
handleExc :: SomeException -> IO (Either String a)
handleExc exc = return (Left ("Test aborted due to exception: " ++ show exc))
data TestResult
= TestPassed [(Text, Text)]
| TestSkipped
| TestFailed [(Text, Text)] [Failure]
| TestAborted [(Text, Text)] Text
deriving (Show, Eq)
data Failure = Failure (Maybe Location) Text
deriving (Show, Eq)
data Location = Location
{ locationFile :: Text
, locationModule :: Text
, locationLine :: Integer
}
deriving (Show, Eq)
data ColorMode
= ColorModeAuto
| ColorModeAlways
| ColorModeNever
deriving (Enum)
data Suite = Suite Text [Suite]
| SuiteTest Test
instance Show Suite where
show s = "<Suite " ++ show (suiteName s) ++ ">"
test :: Test -> Suite
test = SuiteTest
suite :: Text -> [Suite] -> Suite
suite = Suite
suiteName :: Suite -> Text
suiteName (Suite name _) = name
suiteName (SuiteTest t) = testName t
suiteTests :: Suite -> [Test]
suiteTests = loop "" where
loop prefix s = let
name = if Data.Text.null prefix
then suiteName s
else Data.Text.concat [prefix, ".", suiteName s]
in case s of
Suite _ suites -> concatMap (loop name) suites
SuiteTest (Test _ io) -> [Test name io]