{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# 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.Text.IO as TIO
import System.Environment
import System.Mem (performGC)
import System.Random (mkStdGen, setStdGen)
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 :: forall r. 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 -> forall a. a -> Maybe a
Just Word
1
        Iterations Word
i -> forall a. a -> Maybe a
Just Word
i
        Iterations
Continuous -> forall a. Maybe a
Nothing
  case Maybe Word
totalIterations of
    Just Word
1 -> forall r. Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestOnce Settings
settings TestDefM '[] () r
spec
    Maybe Word
_ -> 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 :: forall r. Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestOnce Settings
settings TestDefM '[] () r
spec = do
  TestForest '[] ()
specForest <- 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
  forall a. [String] -> IO a -> IO a
withArgs [] forall a b. (a -> b) -> a -> b
$ do
    SeedSetting -> IO ()
setPseudorandomness (Settings -> SeedSetting
settingSeed Settings
settings)
    case Settings -> Threads
settingThreads Settings
settings of
      Threads
Synchronous -> Settings -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestInterleavedWithOutputSynchronously Settings
settings TestForest '[] ()
specForest
      Threads
ByCapabilities -> do
        Word
i <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
getNumCapabilities

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
i forall a. Eq a => a -> a -> Bool
== Word
1) forall a b. (a -> b) -> a -> b
$ do
          let outputLine :: [Chunk] -> IO ()
              outputLine :: [Chunk] -> IO ()
outputLine [Chunk]
lineChunks = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                TerminalCapabilities -> [Chunk] -> IO ()
putChunksLocaleWith TerminalCapabilities
tc [Chunk]
lineChunks
                Text -> IO ()
TIO.putStrLn Text
""
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
            ( [Chunk] -> IO ()
outputLine
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [])
                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 parallel 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 :: forall r.
Maybe Word
-> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)
sydTestIterations Maybe Word
totalIterations Settings
settings TestDefM '[] () r
spec =
  forall a. [String] -> IO a -> IO a
withArgs [] forall a b. (a -> b) -> a -> b
$ do
    Word
nbCapabilities <- forall a b. (Integral a, Num b) => a -> b
fromIntegral 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
          SeedSetting -> IO ()
setPseudorandomness (Settings -> SeedSetting
settingSeed Settings
settings_)
          TestForest '[] ()
specForest <- forall (outers :: [*]) inner result.
Settings
-> TestDefM outers inner result -> IO (TestForest outers inner)
execTestDefM Settings
settings_ TestDefM '[] () r
spec
          Timed ResultForest
r <- forall (m :: * -> *) a. MonadIO m => Int -> m a -> m (Timed a)
timeItT Int
0 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
          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 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
iteration
              String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"Running iteration: %4d with seed %4d" Word
iteration Int
newSeed
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> SeedSetting
FixedSeed Int
newSeed
            SeedSetting
RandomSeed -> do
              String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"Running iteration: %4d with random seeds" Word
iteration
              forall (f :: * -> *) a. Applicative f => a -> f a
pure SeedSetting
RandomSeed
          Timed ResultForest
rf <- Settings -> IO (Timed ResultForest)
runOnce forall a b. (a -> b) -> a -> b
$ Settings
settings {settingSeed :: SeedSetting
settingSeed = SeedSetting
newSeedSetting}
          if Settings -> ResultForest -> Bool
shouldExitFail Settings
settings (forall a. Timed a -> a
timedValue Timed ResultForest
rf)
            then 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 forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a
succ Word
iteration
              Just Word
i
                | Word
iteration forall a. Ord a => a -> a -> Bool
>= Word
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Timed ResultForest
rf
                | Bool
otherwise -> Word -> IO (Timed ResultForest)
go forall a b. (a -> b) -> a -> b
$ 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Timed ResultForest
rf

setPseudorandomness :: SeedSetting -> IO ()
setPseudorandomness :: SeedSetting -> IO ()
setPseudorandomness = \case
  SeedSetting
RandomSeed -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  FixedSeed Int
seed -> forall (m :: * -> *). MonadIO m => StdGen -> m ()
setStdGen (Int -> StdGen
mkStdGen Int
seed)