{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- | This module defines how to run a test suite
module Test.Syd.Runner
  ( module Test.Syd.Runner,
    module Test.Syd.Runner.Asynchronous,
    module Test.Syd.Runner.Synchronous,
  )
where

import Control.Concurrent (getNumCapabilities)
import System.Environment
import System.Mem (performGC)
import Test.Syd.Def
import Test.Syd.OptParse
import Test.Syd.Output
import Test.Syd.Run
import Test.Syd.Runner.Asynchronous
import Test.Syd.Runner.Synchronous
import Test.Syd.SpecDef
import Text.Printf

sydTestResult :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestResult :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestResult Settings
sets TestDefM '[] () r
spec = do
  let totalIterations :: Maybe Int
totalIterations = case Settings -> Iterations
settingIterations Settings
sets of
        Iterations
OneIteration -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
        Iterations Int
i -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
        Iterations
Continuous -> Maybe Int
forall a. Maybe a
Nothing
  case Maybe Int
totalIterations of
    Just Int
1 -> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
forall r. Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestOnce Settings
sets TestDefM '[] () r
spec
    Maybe Int
_ -> Maybe Int
-> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
forall r.
Maybe Int
-> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestIterations Maybe Int
totalIterations Settings
sets TestDefM '[] () r
spec

sydTestOnce :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestOnce :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestOnce Settings
sets TestDefM '[] () r
spec = do
  TestForest '[] ()
specForest <- Settings -> TestDefM '[] () r -> IO (TestForest '[] ())
forall (a :: [*]) b c.
Settings -> TestDefM a b c -> IO (TestForest a b)
execTestDefM Settings
sets TestDefM '[] () r
spec
  [String] -> IO (Timed ResultForest) -> IO (Timed ResultForest)
forall a. [String] -> IO a -> IO a
withArgs [] (IO (Timed ResultForest) -> IO (Timed ResultForest))
-> IO (Timed ResultForest) -> IO (Timed ResultForest)
forall a b. (a -> b) -> a -> b
$ case Settings -> Threads
settingThreads Settings
sets of
    Threads
Synchronous -> Maybe Bool -> Bool -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestInterleavedWithOutputSynchronously (Settings -> Maybe Bool
settingColour Settings
sets) (Settings -> Bool
settingFailFast Settings
sets) TestForest '[] ()
specForest
    Threads
ByCapabilities -> do
      Int
i <- IO Int
getNumCapabilities
      Maybe Bool
-> Bool -> Int -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestInterleavedWithOutputAsynchronously (Settings -> Maybe Bool
settingColour Settings
sets) (Settings -> Bool
settingFailFast Settings
sets) Int
i TestForest '[] ()
specForest
    Asynchronous Int
i ->
      Maybe Bool
-> Bool -> Int -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestInterleavedWithOutputAsynchronously (Settings -> Maybe Bool
settingColour Settings
sets) (Settings -> Bool
settingFailFast Settings
sets) Int
i TestForest '[] ()
specForest

sydTestIterations :: Maybe Int -> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestIterations :: Maybe Int
-> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestIterations Maybe Int
totalIterations Settings
sets TestDefM '[] () r
spec =
  [String] -> IO (Timed ResultForest) -> IO (Timed ResultForest)
forall a. [String] -> IO a -> IO a
withArgs [] (IO (Timed ResultForest) -> IO (Timed ResultForest))
-> IO (Timed ResultForest) -> IO (Timed ResultForest)
forall a b. (a -> b) -> a -> b
$ do
    Int
nbCapabilities <- IO Int
getNumCapabilities

    let runOnce :: Settings -> IO (Timed ResultForest)
runOnce Settings
sets_ = do
          TestForest '[] ()
specForest <- Settings -> TestDefM '[] () r -> IO (TestForest '[] ())
forall (a :: [*]) b c.
Settings -> TestDefM a b c -> IO (TestForest a b)
execTestDefM Settings
sets_ TestDefM '[] () r
spec
          Timed ResultForest
r <- IO ResultForest -> IO (Timed ResultForest)
forall (m :: * -> *) a. MonadIO m => m a -> m (Timed a)
timeItT (IO ResultForest -> IO (Timed ResultForest))
-> IO ResultForest -> IO (Timed ResultForest)
forall a b. (a -> b) -> a -> b
$ case Settings -> Threads
settingThreads Settings
sets_ of
            Threads
Synchronous -> Bool -> TestForest '[] () -> IO ResultForest
runSpecForestSynchronously (Settings -> Bool
settingFailFast Settings
sets_) TestForest '[] ()
specForest
            Threads
ByCapabilities -> Bool -> Int -> TestForest '[] () -> IO ResultForest
runSpecForestAsynchronously (Settings -> Bool
settingFailFast Settings
sets_) Int
nbCapabilities TestForest '[] ()
specForest
            Asynchronous Int
i -> Bool -> Int -> TestForest '[] () -> IO ResultForest
runSpecForestAsynchronously (Settings -> Bool
settingFailFast Settings
sets_) Int
i TestForest '[] ()
specForest
          IO ()
performGC -- Just to be sure that nothing dangerous is lurking around in memory anywhere
          Timed ResultForest -> IO (Timed ResultForest)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Timed ResultForest
r

    let go :: Int -> IO (Timed ResultForest)
go Int
iteration = do
          let newSeed :: Int
newSeed = Settings -> Int
settingSeed Settings
sets Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
iteration
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Running iteration: %4d with seed %4d" Int
iteration Int
newSeed
          Timed ResultForest
rf <- Settings -> IO (Timed ResultForest)
runOnce (Settings -> IO (Timed ResultForest))
-> Settings -> IO (Timed ResultForest)
forall a b. (a -> b) -> a -> b
$ Settings
sets {settingSeed :: Int
settingSeed = Int
newSeed}
          if ResultForest -> Bool
shouldExitFail (Timed ResultForest -> ResultForest
forall a. Timed a -> a
timedValue Timed ResultForest
rf)
            then Timed ResultForest -> IO (Timed ResultForest)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Timed ResultForest
rf
            else case Maybe Int
totalIterations of
              Maybe Int
Nothing -> Int -> IO (Timed ResultForest)
go (Int -> IO (Timed ResultForest)) -> Int -> IO (Timed ResultForest)
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
succ Int
iteration
              Just Int
i
                | Int
iteration Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i -> Timed ResultForest -> IO (Timed ResultForest)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Timed ResultForest
rf
                | Bool
otherwise -> Int -> IO (Timed ResultForest)
go (Int -> IO (Timed ResultForest)) -> Int -> IO (Timed ResultForest)
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
succ Int
iteration

    Timed ResultForest
rf <- Int -> IO (Timed ResultForest)
go Int
0
    Maybe Bool -> Timed ResultForest -> IO ()
printOutputSpecForest (Settings -> Maybe Bool
settingColour Settings
sets) Timed ResultForest
rf
    Timed ResultForest -> IO (Timed ResultForest)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Timed ResultForest
rf