{-# 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
settings TestDefM '[] () r
spec = do
  let totalIterations :: Maybe Word
totalIterations = case Settings -> Iterations
settingIterations Settings
settings of
        Iterations
OneIteration -> Word -> Maybe Word
forall a. a -> Maybe a
Just Word
1
        Iterations Word
i -> Word -> Maybe Word
forall a. a -> Maybe a
Just Word
i
        Iterations
Continuous -> Maybe Word
forall a. Maybe a
Nothing
  case Maybe Word
totalIterations of
    Just Word
1 -> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
forall r. Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestOnce Settings
settings TestDefM '[] () r
spec
    Maybe Word
_ -> Maybe Word
-> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
forall r.
Maybe Word
-> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestIterations Maybe Word
totalIterations Settings
settings TestDefM '[] () r
spec

sydTestOnce :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestOnce :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestOnce Settings
settings 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
settings TestDefM '[] () r
spec
  TerminalCapabilities
tc <- Settings -> IO TerminalCapabilities
deriveTerminalCapababilities Settings
settings
  [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
settings of
    Threads
Synchronous -> Settings -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestInterleavedWithOutputSynchronously Settings
settings TestForest '[] ()
specForest
    Threads
ByCapabilities -> do
      Word
i <- Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> IO Int -> IO Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
getNumCapabilities

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
i Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
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.)"
          ]
      Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestInterleavedWithOutputAsynchronously Settings
settings Word
i TestForest '[] ()
specForest
    Asynchronous Word
i ->
      Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestInterleavedWithOutputAsynchronously Settings
settings Word
i TestForest '[] ()
specForest

sydTestIterations :: Maybe Word -> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestIterations :: Maybe Word
-> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestIterations Maybe Word
totalIterations Settings
settings 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
    Word
nbCapabilities <- Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> IO Int -> IO Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
getNumCapabilities

    let runOnce :: Settings -> IO (Timed ResultForest)
runOnce Settings
settings_ = do
          TestForest '[] ()
specForest <- Settings -> TestDefM '[] () r -> IO (TestForest '[] ())
forall (outers :: [*]) inner result.
Settings
-> TestDefM outers inner result -> IO (TestForest outers inner)
execTestDefM Settings
settings_ 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
settings_ of
            Threads
Synchronous -> Settings -> TestForest '[] () -> IO ResultForest
runSpecForestSynchronously Settings
settings_ TestForest '[] ()
specForest
            Threads
ByCapabilities -> Settings -> Word -> TestForest '[] () -> IO ResultForest
runSpecForestAsynchronously Settings
settings_ Word
nbCapabilities TestForest '[] ()
specForest
            Asynchronous Word
i -> Settings -> Word -> TestForest '[] () -> IO ResultForest
runSpecForestAsynchronously Settings
settings_ Word
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 :: Word -> IO (Timed ResultForest)
go Word
iteration = do
          SeedSetting
newSeedSetting <- case Settings -> SeedSetting
settingSeed Settings
settings of
            FixedSeed Int
seed -> do
              let newSeed :: Int
newSeed = Int
seed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
iteration
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Word -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Running iteration: %4d with seed %4d" Word
iteration Int
newSeed
              SeedSetting -> IO SeedSetting
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SeedSetting -> IO SeedSetting) -> SeedSetting -> IO SeedSetting
forall a b. (a -> b) -> a -> b
$ Int -> SeedSetting
FixedSeed Int
newSeed
            SeedSetting
RandomSeed -> do
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Word -> String
forall r. PrintfType r => String -> r
printf String
"Running iteration: %4d with random seeds" Word
iteration
              SeedSetting -> IO SeedSetting
forall (f :: * -> *) a. Applicative f => a -> f a
pure SeedSetting
RandomSeed
          Timed ResultForest
rf <- Settings -> IO (Timed ResultForest)
runOnce (Settings -> IO (Timed ResultForest))
-> Settings -> IO (Timed ResultForest)
forall a b. (a -> b) -> a -> b
$ Settings
settings {settingSeed :: SeedSetting
settingSeed = SeedSetting
newSeedSetting}
          if Settings -> ResultForest -> Bool
shouldExitFail Settings
settings (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 Word
totalIterations of
              Maybe Word
Nothing -> Word -> IO (Timed ResultForest)
go (Word -> IO (Timed ResultForest))
-> Word -> IO (Timed ResultForest)
forall a b. (a -> b) -> a -> b
$ Word -> Word
forall a. Enum a => a -> a
succ Word
iteration
              Just Word
i
                | Word
iteration Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
>= Word
i -> Timed ResultForest -> IO (Timed ResultForest)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Timed ResultForest
rf
                | Bool
otherwise -> Word -> IO (Timed ResultForest)
go (Word -> IO (Timed ResultForest))
-> Word -> IO (Timed ResultForest)
forall a b. (a -> b) -> a -> b
$ Word -> Word
forall a. Enum a => a -> a
succ Word
iteration

    Timed ResultForest
rf <- Word -> IO (Timed ResultForest)
go Word
0
    Settings -> Timed ResultForest -> IO ()
printOutputSpecForest Settings
settings Timed ResultForest
rf
    Timed ResultForest -> IO (Timed ResultForest)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Timed ResultForest
rf