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)

-- | A 'Test' is, essentially, an IO action that returns a 'TestResult'. Tests
-- are aggregated into suites (see 'Suite').
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)

-- | Define a test, with the given name and implementation.
test :: String -> (TestOptions -> IO TestResult) -> Test
test :: String -> (TestOptions -> IO TestResult) -> Test
test = String -> (TestOptions -> IO TestResult) -> Test
Test

-- | Get the name a test was given when it was defined; see 'test'.
testName :: Test -> String
testName :: Test -> String
testName (Test String
name TestOptions -> IO TestResult
_) = String
name

-- | Test options are passed to each test, and control details about how the
-- test should be run.
data TestOptions =
  TestOptions
    {

    -- | Get the RNG seed for this test run. The seed is generated once, in
    -- 'defaultMain', and used for all tests. It is also logged to reports
    -- using a note.
    --
    -- When using 'defaultMain', users may specify a seed using the
    -- @--seed@ command-line option.
    --
    -- 'testOptionSeed' is a field accessor, and can be used to update
    -- a 'TestOptions' value.
      TestOptions -> Int
testOptionSeed :: Int

    -- | An optional timeout, in millseconds. Tests which run longer than
    -- this timeout will be aborted.
    --
    -- When using 'defaultMain', users may specify a timeout using the
    -- @--timeout@ command-line option.
    --
    -- 'testOptionTimeout' is a field accessor, and can be used to update
    -- a 'TestOptions' value.
    , 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)

-- | Default test options.
--
-- >$ ghci
-- >Prelude> import Test.Chell
-- >
-- >Test.Chell> testOptionSeed defaultTestOptions
-- >0
-- >
-- >Test.Chell> testOptionTimeout defaultTestOptions
-- >Nothing
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
    }

-- | The result of running a test.
--
-- To support future extensions to the testing API, any users of this module
-- who pattern-match against the 'TestResult' constructors should include a
-- default case. If no default case is provided, a warning will be issued.
data TestResult
  -- | The test passed, and generated the given notes.
  = TestPassed [(String, String)]

  -- | The test did not run, because it was skipped with 'skipIf'
  -- or 'skipWhen'.
  | TestSkipped

  -- | The test failed, generating the given notes and failures.
  | TestFailed [(String, String)] [Failure]

  -- | The test aborted with an error message, and generated the given
  -- notes.
  | TestAborted [(String, String)] String

  -- Not exported; used to generate GHC warnings for users who don't
  -- provide a default case.
  | 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)

-- | Contains details about a test failure.
data Failure =
  Failure
    {
    -- | If given, the location of the failing assertion, expectation,
    -- etc.
    --
    -- 'failureLocation' is a field accessor, and can be used to update
    -- a 'Failure' value.
      Failure -> Maybe Location
failureLocation :: Maybe Location

    -- | If given, a message which explains why the test failed.
    --
    -- 'failureMessage' is a field accessor, and can be used to update
    -- a 'Failure' value.
    , 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)

-- | An empty 'Failure'; use the field accessors to populate this value.
failure :: Failure
failure :: Failure
failure = Maybe Location -> String -> Failure
Failure Maybe Location
forall a. Maybe a
Nothing String
""

-- | Contains details about a location in the test source file.
data Location =
  Location
    {
    -- | A path to a source file, or empty if not provided.
    --
    -- 'locationFile' is a field accessor, and can be used to update
    -- a 'Location' value.
      Location -> String
locationFile :: String

    -- | A Haskell module name, or empty if not provided.
    --
    -- 'locationModule' is a field accessor, and can be used to update
    -- a 'Location' value.
    , Location -> String
locationModule :: String

    -- | A line number, or Nothing if not provided.
    --
    -- 'locationLine' is a field accessor, and can be used to update
    -- a 'Location' value.
    , 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)

-- | An empty 'Location'; use the field accessors to populate this value.
location :: Location
location :: Location
location = String -> String -> Maybe Integer -> Location
Location String
"" String
"" Maybe Integer
forall a. Maybe a
Nothing

-- | A suite is a named collection of tests.
--
-- Note: earlier versions of Chell permitted arbitrary nesting of test suites.
-- This feature proved too unwieldy, and was removed. A similar result can be
-- achieved with 'suiteTests'; see the documentation for 'suite'.
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
            )

-- | Conditionally skip tests. Use this to avoid commenting out tests
-- which are currently broken, or do not work on the current platform.
--
-- @
--tests :: Suite
--tests = 'suite' \"tests\"
--    [ test_Foo
--    , 'skipIf' builtOnUnix test_WindowsSpecific
--    , test_Bar
--    ]
-- @
--
skipIf :: SuiteOrTest a => Bool -> a -> a
skipIf :: Bool -> a -> a
skipIf = Bool -> a -> a
forall a. SuiteOrTest a => Bool -> a -> a
skipIf_

-- | Conditionally skip tests, depending on the result of a runtime check. The
-- predicate is checked before each test is started.
--
-- @
--tests :: Suite
--tests = 'suite' \"tests\"
--    [ test_Foo
--    , 'skipWhen' noNetwork test_PingGoogle
--    , test_Bar
--    ]
-- @
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_

-- | Define a new 'Suite', with the given name and children.
--
-- Note: earlier versions of Chell permitted arbitrary nesting of test suites.
-- This feature proved too unwieldy, and was removed. A similar result can be
-- achieved with 'suiteTests':
--
-- @
--test_Addition :: Test
--test_Subtraction :: Test
--test_Show :: Test
--
--suite_Math :: Suite
--suite_Math = 'suite' \"math\"
--    [ test_Addition
--    , test_Subtraction
--    ]
--
--suite_Prelude :: Suite
--suite_Prelude = 'suite' \"prelude\"
--    (
--      [ test_Show
--      ]
--      ++ suiteTests suite_Math
--    )
-- @
suite :: String -> [Test] -> Suite
suite :: String -> [Test] -> Suite
suite = String -> [Test] -> Suite
Suite

-- | Get a suite's name. Suite names may be any string, but are typically
-- plain ASCII so users can easily type them on the command line.
--
-- >$ ghci chell-example.hs
-- >Ok, modules loaded: Main.
-- >
-- >*Main> suiteName tests_Math
-- >"math"
suiteName :: Suite -> String
suiteName :: Suite -> String
suiteName (Suite String
name [Test]
_) = String
name

-- | Get the full list of tests contained within this 'Suite'. Each test is
-- given its full name within the test hierarchy, where names are separated
-- by periods.
--
-- >$ ghci chell-example.hs
-- >Ok, modules loaded: Main.
-- >
-- >*Main> suiteTests tests_Math
-- >[Test "math.addition",Test "math.subtraction"]
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]

-- | Run a test, wrapped in error handlers. This will return 'TestAborted' if
-- the test throws an exception or times out.
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))