{-# 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 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.Printf

-- | Set the command line argument of the underlying action to empty.
--
-- The action behaves as if no command line argument were provided. Especially,
-- it removes all the arguments initially provided to sydtest and provides a
-- reproducible environment.
withNullArgs :: IO a -> IO a
withNullArgs :: forall a. IO a -> IO a
withNullArgs IO a
action = do
  -- Check that args are not empty before setting it to empty.
  -- This is a workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/18261
  -- In summary, `withArgs` is not thread-safe, hence we would like to avoid it
  -- as much as possible.
  --
  -- If sydtest is used in a more complex environment which may use `withArgs`
  -- too, we would like to avoid a complete crash of the program.
  --
  -- Especially, if sydtest is used itself in a sydtest test (e.g. in order to
  -- test sydtest command line itself), it may crash, see
  -- https://github.com/NorfairKing/sydtest/issues/91 for details.
  [String]
args <- IO [String]
getArgs
  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args
    then IO a
action
    else [String] -> IO a -> IO a
forall a. [String] -> IO a -> IO a
withArgs [] IO a
action

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 -> 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 :: forall r. 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
  IO (Timed ResultForest) -> IO (Timed ResultForest)
forall a. IO a -> IO a
withNullArgs (IO (Timed ResultForest) -> IO (Timed ResultForest))
-> IO (Timed ResultForest) -> IO (Timed ResultForest)
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 <- 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
        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 = do
  IO (Timed ResultForest) -> IO (Timed ResultForest)
forall a. IO a -> IO a
withNullArgs (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
          SeedSetting -> IO ()
setPseudorandomness (Settings -> SeedSetting
settingSeed Settings
settings_)
          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 <- case Settings -> Threads
settingThreads Settings
settings_ of
            Threads
Synchronous -> Settings -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestSynchronously Settings
settings_ TestForest '[] ()
specForest
            Threads
ByCapabilities -> Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestAsynchronously Settings
settings_ Word
nbCapabilities TestForest '[] ()
specForest
            Asynchronous Word
i -> Settings -> Word -> TestForest '[] () -> IO (Timed 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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 = 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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Timed ResultForest
rf

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