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

-- | 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
  TerminalCapabilities
tc <- Settings -> IO TerminalCapabilities
deriveTerminalCapababilities Settings
settings
  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

        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 a. IO a -> IO a
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 ()
putChunksLocaleWith TerminalCapabilities
tc [Chunk]
lineChunks
                Text -> IO ()
TIO.putStrLn Text
""
          (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 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 =
  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 <- Int -> IO ResultForest -> IO (Timed ResultForest)
forall (m :: * -> *) a. MonadIO m => Int -> m a -> m (Timed a)
timeItT Int
0 (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 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)