{-# 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 Control.Monad
import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as SB8
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.Colour
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 (outers :: [*]) inner result.
Settings
-> TestDefM outers inner result -> IO (TestForest outers inner)
execTestDefM Settings
sets TestDefM '[] () r
spec
  TerminalCapabilities
tc <- case Settings -> Maybe Bool
settingColour Settings
sets of
    Just Bool
False -> TerminalCapabilities -> IO TerminalCapabilities
forall (f :: * -> *) a. Applicative f => a -> f a
pure TerminalCapabilities
WithoutColours
    Just Bool
True -> TerminalCapabilities -> IO TerminalCapabilities
forall (f :: * -> *) a. Applicative f => a -> f a
pure TerminalCapabilities
With8BitColours
    Maybe Bool
Nothing -> IO TerminalCapabilities
getTerminalCapabilitiesFromEnv
  [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 -> TerminalCapabilities
-> Bool -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestInterleavedWithOutputSynchronously TerminalCapabilities
tc (Settings -> Bool
settingFailFast Settings
sets) TestForest '[] ()
specForest
    Threads
ByCapabilities -> do
      Int
i <- IO Int
getNumCapabilities

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let outputLine :: [Chunk] -> IO ()
            outputLine :: [Chunk] -> IO ()
outputLine [Chunk]
lineChunks = IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              TerminalCapabilities -> [Chunk] -> IO ()
putChunksWith TerminalCapabilities
tc [Chunk]
lineChunks
              ByteString -> IO ()
SB8.putStrLn ByteString
""
        (Chunk -> IO ()) -> [Chunk] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
          ( [Chunk] -> IO ()
outputLine
              ([Chunk] -> IO ()) -> (Chunk -> [Chunk]) -> Chunk -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chunk -> [Chunk] -> [Chunk]
forall a. a -> [a] -> [a]
: [])
              (Chunk -> [Chunk]) -> (Chunk -> Chunk) -> Chunk -> [Chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour -> Chunk -> Chunk
fore Colour
red
          )
          [ Text -> Chunk
chunk Text
"WARNING: Only one CPU core detected, make sure to compile your test suite with these ghc options:",
            Text -> Chunk
chunk Text
"         -threaded -rtsopts -with-rtsopts=-N",
            Text -> Chunk
chunk Text
"         (This is important for correctness as well as speed, as a parallell test suite can find thread safety problems.)"
          ]
      TerminalCapabilities
-> Bool -> Int -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestInterleavedWithOutputAsynchronously TerminalCapabilities
tc (Settings -> Bool
settingFailFast Settings
sets) Int
i TestForest '[] ()
specForest
    Asynchronous Int
i ->
      TerminalCapabilities
-> Bool -> Int -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestInterleavedWithOutputAsynchronously TerminalCapabilities
tc (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 (outers :: [*]) inner result.
Settings
-> TestDefM outers inner result -> IO (TestForest outers inner)
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
    TerminalCapabilities
tc <- case Settings -> Maybe Bool
settingColour Settings
sets of
      Just Bool
False -> TerminalCapabilities -> IO TerminalCapabilities
forall (f :: * -> *) a. Applicative f => a -> f a
pure TerminalCapabilities
WithoutColours
      Just Bool
True -> TerminalCapabilities -> IO TerminalCapabilities
forall (f :: * -> *) a. Applicative f => a -> f a
pure TerminalCapabilities
With8BitColours
      Maybe Bool
Nothing -> IO TerminalCapabilities
getTerminalCapabilitiesFromEnv
    TerminalCapabilities -> Timed ResultForest -> IO ()
printOutputSpecForest TerminalCapabilities
tc Timed ResultForest
rf
    Timed ResultForest -> IO (Timed ResultForest)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Timed ResultForest
rf