{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- | This module defines the 'IsTest' class and the different instances for it.
module Test.Syd.Run where

import Autodocodec
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as M
import Data.Typeable
import Data.Word
import GHC.Clock (getMonotonicTimeNSec)
import GHC.Generics (Generic)
import Test.QuickCheck
import Test.QuickCheck.Gen
import Test.QuickCheck.IO ()
import Test.QuickCheck.Property hiding (Result (..))
import qualified Test.QuickCheck.Property as QCP
import Test.QuickCheck.Random
import Text.Printf

class IsTest e where
  -- | The argument from 'aroundAll'
  type Arg1 e

  -- | The argument from 'around'
  type Arg2 e

  -- | Running the test, safely
  runTest ::
    e ->
    TestRunSettings ->
    ProgressReporter ->
    ((Arg1 e -> Arg2 e -> IO ()) -> IO ()) ->
    IO TestRunResult

instance IsTest Bool where
  type Arg1 Bool = ()
  type Arg2 Bool = ()
  runTest :: Bool
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 Bool -> Arg2 Bool -> IO ()) -> IO ())
-> IO TestRunResult
runTest Bool
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() () -> Bool
func)

instance IsTest (arg -> Bool) where
  type Arg1 (arg -> Bool) = ()
  type Arg2 (arg -> Bool) = arg
  runTest :: (arg -> Bool)
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (arg -> Bool) -> Arg2 (arg -> Bool) -> IO ()) -> IO ())
-> IO TestRunResult
runTest arg -> Bool
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() arg
arg -> arg -> Bool
func arg
arg)

instance IsTest (outerArgs -> innerArg -> Bool) where
  type Arg1 (outerArgs -> innerArg -> Bool) = outerArgs
  type Arg2 (outerArgs -> innerArg -> Bool) = innerArg
  runTest :: (outerArgs -> innerArg -> Bool)
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (outerArgs -> innerArg -> Bool)
     -> Arg2 (outerArgs -> innerArg -> Bool) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest = forall outerArgs innerArg.
(outerArgs -> innerArg -> Bool)
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runPureTestWithArg

runPureTestWithArg ::
  (outerArgs -> innerArg -> Bool) ->
  TestRunSettings ->
  ProgressReporter ->
  ((outerArgs -> innerArg -> IO ()) -> IO ()) ->
  IO TestRunResult
runPureTestWithArg :: forall outerArgs innerArg.
(outerArgs -> innerArg -> Bool)
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runPureTestWithArg outerArgs -> innerArg -> Bool
computeBool TestRunSettings {} ProgressReporter
progressReporter (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper = do
  let report :: ProgressReporter
report = ProgressReporter -> ProgressReporter
reportProgress ProgressReporter
progressReporter
  let testRunResultNumTests :: Maybe a
testRunResultNumTests = forall a. Maybe a
Nothing
  ProgressReporter
report Progress
ProgressTestStarting
  Either SomeException Bool
resultBool <-
    forall r outerArgs innerArg.
((outerArgs -> innerArg -> IO ()) -> IO ())
-> (outerArgs -> innerArg -> IO r) -> IO (Either SomeException r)
applyWrapper2 (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper forall a b. (a -> b) -> a -> b
$
      \outerArgs
outerArgs innerArg
innerArg -> forall a. a -> IO a
evaluate (outerArgs -> innerArg -> Bool
computeBool outerArgs
outerArgs innerArg
innerArg)
  ProgressReporter
report Progress
ProgressTestDone
  let (TestStatus
testRunResultStatus, Maybe SomeException
testRunResultException) = case Either SomeException Bool
resultBool of
        Left SomeException
ex -> (TestStatus
TestFailed, forall a. a -> Maybe a
Just SomeException
ex)
        Right Bool
bool -> (if Bool
bool then TestStatus
TestPassed else TestStatus
TestFailed, forall a. Maybe a
Nothing)
  let testRunResultNumShrinks :: Maybe a
testRunResultNumShrinks = forall a. Maybe a
Nothing
  let testRunResultGoldenCase :: Maybe a
testRunResultGoldenCase = forall a. Maybe a
Nothing
  let testRunResultFailingInputs :: [a]
testRunResultFailingInputs = []
  let testRunResultExtraInfo :: Maybe a
testRunResultExtraInfo = forall a. Maybe a
Nothing
  let testRunResultLabels :: Maybe a
testRunResultLabels = forall a. Maybe a
Nothing
  let testRunResultClasses :: Maybe a
testRunResultClasses = forall a. Maybe a
Nothing
  let testRunResultTables :: Maybe a
testRunResultTables = forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure TestRunResult {Maybe SomeException
TestStatus
forall a. [a]
forall a. Maybe a
testRunResultExtraInfo :: Maybe String
testRunResultGoldenCase :: Maybe GoldenCase
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultClasses :: Maybe (Map String Int)
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultFailingInputs :: [String]
testRunResultNumShrinks :: Maybe Word
testRunResultNumTests :: Maybe Word
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
testRunResultTables :: forall a. Maybe a
testRunResultClasses :: forall a. Maybe a
testRunResultLabels :: forall a. Maybe a
testRunResultExtraInfo :: forall a. Maybe a
testRunResultFailingInputs :: forall a. [a]
testRunResultGoldenCase :: forall a. Maybe a
testRunResultNumShrinks :: forall a. Maybe a
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
testRunResultNumTests :: forall a. Maybe a
..}

applyWrapper2 ::
  forall r outerArgs innerArg.
  ((outerArgs -> innerArg -> IO ()) -> IO ()) ->
  (outerArgs -> innerArg -> IO r) ->
  IO (Either SomeException r)
applyWrapper2 :: forall r outerArgs innerArg.
((outerArgs -> innerArg -> IO ()) -> IO ())
-> (outerArgs -> innerArg -> IO r) -> IO (Either SomeException r)
applyWrapper2 (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper outerArgs -> innerArg -> IO r
func = do
  MVar (Either SomeException r)
var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (MVar a)
newEmptyMVar
  Either SomeException ()
r <- (forall a. IO a -> [Handler a] -> IO a
`catches` forall a. [Handler (Either SomeException a)]
exceptionHandlers) forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
      (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper forall a b. (a -> b) -> a -> b
$ \outerArgs
outerArgs innerArg
innerArg -> do
        Either SomeException r
res <- (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (outerArgs -> innerArg -> IO r
func outerArgs
outerArgs innerArg
innerArg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO a
evaluate)) forall a. IO a -> [Handler a] -> IO a
`catches` forall a. [Handler (Either SomeException a)]
exceptionHandlers
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException r)
var Either SomeException r
res
  case Either SomeException ()
r of
    Right () -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
readMVar MVar (Either SomeException r)
var
    Left SomeException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left SomeException
e :: Either SomeException r)

instance IsTest (IO ()) where
  type Arg1 (IO ()) = ()
  type Arg2 (IO ()) = ()
  runTest :: IO ()
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (IO ()) -> Arg2 (IO ()) -> IO ()) -> IO ())
-> IO TestRunResult
runTest IO ()
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() () -> IO ()
func)

instance IsTest (arg -> IO ()) where
  type Arg1 (arg -> IO ()) = ()
  type Arg2 (arg -> IO ()) = arg
  runTest :: (arg -> IO ())
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (arg -> IO ()) -> Arg2 (arg -> IO ()) -> IO ()) -> IO ())
-> IO TestRunResult
runTest arg -> IO ()
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() -> arg -> IO ()
func)

instance IsTest (outerArgs -> innerArg -> IO ()) where
  type Arg1 (outerArgs -> innerArg -> IO ()) = outerArgs
  type Arg2 (outerArgs -> innerArg -> IO ()) = innerArg
  runTest :: (outerArgs -> innerArg -> IO ())
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (outerArgs -> innerArg -> IO ())
     -> Arg2 (outerArgs -> innerArg -> IO ()) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest = forall outerArgs innerArg.
(outerArgs -> innerArg -> IO ())
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runIOTestWithArg

instance IsTest (ReaderT env IO ()) where
  type Arg1 (ReaderT env IO ()) = ()
  type Arg2 (ReaderT env IO ()) = env
  runTest :: ReaderT env IO ()
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (ReaderT env IO ()) -> Arg2 (ReaderT env IO ()) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest ReaderT env IO ()
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() -> ReaderT env IO ()
func)

instance IsTest (outerArgs -> ReaderT env IO ()) where
  type Arg1 (outerArgs -> ReaderT env IO ()) = outerArgs
  type Arg2 (outerArgs -> ReaderT env IO ()) = env
  runTest :: (outerArgs -> ReaderT env IO ())
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (outerArgs -> ReaderT env IO ())
     -> Arg2 (outerArgs -> ReaderT env IO ()) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest outerArgs -> ReaderT env IO ()
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\outerArgs
outerArgs env
env -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (outerArgs -> ReaderT env IO ()
func outerArgs
outerArgs) env
env)

runIOTestWithArg ::
  (outerArgs -> innerArg -> IO ()) ->
  TestRunSettings ->
  ProgressReporter ->
  ((outerArgs -> innerArg -> IO ()) -> IO ()) ->
  IO TestRunResult
runIOTestWithArg :: forall outerArgs innerArg.
(outerArgs -> innerArg -> IO ())
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runIOTestWithArg outerArgs -> innerArg -> IO ()
func TestRunSettings {} ProgressReporter
progressReporter (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper = do
  let report :: ProgressReporter
report = ProgressReporter -> ProgressReporter
reportProgress ProgressReporter
progressReporter

  let testRunResultNumTests :: Maybe a
testRunResultNumTests = forall a. Maybe a
Nothing

  ProgressReporter
report Progress
ProgressTestStarting
  Either SomeException ()
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    forall r outerArgs innerArg.
((outerArgs -> innerArg -> IO ()) -> IO ())
-> (outerArgs -> innerArg -> IO r) -> IO (Either SomeException r)
applyWrapper2 (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper forall a b. (a -> b) -> a -> b
$
      \outerArgs
outerArgs innerArg
innerArg ->
        outerArgs -> innerArg -> IO ()
func outerArgs
outerArgs innerArg
innerArg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO a
evaluate
  ProgressReporter
report Progress
ProgressTestDone

  let (TestStatus
testRunResultStatus, Maybe SomeException
testRunResultException) = case Either SomeException ()
result of
        Left SomeException
ex -> (TestStatus
TestFailed, forall a. a -> Maybe a
Just SomeException
ex)
        Right () -> (TestStatus
TestPassed, forall a. Maybe a
Nothing)
  let testRunResultNumShrinks :: Maybe a
testRunResultNumShrinks = forall a. Maybe a
Nothing
  let testRunResultGoldenCase :: Maybe a
testRunResultGoldenCase = forall a. Maybe a
Nothing
  let testRunResultFailingInputs :: [a]
testRunResultFailingInputs = []
  let testRunResultExtraInfo :: Maybe a
testRunResultExtraInfo = forall a. Maybe a
Nothing
  let testRunResultLabels :: Maybe a
testRunResultLabels = forall a. Maybe a
Nothing
  let testRunResultClasses :: Maybe a
testRunResultClasses = forall a. Maybe a
Nothing
  let testRunResultTables :: Maybe a
testRunResultTables = forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure TestRunResult {Maybe SomeException
TestStatus
forall a. [a]
forall a. Maybe a
testRunResultTables :: forall a. Maybe a
testRunResultClasses :: forall a. Maybe a
testRunResultLabels :: forall a. Maybe a
testRunResultExtraInfo :: forall a. Maybe a
testRunResultFailingInputs :: forall a. [a]
testRunResultGoldenCase :: forall a. Maybe a
testRunResultNumShrinks :: forall a. Maybe a
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
testRunResultNumTests :: forall a. Maybe a
testRunResultExtraInfo :: Maybe String
testRunResultGoldenCase :: Maybe GoldenCase
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultClasses :: Maybe (Map String Int)
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultFailingInputs :: [String]
testRunResultNumShrinks :: Maybe Word
testRunResultNumTests :: Maybe Word
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
..}

instance IsTest Property where
  type Arg1 Property = ()
  type Arg2 Property = ()
  runTest :: Property
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 Property -> Arg2 Property -> IO ()) -> IO ())
-> IO TestRunResult
runTest Property
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() -> Property
func)

instance IsTest (arg -> Property) where
  type Arg1 (arg -> Property) = ()
  type Arg2 (arg -> Property) = arg
  runTest :: (arg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (arg -> Property) -> Arg2 (arg -> Property) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest arg -> Property
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() -> arg -> Property
func)

instance IsTest (outerArgs -> innerArg -> Property) where
  type Arg1 (outerArgs -> innerArg -> Property) = outerArgs
  type Arg2 (outerArgs -> innerArg -> Property) = innerArg
  runTest :: (outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (outerArgs -> innerArg -> Property)
     -> Arg2 (outerArgs -> innerArg -> Property) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest = forall outerArgs innerArg.
(outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runPropertyTestWithArg

makeQuickCheckArgs :: TestRunSettings -> Args
makeQuickCheckArgs :: TestRunSettings -> Args
makeQuickCheckArgs TestRunSettings {Bool
Int
SeedSetting
testRunSettingGoldenReset :: TestRunSettings -> Bool
testRunSettingGoldenStart :: TestRunSettings -> Bool
testRunSettingMaxShrinks :: TestRunSettings -> Int
testRunSettingMaxDiscardRatio :: TestRunSettings -> Int
testRunSettingMaxSize :: TestRunSettings -> Int
testRunSettingMaxSuccess :: TestRunSettings -> Int
testRunSettingSeed :: TestRunSettings -> SeedSetting
testRunSettingGoldenReset :: Bool
testRunSettingGoldenStart :: Bool
testRunSettingMaxShrinks :: Int
testRunSettingMaxDiscardRatio :: Int
testRunSettingMaxSize :: Int
testRunSettingMaxSuccess :: Int
testRunSettingSeed :: SeedSetting
..} =
  Args
stdArgs
    { replay :: Maybe (QCGen, Int)
replay = case SeedSetting
testRunSettingSeed of
        SeedSetting
RandomSeed -> forall a. Maybe a
Nothing
        FixedSeed Int
s -> forall a. a -> Maybe a
Just (Int -> QCGen
mkQCGen Int
s, Int
0),
      chatty :: Bool
chatty = Bool
False,
      maxSuccess :: Int
maxSuccess = Int
testRunSettingMaxSuccess,
      maxDiscardRatio :: Int
maxDiscardRatio = Int
testRunSettingMaxDiscardRatio,
      maxSize :: Int
maxSize = Int
testRunSettingMaxSize,
      maxShrinks :: Int
maxShrinks = Int
testRunSettingMaxShrinks
    }

runPropertyTestWithArg ::
  forall outerArgs innerArg.
  (outerArgs -> innerArg -> Property) ->
  TestRunSettings ->
  ProgressReporter ->
  ((outerArgs -> innerArg -> IO ()) -> IO ()) ->
  IO TestRunResult
runPropertyTestWithArg :: forall outerArgs innerArg.
(outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runPropertyTestWithArg outerArgs -> innerArg -> Property
p TestRunSettings
trs ProgressReporter
progressReporter (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper = do
  let report :: ProgressReporter
report = ProgressReporter -> ProgressReporter
reportProgress ProgressReporter
progressReporter
  let qcargs :: Args
qcargs = TestRunSettings -> Args
makeQuickCheckArgs TestRunSettings
trs

  TVar Word
exampleCounter <- forall a. a -> IO (TVar a)
newTVarIO Word
1
  let totalExamples :: Word
totalExamples = (forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Word) (Args -> Int
maxSuccess Args
qcargs)
  let wrapperWithProgress :: (outerArgs -> innerArg -> IO ()) -> IO ()
      wrapperWithProgress :: (outerArgs -> innerArg -> IO ()) -> IO ()
wrapperWithProgress outerArgs -> innerArg -> IO ()
func = (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper forall a b. (a -> b) -> a -> b
$ \outerArgs
outers innerArg
inner -> do
        Word
exampleNr <- forall a. TVar a -> IO a
readTVarIO TVar Word
exampleCounter
        ProgressReporter
report forall a b. (a -> b) -> a -> b
$ Word -> Word -> Progress
ProgressExampleStarting Word
totalExamples Word
exampleNr
        Timed ()
timedResult <- forall (m :: * -> *) a. MonadIO m => m a -> m (Timed a)
timeItT forall a b. (a -> b) -> a -> b
$ outerArgs -> innerArg -> IO ()
func outerArgs
outers innerArg
inner
        ProgressReporter
report forall a b. (a -> b) -> a -> b
$ Word -> Word -> Word64 -> Progress
ProgressExampleDone Word
totalExamples Word
exampleNr forall a b. (a -> b) -> a -> b
$ forall a. Timed a -> Word64
timedTime Timed ()
timedResult
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Word
exampleCounter forall a. Enum a => a -> a
succ
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Timed a -> a
timedValue Timed ()
timedResult

  ProgressReporter
report Progress
ProgressTestStarting
  Result
qcr <- forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult Args
qcargs (forall a b.
((a -> b -> IO ()) -> IO ()) -> (a -> b -> Property) -> Property
aroundProperty (outerArgs -> innerArg -> IO ()) -> IO ()
wrapperWithProgress outerArgs -> innerArg -> Property
p)
  ProgressReporter
report Progress
ProgressTestDone

  let testRunResultGoldenCase :: Maybe a
testRunResultGoldenCase = forall a. Maybe a
Nothing
  let testRunResultNumTests :: Maybe Word
testRunResultNumTests = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Result -> Int
numTests Result
qcr
  case Result
qcr of
    Success {} -> do
      let testRunResultStatus :: TestStatus
testRunResultStatus = TestStatus
TestPassed
      let testRunResultException :: Maybe a
testRunResultException = forall a. Maybe a
Nothing
      let testRunResultNumShrinks :: Maybe a
testRunResultNumShrinks = forall a. Maybe a
Nothing
      let testRunResultFailingInputs :: [a]
testRunResultFailingInputs = []
      let testRunResultExtraInfo :: Maybe a
testRunResultExtraInfo = forall a. Maybe a
Nothing
      let testRunResultLabels :: Maybe (Map [String] Int)
testRunResultLabels = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Result -> Map [String] Int
labels Result
qcr
      let testRunResultClasses :: Maybe (Map String Int)
testRunResultClasses = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Result -> Map String Int
classes Result
qcr
      let testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultTables = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Result -> Map String (Map String Int)
tables Result
qcr
      forall (f :: * -> *) a. Applicative f => a -> f a
pure TestRunResult {Maybe Word
Maybe (Map String Int)
Maybe (Map String (Map String Int))
Maybe (Map [String] Int)
TestStatus
forall a. [a]
forall a. Maybe a
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultClasses :: Maybe (Map String Int)
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultExtraInfo :: forall a. Maybe a
testRunResultFailingInputs :: forall a. [a]
testRunResultNumShrinks :: forall a. Maybe a
testRunResultException :: forall a. Maybe a
testRunResultStatus :: TestStatus
testRunResultNumTests :: Maybe Word
testRunResultGoldenCase :: forall a. Maybe a
testRunResultExtraInfo :: Maybe String
testRunResultGoldenCase :: Maybe GoldenCase
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultClasses :: Maybe (Map String Int)
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultFailingInputs :: [String]
testRunResultNumShrinks :: Maybe Word
testRunResultNumTests :: Maybe Word
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
..}
    GaveUp {} -> do
      let testRunResultStatus :: TestStatus
testRunResultStatus = TestStatus
TestFailed
      let testRunResultException :: Maybe a
testRunResultException = forall a. Maybe a
Nothing
      let testRunResultNumShrinks :: Maybe a
testRunResultNumShrinks = forall a. Maybe a
Nothing
      let testRunResultFailingInputs :: [a]
testRunResultFailingInputs = []
      let testRunResultExtraInfo :: Maybe String
testRunResultExtraInfo = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"Gave up, %d discarded tests" (Result -> Int
numDiscarded Result
qcr)
      let testRunResultLabels :: Maybe (Map [String] Int)
testRunResultLabels = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Result -> Map [String] Int
labels Result
qcr
      let testRunResultClasses :: Maybe (Map String Int)
testRunResultClasses = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Result -> Map String Int
classes Result
qcr
      let testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultTables = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Result -> Map String (Map String Int)
tables Result
qcr
      forall (f :: * -> *) a. Applicative f => a -> f a
pure TestRunResult {Maybe String
Maybe Word
Maybe (Map String Int)
Maybe (Map String (Map String Int))
Maybe (Map [String] Int)
TestStatus
forall a. [a]
forall a. Maybe a
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultClasses :: Maybe (Map String Int)
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultExtraInfo :: Maybe String
testRunResultFailingInputs :: forall a. [a]
testRunResultNumShrinks :: forall a. Maybe a
testRunResultException :: forall a. Maybe a
testRunResultStatus :: TestStatus
testRunResultNumTests :: Maybe Word
testRunResultGoldenCase :: forall a. Maybe a
testRunResultExtraInfo :: Maybe String
testRunResultGoldenCase :: Maybe GoldenCase
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultClasses :: Maybe (Map String Int)
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultFailingInputs :: [String]
testRunResultNumShrinks :: Maybe Word
testRunResultNumTests :: Maybe Word
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
..}
    Failure {} -> do
      let testRunResultStatus :: TestStatus
testRunResultStatus = TestStatus
TestFailed
      let testRunResultException :: Maybe SomeException
testRunResultException = do
            SomeException
se <- Result -> Maybe SomeException
theException Result
qcr
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeException
se :: SomeException)
      let testRunResultNumShrinks :: Maybe Word
testRunResultNumShrinks = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Result -> Int
numShrinks Result
qcr
      let testRunResultFailingInputs :: [String]
testRunResultFailingInputs = Result -> [String]
failingTestCase Result
qcr
      let testRunResultExtraInfo :: Maybe a
testRunResultExtraInfo = forall a. Maybe a
Nothing
      let testRunResultLabels :: Maybe (Map [String] Int)
testRunResultLabels = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
M.singleton (Result -> [String]
failingLabels Result
qcr) Int
1
      let testRunResultClasses :: Maybe (Map String Int)
testRunResultClasses = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. (k -> a) -> Set k -> Map k a
M.fromSet (forall a b. a -> b -> a
const Int
1) (Result -> Set String
failingClasses Result
qcr)
      let testRunResultTables :: Maybe a
testRunResultTables = forall a. Maybe a
Nothing
      forall (f :: * -> *) a. Applicative f => a -> f a
pure TestRunResult {[String]
Maybe Word
Maybe (Map String Int)
Maybe (Map [String] Int)
Maybe SomeException
TestStatus
forall a. Maybe a
testRunResultTables :: forall a. Maybe a
testRunResultClasses :: Maybe (Map String Int)
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultExtraInfo :: forall a. Maybe a
testRunResultFailingInputs :: [String]
testRunResultNumShrinks :: Maybe Word
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
testRunResultNumTests :: Maybe Word
testRunResultGoldenCase :: forall a. Maybe a
testRunResultExtraInfo :: Maybe String
testRunResultGoldenCase :: Maybe GoldenCase
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultClasses :: Maybe (Map String Int)
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultFailingInputs :: [String]
testRunResultNumShrinks :: Maybe Word
testRunResultNumTests :: Maybe Word
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
..}
    NoExpectedFailure {} -> do
      let testRunResultStatus :: TestStatus
testRunResultStatus = TestStatus
TestFailed
      let testRunResultException :: Maybe a
testRunResultException = forall a. Maybe a
Nothing
      let testRunResultNumShrinks :: Maybe a
testRunResultNumShrinks = forall a. Maybe a
Nothing
      let testRunResultFailingInputs :: [a]
testRunResultFailingInputs = []
      let testRunResultLabels :: Maybe (Map [String] Int)
testRunResultLabels = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Result -> Map [String] Int
labels Result
qcr
      let testRunResultClasses :: Maybe (Map String Int)
testRunResultClasses = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Result -> Map String Int
classes Result
qcr
      let testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultTables = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Result -> Map String (Map String Int)
tables Result
qcr
      let testRunResultExtraInfo :: Maybe String
testRunResultExtraInfo = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"Expected the property to fail but it didn't."
      forall (f :: * -> *) a. Applicative f => a -> f a
pure TestRunResult {Maybe String
Maybe Word
Maybe (Map String Int)
Maybe (Map String (Map String Int))
Maybe (Map [String] Int)
TestStatus
forall a. [a]
forall a. Maybe a
testRunResultExtraInfo :: Maybe String
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultClasses :: Maybe (Map String Int)
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultFailingInputs :: forall a. [a]
testRunResultNumShrinks :: forall a. Maybe a
testRunResultException :: forall a. Maybe a
testRunResultStatus :: TestStatus
testRunResultNumTests :: Maybe Word
testRunResultGoldenCase :: forall a. Maybe a
testRunResultExtraInfo :: Maybe String
testRunResultGoldenCase :: Maybe GoldenCase
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultClasses :: Maybe (Map String Int)
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultFailingInputs :: [String]
testRunResultNumShrinks :: Maybe Word
testRunResultNumTests :: Maybe Word
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
..}

aroundProperty :: ((a -> b -> IO ()) -> IO ()) -> (a -> b -> Property) -> Property
aroundProperty :: forall a b.
((a -> b -> IO ()) -> IO ()) -> (a -> b -> Property) -> Property
aroundProperty (a -> b -> IO ()) -> IO ()
action a -> b -> Property
p = Gen Prop -> Property
MkProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (QCGen -> Int -> a) -> Gen a
MkGen forall a b. (a -> b) -> a -> b
$ \QCGen
r Int
n -> forall a b.
((a -> b -> IO ()) -> IO ()) -> (a -> b -> Prop) -> Prop
aroundProp (a -> b -> IO ()) -> IO ()
action forall a b. (a -> b) -> a -> b
$ \a
a b
b -> (forall a. Gen a -> QCGen -> Int -> a
unGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Gen Prop
unProperty forall a b. (a -> b) -> a -> b
$ a -> b -> Property
p a
a b
b) QCGen
r Int
n

aroundProp :: ((a -> b -> IO ()) -> IO ()) -> (a -> b -> Prop) -> Prop
aroundProp :: forall a b.
((a -> b -> IO ()) -> IO ()) -> (a -> b -> Prop) -> Prop
aroundProp (a -> b -> IO ()) -> IO ()
action a -> b -> Prop
p = Rose Result -> Prop
MkProp forall a b. (a -> b) -> a -> b
$ forall a b.
((a -> b -> IO ()) -> IO ())
-> (a -> b -> Rose Result) -> Rose Result
aroundRose (a -> b -> IO ()) -> IO ()
action (\a
a b
b -> Prop -> Rose Result
unProp forall a b. (a -> b) -> a -> b
$ a -> b -> Prop
p a
a b
b)

aroundRose :: ((a -> b -> IO ()) -> IO ()) -> (a -> b -> Rose QCP.Result) -> Rose QCP.Result
aroundRose :: forall a b.
((a -> b -> IO ()) -> IO ())
-> (a -> b -> Rose Result) -> Rose Result
aroundRose (a -> b -> IO ()) -> IO ()
action a -> b -> Rose Result
r = IO (Rose Result) -> Rose Result
ioRose forall a b. (a -> b) -> a -> b
$ do
  IORef (Rose Result)
ref <- forall a. a -> IO (IORef a)
newIORef (forall (m :: * -> *) a. Monad m => a -> m a
return Result
QCP.succeeded)
  (a -> b -> IO ()) -> IO ()
action forall a b. (a -> b) -> a -> b
$ \a
a b
b -> Rose Result -> IO (Rose Result)
reduceRose (a -> b -> Rose Result
r a
a b
b) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. IORef a -> a -> IO ()
writeIORef IORef (Rose Result)
ref
  forall a. IORef a -> IO a
readIORef IORef (Rose Result)
ref

-- | A golden test for output of type @a@.
--
-- The purpose of a golden test is to ensure that the output of a certain
-- process does not change even over time.
--
-- Golden tests can also be used to show how the output of a certain process
-- changes over time and force code reviewers to review the diff that they see
-- in the PR.
--
-- This works by saving a 'golden' output in the repository somewhere,
-- committing it, and then compare that golden output to the output that is
-- currently being produced. You can use `--golden-reset` to have sydtest
-- update the golden output by writing the current output.
data GoldenTest a = GoldenTest
  { -- | Read the golden test output, 'Nothing' if there is no golden output yet.
    forall a. GoldenTest a -> IO (Maybe a)
goldenTestRead :: IO (Maybe a),
    -- | Produce the current output
    forall a. GoldenTest a -> IO a
goldenTestProduce :: IO a,
    -- | Write golden output
    forall a. GoldenTest a -> a -> IO ()
goldenTestWrite :: a -> IO (),
    -- | Compare golden output with current output
    --
    -- The first argument is the current output, the second is the golden output
    forall a. GoldenTest a -> a -> a -> Maybe Assertion
goldenTestCompare :: a -> a -> Maybe Assertion
  }

instance IsTest (GoldenTest a) where
  type Arg1 (GoldenTest a) = ()
  type Arg2 (GoldenTest a) = ()
  runTest :: GoldenTest a
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (GoldenTest a) -> Arg2 (GoldenTest a) -> IO ()) -> IO ())
-> IO TestRunResult
runTest GoldenTest a
gt = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() () -> GoldenTest a
gt)

instance IsTest (arg -> GoldenTest a) where
  type Arg1 (arg -> GoldenTest a) = ()
  type Arg2 (arg -> GoldenTest a) = arg
  runTest :: (arg -> GoldenTest a)
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (arg -> GoldenTest a)
     -> Arg2 (arg -> GoldenTest a) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest arg -> GoldenTest a
gt = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() -> arg -> GoldenTest a
gt)

instance IsTest (outerArgs -> innerArg -> GoldenTest a) where
  type Arg1 (outerArgs -> innerArg -> GoldenTest a) = outerArgs
  type Arg2 (outerArgs -> innerArg -> GoldenTest a) = innerArg
  runTest :: (outerArgs -> innerArg -> GoldenTest a)
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (outerArgs -> innerArg -> GoldenTest a)
     -> Arg2 (outerArgs -> innerArg -> GoldenTest a) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest outerArgs -> innerArg -> GoldenTest a
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\outerArgs
outerArgs innerArg
innerArg -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (outerArgs -> innerArg -> GoldenTest a
func outerArgs
outerArgs innerArg
innerArg) :: IO (GoldenTest a))

instance IsTest (IO (GoldenTest a)) where
  type Arg1 (IO (GoldenTest a)) = ()
  type Arg2 (IO (GoldenTest a)) = ()
  runTest :: IO (GoldenTest a)
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (IO (GoldenTest a)) -> Arg2 (IO (GoldenTest a)) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest IO (GoldenTest a)
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() () -> IO (GoldenTest a)
func)

instance IsTest (arg -> IO (GoldenTest a)) where
  type Arg1 (arg -> IO (GoldenTest a)) = ()
  type Arg2 (arg -> IO (GoldenTest a)) = arg
  runTest :: (arg -> IO (GoldenTest a))
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (arg -> IO (GoldenTest a))
     -> Arg2 (arg -> IO (GoldenTest a)) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest arg -> IO (GoldenTest a)
func = forall e.
IsTest e =>
e
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 e -> Arg2 e -> IO ()) -> IO ())
-> IO TestRunResult
runTest (\() -> arg -> IO (GoldenTest a)
func)

instance IsTest (outerArgs -> innerArg -> IO (GoldenTest a)) where
  type Arg1 (outerArgs -> innerArg -> IO (GoldenTest a)) = outerArgs
  type Arg2 (outerArgs -> innerArg -> IO (GoldenTest a)) = innerArg
  runTest :: (outerArgs -> innerArg -> IO (GoldenTest a))
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (outerArgs -> innerArg -> IO (GoldenTest a))
     -> Arg2 (outerArgs -> innerArg -> IO (GoldenTest a)) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest = forall outerArgs innerArg a.
(outerArgs -> innerArg -> IO (GoldenTest a))
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runGoldenTestWithArg

runGoldenTestWithArg ::
  (outerArgs -> innerArg -> IO (GoldenTest a)) ->
  TestRunSettings ->
  ProgressReporter ->
  ((outerArgs -> innerArg -> IO ()) -> IO ()) ->
  IO TestRunResult
runGoldenTestWithArg :: forall outerArgs innerArg a.
(outerArgs -> innerArg -> IO (GoldenTest a))
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runGoldenTestWithArg outerArgs -> innerArg -> IO (GoldenTest a)
createGolden TestRunSettings {Bool
Int
SeedSetting
testRunSettingGoldenReset :: Bool
testRunSettingGoldenStart :: Bool
testRunSettingMaxShrinks :: Int
testRunSettingMaxDiscardRatio :: Int
testRunSettingMaxSize :: Int
testRunSettingMaxSuccess :: Int
testRunSettingSeed :: SeedSetting
testRunSettingGoldenReset :: TestRunSettings -> Bool
testRunSettingGoldenStart :: TestRunSettings -> Bool
testRunSettingMaxShrinks :: TestRunSettings -> Int
testRunSettingMaxDiscardRatio :: TestRunSettings -> Int
testRunSettingMaxSize :: TestRunSettings -> Int
testRunSettingMaxSuccess :: TestRunSettings -> Int
testRunSettingSeed :: TestRunSettings -> SeedSetting
..} ProgressReporter
_ (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper = do
  Either
  SomeException (TestStatus, Maybe GoldenCase, Maybe SomeException)
errOrTrip <- forall r outerArgs innerArg.
((outerArgs -> innerArg -> IO ()) -> IO ())
-> (outerArgs -> innerArg -> IO r) -> IO (Either SomeException r)
applyWrapper2 (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper forall a b. (a -> b) -> a -> b
$ \outerArgs
outerArgs innerArg
innerArgs -> do
    GoldenTest {IO a
IO (Maybe a)
a -> IO ()
a -> a -> Maybe Assertion
goldenTestCompare :: a -> a -> Maybe Assertion
goldenTestWrite :: a -> IO ()
goldenTestProduce :: IO a
goldenTestRead :: IO (Maybe a)
goldenTestCompare :: forall a. GoldenTest a -> a -> a -> Maybe Assertion
goldenTestWrite :: forall a. GoldenTest a -> a -> IO ()
goldenTestProduce :: forall a. GoldenTest a -> IO a
goldenTestRead :: forall a. GoldenTest a -> IO (Maybe a)
..} <- outerArgs -> innerArg -> IO (GoldenTest a)
createGolden outerArgs
outerArgs innerArg
innerArgs
    Maybe a
mGolden <- IO (Maybe a)
goldenTestRead
    case Maybe a
mGolden of
      Maybe a
Nothing ->
        if Bool
testRunSettingGoldenStart
          then do
            a
actual <- IO a
goldenTestProduce forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO a
evaluate
            a -> IO ()
goldenTestWrite a
actual
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestPassed, forall a. a -> Maybe a
Just GoldenCase
GoldenStarted, forall a. Maybe a
Nothing)
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestFailed, forall a. a -> Maybe a
Just GoldenCase
GoldenNotFound, forall a. Maybe a
Nothing)
      Just a
golden -> do
        a
actual <- IO a
goldenTestProduce forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO a
evaluate
        case a -> a -> Maybe Assertion
goldenTestCompare a
actual a
golden of
          Maybe Assertion
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestPassed, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
          Just Assertion
assertion ->
            if Bool
testRunSettingGoldenReset
              then do
                a -> IO ()
goldenTestWrite a
actual
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestPassed, forall a. a -> Maybe a
Just GoldenCase
GoldenReset, forall a. Maybe a
Nothing)
              else forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestFailed, forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException Assertion
assertion)
  let (TestStatus
testRunResultStatus, Maybe GoldenCase
testRunResultGoldenCase, Maybe SomeException
testRunResultException) = case Either
  SomeException (TestStatus, Maybe GoldenCase, Maybe SomeException)
errOrTrip of
        Left SomeException
e -> (TestStatus
TestFailed, forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just SomeException
e)
        Right (TestStatus, Maybe GoldenCase, Maybe SomeException)
trip -> (TestStatus, Maybe GoldenCase, Maybe SomeException)
trip
  let testRunResultNumTests :: Maybe a
testRunResultNumTests = forall a. Maybe a
Nothing
  let testRunResultNumShrinks :: Maybe a
testRunResultNumShrinks = forall a. Maybe a
Nothing
  let testRunResultFailingInputs :: [a]
testRunResultFailingInputs = []
  let testRunResultExtraInfo :: Maybe a
testRunResultExtraInfo = forall a. Maybe a
Nothing
  let testRunResultLabels :: Maybe a
testRunResultLabels = forall a. Maybe a
Nothing
  let testRunResultClasses :: Maybe a
testRunResultClasses = forall a. Maybe a
Nothing
  let testRunResultTables :: Maybe a
testRunResultTables = forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure TestRunResult {Maybe SomeException
Maybe GoldenCase
TestStatus
forall a. [a]
forall a. Maybe a
testRunResultTables :: forall a. Maybe a
testRunResultClasses :: forall a. Maybe a
testRunResultLabels :: forall a. Maybe a
testRunResultExtraInfo :: forall a. Maybe a
testRunResultFailingInputs :: forall a. [a]
testRunResultNumShrinks :: forall a. Maybe a
testRunResultNumTests :: forall a. Maybe a
testRunResultException :: Maybe SomeException
testRunResultGoldenCase :: Maybe GoldenCase
testRunResultStatus :: TestStatus
testRunResultExtraInfo :: Maybe String
testRunResultGoldenCase :: Maybe GoldenCase
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultClasses :: Maybe (Map String Int)
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultFailingInputs :: [String]
testRunResultNumShrinks :: Maybe Word
testRunResultNumTests :: Maybe Word
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
..}

exceptionHandlers :: [Handler (Either SomeException a)]
exceptionHandlers :: forall a. [Handler (Either SomeException a)]
exceptionHandlers =
  [ -- Re-throw AsyncException, otherwise execution will not terminate on SIGINT (ctrl-c).
    forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\AsyncException
e -> forall e a. Exception e => e -> IO a
throwIO (AsyncException
e :: AsyncException)),
    -- Catch all the rest
    forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\SomeException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (SomeException
e :: SomeException))
  ]

type Test = IO ()

data TestRunSettings = TestRunSettings
  { TestRunSettings -> SeedSetting
testRunSettingSeed :: !SeedSetting,
    TestRunSettings -> Int
testRunSettingMaxSuccess :: !Int,
    TestRunSettings -> Int
testRunSettingMaxSize :: !Int,
    TestRunSettings -> Int
testRunSettingMaxDiscardRatio :: !Int,
    TestRunSettings -> Int
testRunSettingMaxShrinks :: !Int,
    TestRunSettings -> Bool
testRunSettingGoldenStart :: !Bool,
    TestRunSettings -> Bool
testRunSettingGoldenReset :: !Bool
  }
  deriving (Int -> TestRunSettings -> ShowS
[TestRunSettings] -> ShowS
TestRunSettings -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestRunSettings] -> ShowS
$cshowList :: [TestRunSettings] -> ShowS
show :: TestRunSettings -> String
$cshow :: TestRunSettings -> String
showsPrec :: Int -> TestRunSettings -> ShowS
$cshowsPrec :: Int -> TestRunSettings -> ShowS
Show, TestRunSettings -> TestRunSettings -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestRunSettings -> TestRunSettings -> Bool
$c/= :: TestRunSettings -> TestRunSettings -> Bool
== :: TestRunSettings -> TestRunSettings -> Bool
$c== :: TestRunSettings -> TestRunSettings -> Bool
Eq, forall x. Rep TestRunSettings x -> TestRunSettings
forall x. TestRunSettings -> Rep TestRunSettings x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TestRunSettings x -> TestRunSettings
$cfrom :: forall x. TestRunSettings -> Rep TestRunSettings x
Generic)

defaultTestRunSettings :: TestRunSettings
defaultTestRunSettings :: TestRunSettings
defaultTestRunSettings =
  TestRunSettings
    { testRunSettingSeed :: SeedSetting
testRunSettingSeed = Int -> SeedSetting
FixedSeed Int
42, -- This is set by default because we want reproducability by default.
      testRunSettingMaxSuccess :: Int
testRunSettingMaxSuccess = Args -> Int
maxSuccess Args
stdArgs,
      testRunSettingMaxSize :: Int
testRunSettingMaxSize = Args -> Int
maxSize Args
stdArgs,
      testRunSettingMaxDiscardRatio :: Int
testRunSettingMaxDiscardRatio = Args -> Int
maxDiscardRatio Args
stdArgs,
      testRunSettingMaxShrinks :: Int
testRunSettingMaxShrinks =
        -- This is different from what quickcheck does so that test suites are more likely to finish
        Int
100,
      testRunSettingGoldenStart :: Bool
testRunSettingGoldenStart =
        -- It's important that this is False
        -- If it's true by default, then we wouldn't notice it when golden
        -- results are ccidentally not shipped along with the test suite.
        -- In such a case, golden tests could never fail.
        Bool
False,
      testRunSettingGoldenReset :: Bool
testRunSettingGoldenReset = Bool
False
    }

data SeedSetting
  = RandomSeed
  | FixedSeed !Int
  deriving (Int -> SeedSetting -> ShowS
[SeedSetting] -> ShowS
SeedSetting -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SeedSetting] -> ShowS
$cshowList :: [SeedSetting] -> ShowS
show :: SeedSetting -> String
$cshow :: SeedSetting -> String
showsPrec :: Int -> SeedSetting -> ShowS
$cshowsPrec :: Int -> SeedSetting -> ShowS
Show, SeedSetting -> SeedSetting -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SeedSetting -> SeedSetting -> Bool
$c/= :: SeedSetting -> SeedSetting -> Bool
== :: SeedSetting -> SeedSetting -> Bool
$c== :: SeedSetting -> SeedSetting -> Bool
Eq, forall x. Rep SeedSetting x -> SeedSetting
forall x. SeedSetting -> Rep SeedSetting x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SeedSetting x -> SeedSetting
$cfrom :: forall x. SeedSetting -> Rep SeedSetting x
Generic)

instance HasCodec SeedSetting where
  codec :: JSONCodec SeedSetting
codec = forall oldOutput newOutput newInput oldInput context.
(oldOutput -> newOutput)
-> (newInput -> oldInput)
-> Codec context oldInput oldOutput
-> Codec context newInput newOutput
dimapCodec forall {a}. Either a Int -> SeedSetting
f SeedSetting -> Either Text Int
g forall a b. (a -> b) -> a -> b
$ forall context input1 output1 input2 output2.
Codec context input1 output1
-> Codec context input2 output2
-> Codec context (Either input1 input2) (Either output1 output2)
eitherCodec (Text -> JSONCodec Text
literalTextCodec Text
"random") forall value. HasCodec value => JSONCodec value
codec
    where
      f :: Either a Int -> SeedSetting
f = \case
        Left a
_ -> SeedSetting
RandomSeed
        Right Int
i -> Int -> SeedSetting
FixedSeed Int
i
      g :: SeedSetting -> Either Text Int
g = \case
        SeedSetting
RandomSeed -> forall a b. a -> Either a b
Left Text
"random"
        FixedSeed Int
i -> forall a b. b -> Either a b
Right Int
i

data TestRunResult = TestRunResult
  { TestRunResult -> TestStatus
testRunResultStatus :: !TestStatus,
    TestRunResult -> Maybe SomeException
testRunResultException :: !(Maybe SomeException),
    TestRunResult -> Maybe Word
testRunResultNumTests :: !(Maybe Word),
    TestRunResult -> Maybe Word
testRunResultNumShrinks :: !(Maybe Word),
    TestRunResult -> [String]
testRunResultFailingInputs :: [String],
    TestRunResult -> Maybe (Map [String] Int)
testRunResultLabels :: !(Maybe (Map [String] Int)),
    TestRunResult -> Maybe (Map String Int)
testRunResultClasses :: !(Maybe (Map String Int)),
    TestRunResult -> Maybe (Map String (Map String Int))
testRunResultTables :: !(Maybe (Map String (Map String Int))),
    TestRunResult -> Maybe GoldenCase
testRunResultGoldenCase :: !(Maybe GoldenCase),
    TestRunResult -> Maybe String
testRunResultExtraInfo :: !(Maybe String)
  }
  deriving (Int -> TestRunResult -> ShowS
[TestRunResult] -> ShowS
TestRunResult -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestRunResult] -> ShowS
$cshowList :: [TestRunResult] -> ShowS
show :: TestRunResult -> String
$cshow :: TestRunResult -> String
showsPrec :: Int -> TestRunResult -> ShowS
$cshowsPrec :: Int -> TestRunResult -> ShowS
Show, forall x. Rep TestRunResult x -> TestRunResult
forall x. TestRunResult -> Rep TestRunResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TestRunResult x -> TestRunResult
$cfrom :: forall x. TestRunResult -> Rep TestRunResult x
Generic)

data TestStatus = TestPassed | TestFailed
  deriving (Int -> TestStatus -> ShowS
[TestStatus] -> ShowS
TestStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestStatus] -> ShowS
$cshowList :: [TestStatus] -> ShowS
show :: TestStatus -> String
$cshow :: TestStatus -> String
showsPrec :: Int -> TestStatus -> ShowS
$cshowsPrec :: Int -> TestStatus -> ShowS
Show, TestStatus -> TestStatus -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestStatus -> TestStatus -> Bool
$c/= :: TestStatus -> TestStatus -> Bool
== :: TestStatus -> TestStatus -> Bool
$c== :: TestStatus -> TestStatus -> Bool
Eq, forall x. Rep TestStatus x -> TestStatus
forall x. TestStatus -> Rep TestStatus x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TestStatus x -> TestStatus
$cfrom :: forall x. TestStatus -> Rep TestStatus x
Generic)

-- | A special exception that sydtest knows about and can display nicely in the error output
--
-- This is exported outwards so that you can define golden tests for custom types.
--
-- You will probably not want to use this directly in everyday tests, use `shouldBe` or a similar function instead.
data Assertion
  = NotEqualButShouldHaveBeenEqual !String !String
  | EqualButShouldNotHaveBeenEqual !String !String
  | PredicateSucceededButShouldHaveFailed
      !String -- Value
      !(Maybe String) -- Name of the predicate
  | PredicateFailedButShouldHaveSucceeded
      !String -- Value
      !(Maybe String) -- Name of the predicate
  | ExpectationFailed !String
  | Context !Assertion !String
  deriving (Int -> Assertion -> ShowS
[Assertion] -> ShowS
Assertion -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Assertion] -> ShowS
$cshowList :: [Assertion] -> ShowS
show :: Assertion -> String
$cshow :: Assertion -> String
showsPrec :: Int -> Assertion -> ShowS
$cshowsPrec :: Int -> Assertion -> ShowS
Show, Assertion -> Assertion -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Assertion -> Assertion -> Bool
$c/= :: Assertion -> Assertion -> Bool
== :: Assertion -> Assertion -> Bool
$c== :: Assertion -> Assertion -> Bool
Eq, Typeable, forall x. Rep Assertion x -> Assertion
forall x. Assertion -> Rep Assertion x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Assertion x -> Assertion
$cfrom :: forall x. Assertion -> Rep Assertion x
Generic)

instance Exception Assertion

-- | An exception with context.
--
-- We wrap an existentially qualified exception here, instead of
-- 'SomeException', so that we can unwrap it.
-- (For some unknown reason, that doesn't work otherwise.)
data Contextual
  = forall e. Exception e => Contextual !e !String

instance Show Contextual where
  showsPrec :: Int -> Contextual -> ShowS
showsPrec Int
d (Contextual e
e String
s) = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Contextual " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (forall e. Exception e => e -> String
displayException e
e) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 String
s

instance Exception Contextual

addContextToException :: Exception e => e -> String -> Contextual
addContextToException :: forall e. Exception e => e -> String -> Contextual
addContextToException e
e = forall e. Exception e => e -> String -> Contextual
Contextual e
e

data GoldenCase
  = GoldenNotFound
  | GoldenStarted
  | GoldenReset
  deriving (Int -> GoldenCase -> ShowS
[GoldenCase] -> ShowS
GoldenCase -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GoldenCase] -> ShowS
$cshowList :: [GoldenCase] -> ShowS
show :: GoldenCase -> String
$cshow :: GoldenCase -> String
showsPrec :: Int -> GoldenCase -> ShowS
$cshowsPrec :: Int -> GoldenCase -> ShowS
Show, GoldenCase -> GoldenCase -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GoldenCase -> GoldenCase -> Bool
$c/= :: GoldenCase -> GoldenCase -> Bool
== :: GoldenCase -> GoldenCase -> Bool
$c== :: GoldenCase -> GoldenCase -> Bool
Eq, Typeable, forall x. Rep GoldenCase x -> GoldenCase
forall x. GoldenCase -> Rep GoldenCase x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GoldenCase x -> GoldenCase
$cfrom :: forall x. GoldenCase -> Rep GoldenCase x
Generic)

type ProgressReporter = Progress -> IO ()

noProgressReporter :: ProgressReporter
noProgressReporter :: ProgressReporter
noProgressReporter Progress
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

reportProgress :: ProgressReporter -> Progress -> IO ()
reportProgress :: ProgressReporter -> ProgressReporter
reportProgress = forall a. a -> a
id

data Progress
  = ProgressTestStarting
  | ProgressExampleStarting
      !Word
      -- ^ Total examples
      !Word
      -- ^ Example number
  | ProgressExampleDone
      !Word
      -- ^ Total examples
      !Word
      -- ^ Example number
      !Word64
      -- ^ Time it took
  | ProgressTestDone
  deriving (Int -> Progress -> ShowS
[Progress] -> ShowS
Progress -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Progress] -> ShowS
$cshowList :: [Progress] -> ShowS
show :: Progress -> String
$cshow :: Progress -> String
showsPrec :: Int -> Progress -> ShowS
$cshowsPrec :: Int -> Progress -> ShowS
Show, Progress -> Progress -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Progress -> Progress -> Bool
$c/= :: Progress -> Progress -> Bool
== :: Progress -> Progress -> Bool
$c== :: Progress -> Progress -> Bool
Eq, forall x. Rep Progress x -> Progress
forall x. Progress -> Rep Progress x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Progress x -> Progress
$cfrom :: forall x. Progress -> Rep Progress x
Generic)

-- | Time an action and return the result as well as how long it took in seconds.
--
-- This function does not use the 'timeit' package because that package uses CPU time instead of system time.
-- That means that any waiting, like with 'threadDelay' would not be counted.
--
-- Note that this does not evaluate the result, on purpose.
timeItT :: MonadIO m => m a -> m (Timed a)
timeItT :: forall (m :: * -> *) a. MonadIO m => m a -> m (Timed a)
timeItT m a
func = do
  Word64
begin <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
getMonotonicTimeNSec
  a
r <- m a
func
  Word64
end <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
getMonotonicTimeNSec
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Word64 -> Timed a
Timed a
r (Word64
end forall a. Num a => a -> a -> a
- Word64
begin)

data Timed a = Timed
  { forall a. Timed a -> a
timedValue :: !a,
    -- | In nanoseconds
    forall a. Timed a -> Word64
timedTime :: !Word64
  }
  deriving (Int -> Timed a -> ShowS
forall a. Show a => Int -> Timed a -> ShowS
forall a. Show a => [Timed a] -> ShowS
forall a. Show a => Timed a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Timed a] -> ShowS
$cshowList :: forall a. Show a => [Timed a] -> ShowS
show :: Timed a -> String
$cshow :: forall a. Show a => Timed a -> String
showsPrec :: Int -> Timed a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Timed a -> ShowS
Show, Timed a -> Timed a -> Bool
forall a. Eq a => Timed a -> Timed a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Timed a -> Timed a -> Bool
$c/= :: forall a. Eq a => Timed a -> Timed a -> Bool
== :: Timed a -> Timed a -> Bool
$c== :: forall a. Eq a => Timed a -> Timed a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Timed a) x -> Timed a
forall a x. Timed a -> Rep (Timed a) x
$cto :: forall a x. Rep (Timed a) x -> Timed a
$cfrom :: forall a x. Timed a -> Rep (Timed a) x
Generic, forall a b. a -> Timed b -> Timed a
forall a b. (a -> b) -> Timed a -> Timed b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Timed b -> Timed a
$c<$ :: forall a b. a -> Timed b -> Timed a
fmap :: forall a b. (a -> b) -> Timed a -> Timed b
$cfmap :: forall a b. (a -> b) -> Timed a -> Timed b
Functor)