{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NumericUnderscores #-}
-- GHC wants us to remove `Err never` branches from case statements, because it
-- knows we'll never end up in those branches. We like them though, because
-- missing such a branch in a case statement looks like a problem and so is
-- distracting.
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

module Test.Internal where

import qualified Control.Concurrent.MVar as MVar
import qualified Control.Exception.Safe as Exception
import qualified Control.Monad.IO.Class
import qualified Data.Either
import qualified Data.IORef as IORef
import qualified Dict
import qualified GHC.Stack as Stack
import qualified Hedgehog
import qualified Hedgehog.Internal.Property
import qualified Hedgehog.Internal.Report
import qualified Hedgehog.Internal.Runner
import qualified Hedgehog.Internal.Seed
import qualified List
import qualified Maybe
import NriPrelude
import Platform (TracingSpan)
import qualified Platform
import qualified Platform.Internal
import qualified Task
import qualified Tuple
import qualified Prelude

data SingleTest a = SingleTest
  { SingleTest a -> [Text]
describes :: [Text],
    SingleTest a -> Text
name :: Text,
    SingleTest a -> Label
label :: Label,
    SingleTest a -> Maybe SrcLoc
loc :: Maybe Stack.SrcLoc,
    SingleTest a -> a
body :: a
  }
  deriving (a -> SingleTest b -> SingleTest a
(a -> b) -> SingleTest a -> SingleTest b
(forall a b. (a -> b) -> SingleTest a -> SingleTest b)
-> (forall a b. a -> SingleTest b -> SingleTest a)
-> Functor SingleTest
forall a b. a -> SingleTest b -> SingleTest a
forall a b. (a -> b) -> SingleTest a -> SingleTest b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SingleTest b -> SingleTest a
$c<$ :: forall a b. a -> SingleTest b -> SingleTest a
fmap :: (a -> b) -> SingleTest a -> SingleTest b
$cfmap :: forall a b. (a -> b) -> SingleTest a -> SingleTest b
Prelude.Functor)

data Label = None | Skip | Only | Todo
  deriving (Label -> Label -> Bool
(Label -> Label -> Bool) -> (Label -> Label -> Bool) -> Eq Label
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Label -> Label -> Bool
$c/= :: Label -> Label -> Bool
== :: Label -> Label -> Bool
$c== :: Label -> Label -> Bool
Eq, Eq Label
Eq Label
-> (Label -> Label -> Ordering)
-> (Label -> Label -> Bool)
-> (Label -> Label -> Bool)
-> (Label -> Label -> Bool)
-> (Label -> Label -> Bool)
-> (Label -> Label -> Label)
-> (Label -> Label -> Label)
-> Ord Label
Label -> Label -> Bool
Label -> Label -> Ordering
Label -> Label -> Label
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Label -> Label -> Label
$cmin :: Label -> Label -> Label
max :: Label -> Label -> Label
$cmax :: Label -> Label -> Label
>= :: Label -> Label -> Bool
$c>= :: Label -> Label -> Bool
> :: Label -> Label -> Bool
$c> :: Label -> Label -> Bool
<= :: Label -> Label -> Bool
$c<= :: Label -> Label -> Bool
< :: Label -> Label -> Bool
$c< :: Label -> Label -> Bool
compare :: Label -> Label -> Ordering
$ccompare :: Label -> Label -> Ordering
$cp1Ord :: Eq Label
Ord)

data TestResult
  = Succeeded
  | Failed Failure

data Failure
  = FailedAssertion Text (Maybe Stack.SrcLoc)
  | ThrewException Exception.SomeException
  | TookTooLong
  | TestRunnerMessedUp Text
  deriving (Int -> Failure -> ShowS
[Failure] -> ShowS
Failure -> String
(Int -> Failure -> ShowS)
-> (Failure -> String) -> ([Failure] -> ShowS) -> Show Failure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Failure] -> ShowS
$cshowList :: [Failure] -> ShowS
show :: Failure -> String
$cshow :: Failure -> String
showsPrec :: Int -> Failure -> ShowS
$cshowsPrec :: Int -> Failure -> ShowS
Show)

instance Exception.Exception Failure

data SuiteResult
  = AllPassed [SingleTest TracingSpan]
  | OnlysPassed [SingleTest TracingSpan] [SingleTest NotRan]
  | PassedWithSkipped [SingleTest TracingSpan] [SingleTest NotRan]
  | TestsFailed [SingleTest TracingSpan] [SingleTest NotRan] [SingleTest (TracingSpan, Failure)]
  | NoTestsInSuite

data NotRan = NotRan

-- | A test which has yet to be evaluated. When evaluated, it produces one
-- or more 'Expect.Expectation's.
-- See 'test' and 'fuzz' for some ways to create a @Test@.
newtype Test = Test {Test -> [SingleTest Expectation]
unTest :: [SingleTest Expectation]}

-- | The result of a single test run: either a 'pass' or a 'fail'.
type Expectation = Expectation' ()

-- | The type of a test that runs some script with multiple expectations in
-- between.
newtype Expectation' a = Expectation {Expectation' a -> Task Failure a
unExpectation :: Task Failure a}
  deriving (a -> Expectation' b -> Expectation' a
(a -> b) -> Expectation' a -> Expectation' b
(forall a b. (a -> b) -> Expectation' a -> Expectation' b)
-> (forall a b. a -> Expectation' b -> Expectation' a)
-> Functor Expectation'
forall a b. a -> Expectation' b -> Expectation' a
forall a b. (a -> b) -> Expectation' a -> Expectation' b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Expectation' b -> Expectation' a
$c<$ :: forall a b. a -> Expectation' b -> Expectation' a
fmap :: (a -> b) -> Expectation' a -> Expectation' b
$cfmap :: forall a b. (a -> b) -> Expectation' a -> Expectation' b
Prelude.Functor, Functor Expectation'
a -> Expectation' a
Functor Expectation'
-> (forall a. a -> Expectation' a)
-> (forall a b.
    Expectation' (a -> b) -> Expectation' a -> Expectation' b)
-> (forall a b c.
    (a -> b -> c)
    -> Expectation' a -> Expectation' b -> Expectation' c)
-> (forall a b. Expectation' a -> Expectation' b -> Expectation' b)
-> (forall a b. Expectation' a -> Expectation' b -> Expectation' a)
-> Applicative Expectation'
Expectation' a -> Expectation' b -> Expectation' b
Expectation' a -> Expectation' b -> Expectation' a
Expectation' (a -> b) -> Expectation' a -> Expectation' b
(a -> b -> c) -> Expectation' a -> Expectation' b -> Expectation' c
forall a. a -> Expectation' a
forall a b. Expectation' a -> Expectation' b -> Expectation' a
forall a b. Expectation' a -> Expectation' b -> Expectation' b
forall a b.
Expectation' (a -> b) -> Expectation' a -> Expectation' b
forall a b c.
(a -> b -> c) -> Expectation' a -> Expectation' b -> Expectation' c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Expectation' a -> Expectation' b -> Expectation' a
$c<* :: forall a b. Expectation' a -> Expectation' b -> Expectation' a
*> :: Expectation' a -> Expectation' b -> Expectation' b
$c*> :: forall a b. Expectation' a -> Expectation' b -> Expectation' b
liftA2 :: (a -> b -> c) -> Expectation' a -> Expectation' b -> Expectation' c
$cliftA2 :: forall a b c.
(a -> b -> c) -> Expectation' a -> Expectation' b -> Expectation' c
<*> :: Expectation' (a -> b) -> Expectation' a -> Expectation' b
$c<*> :: forall a b.
Expectation' (a -> b) -> Expectation' a -> Expectation' b
pure :: a -> Expectation' a
$cpure :: forall a. a -> Expectation' a
$cp1Applicative :: Functor Expectation'
Prelude.Applicative, Applicative Expectation'
a -> Expectation' a
Applicative Expectation'
-> (forall a b.
    Expectation' a -> (a -> Expectation' b) -> Expectation' b)
-> (forall a b. Expectation' a -> Expectation' b -> Expectation' b)
-> (forall a. a -> Expectation' a)
-> Monad Expectation'
Expectation' a -> (a -> Expectation' b) -> Expectation' b
Expectation' a -> Expectation' b -> Expectation' b
forall a. a -> Expectation' a
forall a b. Expectation' a -> Expectation' b -> Expectation' b
forall a b.
Expectation' a -> (a -> Expectation' b) -> Expectation' b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Expectation' a
$creturn :: forall a. a -> Expectation' a
>> :: Expectation' a -> Expectation' b -> Expectation' b
$c>> :: forall a b. Expectation' a -> Expectation' b -> Expectation' b
>>= :: Expectation' a -> (a -> Expectation' b) -> Expectation' b
$c>>= :: forall a b.
Expectation' a -> (a -> Expectation' b) -> Expectation' b
$cp1Monad :: Applicative Expectation'
Prelude.Monad)

-- | A @Fuzzer a@ knows how to produce random values of @a@ and how to "shrink"
-- a value of @a@, that is turn a value into another that is slightly simpler.
newtype Fuzzer a = Fuzzer {Fuzzer a -> Gen a
unFuzzer :: Hedgehog.Gen a}
  deriving (a -> Fuzzer b -> Fuzzer a
(a -> b) -> Fuzzer a -> Fuzzer b
(forall a b. (a -> b) -> Fuzzer a -> Fuzzer b)
-> (forall a b. a -> Fuzzer b -> Fuzzer a) -> Functor Fuzzer
forall a b. a -> Fuzzer b -> Fuzzer a
forall a b. (a -> b) -> Fuzzer a -> Fuzzer b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Fuzzer b -> Fuzzer a
$c<$ :: forall a b. a -> Fuzzer b -> Fuzzer a
fmap :: (a -> b) -> Fuzzer a -> Fuzzer b
$cfmap :: forall a b. (a -> b) -> Fuzzer a -> Fuzzer b
Prelude.Functor, Functor Fuzzer
a -> Fuzzer a
Functor Fuzzer
-> (forall a. a -> Fuzzer a)
-> (forall a b. Fuzzer (a -> b) -> Fuzzer a -> Fuzzer b)
-> (forall a b c.
    (a -> b -> c) -> Fuzzer a -> Fuzzer b -> Fuzzer c)
-> (forall a b. Fuzzer a -> Fuzzer b -> Fuzzer b)
-> (forall a b. Fuzzer a -> Fuzzer b -> Fuzzer a)
-> Applicative Fuzzer
Fuzzer a -> Fuzzer b -> Fuzzer b
Fuzzer a -> Fuzzer b -> Fuzzer a
Fuzzer (a -> b) -> Fuzzer a -> Fuzzer b
(a -> b -> c) -> Fuzzer a -> Fuzzer b -> Fuzzer c
forall a. a -> Fuzzer a
forall a b. Fuzzer a -> Fuzzer b -> Fuzzer a
forall a b. Fuzzer a -> Fuzzer b -> Fuzzer b
forall a b. Fuzzer (a -> b) -> Fuzzer a -> Fuzzer b
forall a b c. (a -> b -> c) -> Fuzzer a -> Fuzzer b -> Fuzzer c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Fuzzer a -> Fuzzer b -> Fuzzer a
$c<* :: forall a b. Fuzzer a -> Fuzzer b -> Fuzzer a
*> :: Fuzzer a -> Fuzzer b -> Fuzzer b
$c*> :: forall a b. Fuzzer a -> Fuzzer b -> Fuzzer b
liftA2 :: (a -> b -> c) -> Fuzzer a -> Fuzzer b -> Fuzzer c
$cliftA2 :: forall a b c. (a -> b -> c) -> Fuzzer a -> Fuzzer b -> Fuzzer c
<*> :: Fuzzer (a -> b) -> Fuzzer a -> Fuzzer b
$c<*> :: forall a b. Fuzzer (a -> b) -> Fuzzer a -> Fuzzer b
pure :: a -> Fuzzer a
$cpure :: forall a. a -> Fuzzer a
$cp1Applicative :: Functor Fuzzer
Prelude.Applicative)

-- | Apply a description to a list of tests.
--
-- > import Test (describe, test, fuzz)
-- > import Fuzz (int)
-- > import Expect
-- >
-- > describe "List"
-- >     [ describe "reverse"
-- >         [ test "has no effect on an empty list" <|
-- >             \_ ->
-- >                 List.reverse []
-- >                     |> Expect.equal []
-- >         , fuzz int "has no effect on a one-item list" <|
-- >             \num ->
-- >                  List.reverse [ num ]
-- >                     |> Expect.equal [ num ]
-- >         ]
-- >     ]
--
-- Passing an empty list will result in a failing test, because you either made a
-- mistake or are creating a placeholder.
describe :: Text -> [Test] -> Test
describe :: Text -> [Test] -> Test
describe Text
description [Test]
tests =
  [Test]
tests
    [Test]
-> ([Test] -> [SingleTest Expectation]) -> [SingleTest Expectation]
forall a b. a -> (a -> b) -> b
|> (Test -> [SingleTest Expectation])
-> [Test] -> [SingleTest Expectation]
forall a b. (a -> List b) -> List a -> List b
List.concatMap Test -> [SingleTest Expectation]
unTest
    [SingleTest Expectation]
-> ([SingleTest Expectation] -> [SingleTest Expectation])
-> [SingleTest Expectation]
forall a b. a -> (a -> b) -> b
|> (SingleTest Expectation -> SingleTest Expectation)
-> [SingleTest Expectation] -> [SingleTest Expectation]
forall a b. (a -> b) -> List a -> List b
List.map (\SingleTest Expectation
test' -> SingleTest Expectation
test' {describes :: [Text]
describes = Text
description Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: SingleTest Expectation -> [Text]
forall a. SingleTest a -> [Text]
describes SingleTest Expectation
test'})
    [SingleTest Expectation]
-> ([SingleTest Expectation] -> Test) -> Test
forall a b. a -> (a -> b) -> b
|> [SingleTest Expectation] -> Test
Test

-- | Returns a 'Test' that is "todo" (not yet implemented). These tests always
-- fail.
--
-- These tests aren't meant to be committed to version control. Instead, use
-- them when you're brainstorming lots of tests you'd like to write, but you
-- can't implement them all at once. When you replace @todo@ with a real test,
-- you'll be able to see if it fails without clutter from tests still not
-- implemented. But, unlike leaving yourself comments, you'll be prompted to
-- implement these tests because your suite will fail.
--
-- > describe "a new thing"
-- >     [ todo "does what is expected in the common case"
-- >     , todo "correctly handles an edge case I just thought of"
-- >     ]
--
-- This functionality is similar to "pending" tests in other frameworks, except
-- that a todo test is considered failing but a pending test often is not.
todo :: Stack.HasCallStack => Text -> Test
todo :: Text -> Test
todo Text
name =
  [SingleTest Expectation] -> Test
Test
    [ SingleTest :: forall a.
[Text] -> Text -> Label -> Maybe SrcLoc -> a -> SingleTest a
SingleTest
        { describes :: [Text]
describes = [],
          name :: Text
name = Text
name,
          loc :: Maybe SrcLoc
loc = (HasCallStack => Maybe SrcLoc) -> Maybe SrcLoc
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Maybe SrcLoc
getFrame,
          label :: Label
label = Label
Todo,
          body :: Expectation
body = Task Failure () -> Expectation
forall a. Task Failure a -> Expectation' a
Expectation (() -> Task Failure ()
forall a x. a -> Task x a
Task.succeed ())
        }
    ]

-- | Return a 'Test' that evaluates a single
-- 'Expect.Expectation'
--
-- > import Test (fuzz)
-- > import Expect
-- > test "the empty list has 0 length" <|
-- >     \_ ->
-- >         List.length []
-- >             |> Expect.equal 0
test :: Stack.HasCallStack => Text -> (() -> Expectation) -> Test
test :: Text -> (() -> Expectation) -> Test
test Text
name () -> Expectation
expectation =
  [SingleTest Expectation] -> Test
Test
    [ SingleTest :: forall a.
[Text] -> Text -> Label -> Maybe SrcLoc -> a -> SingleTest a
SingleTest
        { describes :: [Text]
describes = [],
          name :: Text
name = Text
name,
          loc :: Maybe SrcLoc
loc = (HasCallStack => Maybe SrcLoc) -> Maybe SrcLoc
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Maybe SrcLoc
getFrame,
          label :: Label
label = Label
None,
          body :: Expectation
body = Expectation -> Expectation
handleUnexpectedErrors (() -> Expectation
expectation ())
        }
    ]

-- | Take a function that produces a test, and calls it several (usually 100)
-- times, using a randomly-generated input from a 'Fuzzer' each time. This
-- allows you to test that a property that should always be true is indeed true
-- under a wide variety of conditions. The function also takes a string
-- describing the test.
--
-- These are called "fuzz tests" because of the randomness. You may find them
-- elsewhere called property-based tests, generative tests, or QuickCheck-style
-- tests.
fuzz :: (Stack.HasCallStack, Show a) => Fuzzer a -> Text -> (a -> Expectation) -> Test
fuzz :: Fuzzer a -> Text -> (a -> Expectation) -> Test
fuzz Fuzzer a
fuzzer Text
name a -> Expectation
expectation =
  [SingleTest Expectation] -> Test
Test
    [ SingleTest :: forall a.
[Text] -> Text -> Label -> Maybe SrcLoc -> a -> SingleTest a
SingleTest
        { describes :: [Text]
describes = [],
          name :: Text
name = Text
name,
          loc :: Maybe SrcLoc
loc = (HasCallStack => Maybe SrcLoc) -> Maybe SrcLoc
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Maybe SrcLoc
getFrame,
          label :: Label
label = Label
None,
          body :: Expectation
body = Fuzzer a -> (a -> Expectation) -> Expectation
forall a. Show a => Fuzzer a -> (a -> Expectation) -> Expectation
fuzzBody Fuzzer a
fuzzer a -> Expectation
expectation
        }
    ]

-- | Run a fuzz test using two random inputs.
fuzz2 :: (Stack.HasCallStack, Show a, Show b) => Fuzzer a -> Fuzzer b -> Text -> (a -> b -> Expectation) -> Test
fuzz2 :: Fuzzer a -> Fuzzer b -> Text -> (a -> b -> Expectation) -> Test
fuzz2 (Fuzzer Gen a
genA) (Fuzzer Gen b
genB) Text
name a -> b -> Expectation
expectation =
  [SingleTest Expectation] -> Test
Test
    [ SingleTest :: forall a.
[Text] -> Text -> Label -> Maybe SrcLoc -> a -> SingleTest a
SingleTest
        { describes :: [Text]
describes = [],
          name :: Text
name = Text
name,
          loc :: Maybe SrcLoc
loc = (HasCallStack => Maybe SrcLoc) -> Maybe SrcLoc
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Maybe SrcLoc
getFrame,
          label :: Label
label = Label
None,
          body :: Expectation
body =
            Fuzzer (a, b) -> ((a, b) -> Expectation) -> Expectation
forall a. Show a => Fuzzer a -> (a -> Expectation) -> Expectation
fuzzBody
              (Gen (a, b) -> Fuzzer (a, b)
forall a. Gen a -> Fuzzer a
Fuzzer ((a -> b -> (a, b)) -> Gen a -> Gen b -> Gen (a, b)
forall (m :: * -> *) a b value.
Applicative m =>
(a -> b -> value) -> m a -> m b -> m value
map2 (,) Gen a
genA Gen b
genB))
              (\(a
a, b
b) -> a -> b -> Expectation
expectation a
a b
b)
        }
    ]

-- | Run a fuzz test using three random inputs.
fuzz3 :: (Stack.HasCallStack, Show a, Show b, Show c) => Fuzzer a -> Fuzzer b -> Fuzzer c -> Text -> (a -> b -> c -> Expectation) -> Test
fuzz3 :: Fuzzer a
-> Fuzzer b
-> Fuzzer c
-> Text
-> (a -> b -> c -> Expectation)
-> Test
fuzz3 (Fuzzer Gen a
genA) (Fuzzer Gen b
genB) (Fuzzer Gen c
genC) Text
name a -> b -> c -> Expectation
expectation =
  [SingleTest Expectation] -> Test
Test
    [ SingleTest :: forall a.
[Text] -> Text -> Label -> Maybe SrcLoc -> a -> SingleTest a
SingleTest
        { describes :: [Text]
describes = [],
          name :: Text
name = Text
name,
          loc :: Maybe SrcLoc
loc = (HasCallStack => Maybe SrcLoc) -> Maybe SrcLoc
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Maybe SrcLoc
getFrame,
          label :: Label
label = Label
None,
          body :: Expectation
body =
            Fuzzer (a, b, c) -> ((a, b, c) -> Expectation) -> Expectation
forall a. Show a => Fuzzer a -> (a -> Expectation) -> Expectation
fuzzBody
              (Gen (a, b, c) -> Fuzzer (a, b, c)
forall a. Gen a -> Fuzzer a
Fuzzer ((a -> b -> c -> (a, b, c))
-> Gen a -> Gen b -> Gen c -> Gen (a, b, c)
forall (m :: * -> *) a b c value.
Applicative m =>
(a -> b -> c -> value) -> m a -> m b -> m c -> m value
map3 (,,) Gen a
genA Gen b
genB Gen c
genC))
              (\(a
a, b
b, c
c) -> a -> b -> c -> Expectation
expectation a
a b
b c
c)
        }
    ]

fuzzBody :: Show a => Fuzzer a -> (a -> Expectation) -> Expectation
fuzzBody :: Fuzzer a -> (a -> Expectation) -> Expectation
fuzzBody (Fuzzer Gen a
gen) a -> Expectation
expectation = do
  Task Failure () -> Expectation
forall a. Task Failure a -> Expectation' a
Expectation
    (Task Failure () -> Expectation) -> Task Failure () -> Expectation
forall a b. (a -> b) -> a -> b
<| (LogHandler -> IO (Result Failure ())) -> Task Failure ()
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Platform.Internal.Task
      ( \LogHandler
_log -> do
          -- For the moment we're not recording traces in fuzz tests. Because
          -- the test body runs a great many times, we'd record a ton of data
          -- that's not all that useful.
          --
          -- Ideally we'd only keep the recording of the most significant run,
          -- but we have to figure out how to do that first.
          LogHandler
silentLog <- IO LogHandler
Platform.silentHandler
          Seed
seed <- IO Seed
forall (m :: * -> *). MonadIO m => m Seed
Hedgehog.Internal.Seed.random
          IORef (Maybe Failure)
failureRef <- Maybe Failure -> IO (IORef (Maybe Failure))
forall a. a -> IO (IORef a)
IORef.newIORef Maybe Failure
forall a. Maybe a
Nothing
          Report Result
hedgehogResult <-
            PropertyConfig
-> Size
-> Seed
-> PropertyT IO ()
-> (Report Progress -> IO ())
-> IO (Report Result)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
PropertyConfig
-> Size
-> Seed
-> PropertyT m ()
-> (Report Progress -> m ())
-> m (Report Result)
Hedgehog.Internal.Runner.checkReport
              PropertyConfig
Hedgehog.Internal.Property.defaultConfig
              Size
0 -- Same value used as in Hedgehog internals.
              Seed
seed
              ( do
                  a
generated <- Gen a -> PropertyT IO a
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
Hedgehog.forAll Gen a
gen
                  Result Failure ()
result <-
                    a -> Expectation
expectation a
generated
                      Expectation -> (Expectation -> Expectation) -> Expectation
forall a b. a -> (a -> b) -> b
|> Expectation -> Expectation
handleUnexpectedErrors
                      Expectation -> (Expectation -> Task Failure ()) -> Task Failure ()
forall a b. a -> (a -> b) -> b
|> Expectation -> Task Failure ()
forall a. Expectation' a -> Task Failure a
unExpectation
                      Task Failure ()
-> (Task Failure () -> Task Failure (Result Failure ()))
-> Task Failure (Result Failure ())
forall a b. a -> (a -> b) -> b
|> (() -> Result Failure ())
-> Task Failure () -> Task Failure (Result Failure ())
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map () -> Result Failure ()
forall error value. value -> Result error value
Ok
                      Task Failure (Result Failure ())
-> (Task Failure (Result Failure ())
    -> Task Never (Result Failure ()))
-> Task Never (Result Failure ())
forall a b. a -> (a -> b) -> b
|> (Failure -> Task Never (Result Failure ()))
-> Task Failure (Result Failure ())
-> Task Never (Result Failure ())
forall x y a. (x -> Task y a) -> Task x a -> Task y a
Task.onError (Result Failure () -> Task Never (Result Failure ())
forall a x. a -> Task x a
Task.succeed (Result Failure () -> Task Never (Result Failure ()))
-> (Failure -> Result Failure ())
-> Failure
-> Task Never (Result Failure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< Failure -> Result Failure ()
forall error value. error -> Result error value
Err)
                      Task Never (Result Failure ())
-> (Task Never (Result Failure ()) -> IO (Result Failure ()))
-> IO (Result Failure ())
forall a b. a -> (a -> b) -> b
|> LogHandler
-> Task Never (Result Failure ()) -> IO (Result Failure ())
forall a. LogHandler -> Task Never a -> IO a
Task.perform LogHandler
silentLog
                      IO (Result Failure ())
-> (IO (Result Failure ()) -> PropertyT IO (Result Failure ()))
-> PropertyT IO (Result Failure ())
forall a b. a -> (a -> b) -> b
|> IO (Result Failure ()) -> PropertyT IO (Result Failure ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Control.Monad.IO.Class.liftIO
                  case Result Failure ()
result of
                    Ok () -> () -> PropertyT IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ()
                    Err Failure
failure -> do
                      IORef (Maybe Failure) -> Maybe Failure -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef (Maybe Failure)
failureRef (Failure -> Maybe Failure
forall a. a -> Maybe a
Just Failure
failure)
                        IO () -> (IO () -> PropertyT IO ()) -> PropertyT IO ()
forall a b. a -> (a -> b) -> b
|> IO () -> PropertyT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Control.Monad.IO.Class.liftIO
                      PropertyT IO ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
Hedgehog.failure
              )
              (\Report Progress
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ())
          case Report Result -> Result
forall a. Report a -> a
Hedgehog.Internal.Report.reportStatus Report Result
hedgehogResult of
            Hedgehog.Internal.Report.Failed FailureReport
_ -> do
              Maybe Failure
maybeFailure <- IORef (Maybe Failure) -> IO (Maybe Failure)
forall a. IORef a -> IO a
IORef.readIORef IORef (Maybe Failure)
failureRef
              case Maybe Failure
maybeFailure of
                Maybe Failure
Nothing ->
                  Text -> Failure
TestRunnerMessedUp Text
"I lost the error report of a failed fuzz test test."
                    Failure -> (Failure -> Result Failure ()) -> Result Failure ()
forall a b. a -> (a -> b) -> b
|> Failure -> Result Failure ()
forall error value. error -> Result error value
Err
                    Result Failure ()
-> (Result Failure () -> IO (Result Failure ()))
-> IO (Result Failure ())
forall a b. a -> (a -> b) -> b
|> Result Failure () -> IO (Result Failure ())
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
                Just Failure
failure ->
                  Failure -> Result Failure ()
forall error value. error -> Result error value
Err Failure
failure
                    Result Failure ()
-> (Result Failure () -> IO (Result Failure ()))
-> IO (Result Failure ())
forall a b. a -> (a -> b) -> b
|> Result Failure () -> IO (Result Failure ())
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
            Result
Hedgehog.Internal.Report.GaveUp ->
              Text -> Failure
TestRunnerMessedUp Text
"I couldn't generate any values for a fuzz test."
                Failure -> (Failure -> Result Failure ()) -> Result Failure ()
forall a b. a -> (a -> b) -> b
|> Failure -> Result Failure ()
forall error value. error -> Result error value
Err
                Result Failure ()
-> (Result Failure () -> IO (Result Failure ()))
-> IO (Result Failure ())
forall a b. a -> (a -> b) -> b
|> Result Failure () -> IO (Result Failure ())
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
            Result
Hedgehog.Internal.Report.OK ->
              () -> Result Failure ()
forall error value. value -> Result error value
Ok ()
                Result Failure ()
-> (Result Failure () -> IO (Result Failure ()))
-> IO (Result Failure ())
forall a b. a -> (a -> b) -> b
|> Result Failure () -> IO (Result Failure ())
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
      )

-- | Returns a 'Test' that gets skipped.
--
-- Calls to @skip@ aren't meant to be committed to version control. Instead,
-- use it when you want to focus on getting a particular subset of your tests
-- to pass. If you use @skip@, your entire test suite will fail, even if each
-- of the individual tests pass. This is to help avoid accidentally committing
-- a @skip@ to version control.
--
-- See also 'only'. Note that @skip@ takes precedence over @only@; if you use a
-- @skip@ inside an @only@, it will still get skipped, and if you use an @only@
-- inside a @skip@, it will also get skipped.
--
-- > describe "List"
-- >     [ skip <|
-- >         describe "reverse"
-- >             [ test "has no effect on an empty list" <|
-- >                 \_ ->
-- >                     List.reverse []
-- >                         |> Expect.equal []
-- >             , fuzz int "has no effect on a one-item list" <|
-- >                 \num ->
-- >                     List.reverse [ num ]
-- >                         |> Expect.equal [ num ]
-- >             ]
-- >     , test "This is the only test that will get run; the other was skipped!" <|
-- >         \_ ->
-- >             List.length []
-- >                 |> Expect.equal 0
-- >     ]
skip :: Test -> Test
skip :: Test -> Test
skip (Test [SingleTest Expectation]
tests) =
  [SingleTest Expectation] -> Test
Test ([SingleTest Expectation] -> Test)
-> [SingleTest Expectation] -> Test
forall a b. (a -> b) -> a -> b
<| (SingleTest Expectation -> SingleTest Expectation)
-> [SingleTest Expectation] -> [SingleTest Expectation]
forall a b. (a -> b) -> List a -> List b
List.map (\SingleTest Expectation
test' -> SingleTest Expectation
test' {label :: Label
label = Label
Skip}) [SingleTest Expectation]
tests

-- | Returns a 'Test' that causes other tests to be skipped, and only runs the given one.
--
-- Calls to @only@ aren't meant to be committed to version control. Instead,
-- use them when you want to focus on getting a particular subset of your tests
-- to pass.  If you use @only@, your entire test suite will fail, even if each
-- of the individual tests pass. This is to help avoid accidentally committing
-- a @only@ to version control.
--
-- If you you use @only@ on multiple tests, only those tests will run. If you
-- put a @only@ inside another @only@, only the outermost @only@ will affect
-- which tests gets run. See also 'skip'. Note that @skip@ takes precedence
-- over @only@; if you use a @skip@ inside an @only@, it will still get
-- skipped, and if you use an @only@ inside a @skip@, it will also get skipped.
--
-- > describe "List"
-- >     [ only <|
-- >         describe "reverse"
-- >             [ test "has no effect on an empty list" <|
-- >                 \_ ->
-- >                     List.reverse []
-- >                         |> Expect.equal []
-- >             , fuzz int "has no effect on a one-item list" <|
-- >                 \num ->
-- >                     List.reverse [ num ]
-- >                         |> Expect.equal [ num ]
-- >             ]
-- >     , test "This will not get run, because of the @only@ above!" <|
-- >         \_ ->
-- >             List.length []
-- >                 |> Expect.equal 0
-- >     ]
only :: Test -> Test
only :: Test -> Test
only (Test [SingleTest Expectation]
tests) =
  [SingleTest Expectation] -> Test
Test ([SingleTest Expectation] -> Test)
-> [SingleTest Expectation] -> Test
forall a b. (a -> b) -> a -> b
<| (SingleTest Expectation -> SingleTest Expectation)
-> [SingleTest Expectation] -> [SingleTest Expectation]
forall a b. (a -> b) -> List a -> List b
List.map (\SingleTest Expectation
test' -> SingleTest Expectation
test' {label :: Label
label = Label
Only}) [SingleTest Expectation]
tests

run :: Test -> Task e SuiteResult
run :: Test -> Task e SuiteResult
run (Test [SingleTest Expectation]
all) = do
  let grouped :: Dict Label [SingleTest Expectation]
grouped = (SingleTest Expectation -> Label)
-> [SingleTest Expectation] -> Dict Label [SingleTest Expectation]
forall key a. Ord key => (a -> key) -> [a] -> Dict key [a]
groupBy SingleTest Expectation -> Label
forall a. SingleTest a -> Label
label [SingleTest Expectation]
all
  let skipped :: [SingleTest Expectation]
skipped = Label
-> Dict Label [SingleTest Expectation]
-> Maybe [SingleTest Expectation]
forall comparable v.
Ord comparable =>
comparable -> Dict comparable v -> Maybe v
Dict.get Label
Skip Dict Label [SingleTest Expectation]
grouped Maybe [SingleTest Expectation]
-> (Maybe [SingleTest Expectation] -> [SingleTest Expectation])
-> [SingleTest Expectation]
forall a b. a -> (a -> b) -> b
|> [SingleTest Expectation]
-> Maybe [SingleTest Expectation] -> [SingleTest Expectation]
forall a. a -> Maybe a -> a
Maybe.withDefault []
  let todos :: [SingleTest Expectation]
todos = Label
-> Dict Label [SingleTest Expectation]
-> Maybe [SingleTest Expectation]
forall comparable v.
Ord comparable =>
comparable -> Dict comparable v -> Maybe v
Dict.get Label
Todo Dict Label [SingleTest Expectation]
grouped Maybe [SingleTest Expectation]
-> (Maybe [SingleTest Expectation] -> [SingleTest Expectation])
-> [SingleTest Expectation]
forall a b. a -> (a -> b) -> b
|> [SingleTest Expectation]
-> Maybe [SingleTest Expectation] -> [SingleTest Expectation]
forall a. a -> Maybe a -> a
Maybe.withDefault []
  let containsOnlys :: Bool
containsOnlys =
        case Label
-> Dict Label [SingleTest Expectation]
-> Maybe [SingleTest Expectation]
forall comparable v.
Ord comparable =>
comparable -> Dict comparable v -> Maybe v
Dict.get Label
Only Dict Label [SingleTest Expectation]
grouped Maybe [SingleTest Expectation]
-> (Maybe [SingleTest Expectation] -> [SingleTest Expectation])
-> [SingleTest Expectation]
forall a b. a -> (a -> b) -> b
|> [SingleTest Expectation]
-> Maybe [SingleTest Expectation] -> [SingleTest Expectation]
forall a. a -> Maybe a -> a
Maybe.withDefault [] of
          [] -> Bool
False
          [SingleTest Expectation]
_ -> Bool
True
  let doRun :: Label -> Bool
doRun Label
label =
        if Bool
containsOnlys
          then Label
label Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
Only
          else Label
label Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
None
  let ([SingleTest Expectation]
toRun, [SingleTest Expectation]
notToRun') =
        Dict Label [SingleTest Expectation]
-> List (Label, [SingleTest Expectation])
forall k v. Dict k v -> List (k, v)
Dict.toList Dict Label [SingleTest Expectation]
grouped
          List (Label, [SingleTest Expectation])
-> (List (Label, [SingleTest Expectation])
    -> (List (Label, [SingleTest Expectation]),
        List (Label, [SingleTest Expectation])))
-> (List (Label, [SingleTest Expectation]),
    List (Label, [SingleTest Expectation]))
forall a b. a -> (a -> b) -> b
|> ((Label, [SingleTest Expectation]) -> Bool)
-> List (Label, [SingleTest Expectation])
-> (List (Label, [SingleTest Expectation]),
    List (Label, [SingleTest Expectation]))
forall a. (a -> Bool) -> List a -> (List a, List a)
List.partition (Label -> Bool
doRun (Label -> Bool)
-> ((Label, [SingleTest Expectation]) -> Label)
-> (Label, [SingleTest Expectation])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< (Label, [SingleTest Expectation]) -> Label
forall a b. (a, b) -> a
Tuple.first)
          (List (Label, [SingleTest Expectation]),
 List (Label, [SingleTest Expectation]))
-> ((List (Label, [SingleTest Expectation]),
     List (Label, [SingleTest Expectation]))
    -> ([SingleTest Expectation], [SingleTest Expectation]))
-> ([SingleTest Expectation], [SingleTest Expectation])
forall a b. a -> (a -> b) -> b
|> (List (Label, [SingleTest Expectation])
 -> [SingleTest Expectation])
-> (List (Label, [SingleTest Expectation])
    -> [SingleTest Expectation])
-> (List (Label, [SingleTest Expectation]),
    List (Label, [SingleTest Expectation]))
-> ([SingleTest Expectation], [SingleTest Expectation])
forall a x b y. (a -> x) -> (b -> y) -> (a, b) -> (x, y)
Tuple.mapBoth (((Label, [SingleTest Expectation]) -> [SingleTest Expectation])
-> List (Label, [SingleTest Expectation])
-> [SingleTest Expectation]
forall a b. (a -> List b) -> List a -> List b
List.concatMap (Label, [SingleTest Expectation]) -> [SingleTest Expectation]
forall a b. (a, b) -> b
Tuple.second) (((Label, [SingleTest Expectation]) -> [SingleTest Expectation])
-> List (Label, [SingleTest Expectation])
-> [SingleTest Expectation]
forall a b. (a -> List b) -> List a -> List b
List.concatMap (Label, [SingleTest Expectation]) -> [SingleTest Expectation]
forall a b. (a, b) -> b
Tuple.second)
  let notToRun :: List (SingleTest NotRan)
notToRun = (SingleTest Expectation -> SingleTest NotRan)
-> [SingleTest Expectation] -> List (SingleTest NotRan)
forall a b. (a -> b) -> List a -> List b
List.map (\SingleTest Expectation
test' -> SingleTest Expectation
test' {body :: NotRan
body = NotRan
NotRan}) [SingleTest Expectation]
notToRun'
  List (SingleTest (TracingSpan, TestResult))
results <- List (Task e (SingleTest (TracingSpan, TestResult)))
-> Task e (List (SingleTest (TracingSpan, TestResult)))
forall x a. List (Task x a) -> Task x (List a)
Task.parallel ((SingleTest Expectation
 -> Task e (SingleTest (TracingSpan, TestResult)))
-> [SingleTest Expectation]
-> List (Task e (SingleTest (TracingSpan, TestResult)))
forall a b. (a -> b) -> List a -> List b
List.map SingleTest Expectation
-> Task e (SingleTest (TracingSpan, TestResult))
forall e.
SingleTest Expectation
-> Task e (SingleTest (TracingSpan, TestResult))
runSingle [SingleTest Expectation]
toRun)
  let ([SingleTest (TracingSpan, Failure)]
failed, [SingleTest TracingSpan]
passed) =
        List (SingleTest (TracingSpan, TestResult))
results
          List (SingleTest (TracingSpan, TestResult))
-> (List (SingleTest (TracingSpan, TestResult))
    -> List
         (Either
            (SingleTest (TracingSpan, Failure)) (SingleTest TracingSpan)))
-> List
     (Either
        (SingleTest (TracingSpan, Failure)) (SingleTest TracingSpan))
forall a b. a -> (a -> b) -> b
|> (SingleTest (TracingSpan, TestResult)
 -> Either
      (SingleTest (TracingSpan, Failure)) (SingleTest TracingSpan))
-> List (SingleTest (TracingSpan, TestResult))
-> List
     (Either
        (SingleTest (TracingSpan, Failure)) (SingleTest TracingSpan))
forall a b. (a -> b) -> List a -> List b
List.map
            ( \SingleTest (TracingSpan, TestResult)
test' ->
                case SingleTest (TracingSpan, TestResult) -> (TracingSpan, TestResult)
forall a. SingleTest a -> a
body SingleTest (TracingSpan, TestResult)
test' of
                  (TracingSpan
tracingSpan, Failed Failure
failure) ->
                    SingleTest (TracingSpan, Failure)
-> Either
     (SingleTest (TracingSpan, Failure)) (SingleTest TracingSpan)
forall a b. a -> Either a b
Prelude.Left SingleTest (TracingSpan, TestResult)
test' {body :: (TracingSpan, Failure)
body = (TracingSpan
tracingSpan, Failure
failure)}
                  (TracingSpan
tracingSpan, TestResult
Succeeded) ->
                    SingleTest TracingSpan
-> Either
     (SingleTest (TracingSpan, Failure)) (SingleTest TracingSpan)
forall a b. b -> Either a b
Prelude.Right SingleTest (TracingSpan, TestResult)
test' {body :: TracingSpan
body = TracingSpan
tracingSpan}
            )
          List
  (Either
     (SingleTest (TracingSpan, Failure)) (SingleTest TracingSpan))
-> (List
      (Either
         (SingleTest (TracingSpan, Failure)) (SingleTest TracingSpan))
    -> ([SingleTest (TracingSpan, Failure)], [SingleTest TracingSpan]))
-> ([SingleTest (TracingSpan, Failure)], [SingleTest TracingSpan])
forall a b. a -> (a -> b) -> b
|> List
  (Either
     (SingleTest (TracingSpan, Failure)) (SingleTest TracingSpan))
-> ([SingleTest (TracingSpan, Failure)], [SingleTest TracingSpan])
forall a b. [Either a b] -> ([a], [b])
Data.Either.partitionEithers
  let summary :: Summary
summary =
        Summary :: Bool -> Bool -> Bool -> Bool -> Summary
Summary
          { noTests :: Bool
noTests = [SingleTest Expectation] -> Bool
forall a. List a -> Bool
List.isEmpty [SingleTest Expectation]
all,
            allPassed :: Bool
allPassed = [SingleTest (TracingSpan, Failure)] -> Bool
forall a. List a -> Bool
List.isEmpty [SingleTest (TracingSpan, Failure)]
failed,
            anyOnlys :: Bool
anyOnlys = Bool
containsOnlys,
            noneSkipped :: Bool
noneSkipped = [SingleTest Expectation] -> Bool
forall a. List a -> Bool
List.isEmpty ([SingleTest Expectation]
skipped [SingleTest Expectation]
-> [SingleTest Expectation] -> [SingleTest Expectation]
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SingleTest Expectation]
todos)
          }
  SuiteResult -> Task e SuiteResult
forall a x. a -> Task x a
Task.succeed (SuiteResult -> Task e SuiteResult)
-> SuiteResult -> Task e SuiteResult
forall a b. (a -> b) -> a -> b
<| case Summary
summary of
    Summary {noTests :: Summary -> Bool
noTests = Bool
True} -> SuiteResult
NoTestsInSuite
    Summary {allPassed :: Summary -> Bool
allPassed = Bool
False} -> [SingleTest TracingSpan]
-> List (SingleTest NotRan)
-> [SingleTest (TracingSpan, Failure)]
-> SuiteResult
TestsFailed [SingleTest TracingSpan]
passed List (SingleTest NotRan)
notToRun [SingleTest (TracingSpan, Failure)]
failed
    Summary {anyOnlys :: Summary -> Bool
anyOnlys = Bool
True} -> [SingleTest TracingSpan] -> List (SingleTest NotRan) -> SuiteResult
OnlysPassed [SingleTest TracingSpan]
passed List (SingleTest NotRan)
notToRun
    Summary {noneSkipped :: Summary -> Bool
noneSkipped = Bool
False} -> [SingleTest TracingSpan] -> List (SingleTest NotRan) -> SuiteResult
PassedWithSkipped [SingleTest TracingSpan]
passed List (SingleTest NotRan)
notToRun
    Summary {} -> [SingleTest TracingSpan] -> SuiteResult
AllPassed [SingleTest TracingSpan]
passed

data Summary = Summary
  { Summary -> Bool
noTests :: Bool,
    Summary -> Bool
allPassed :: Bool,
    Summary -> Bool
anyOnlys :: Bool,
    Summary -> Bool
noneSkipped :: Bool
  }

handleUnexpectedErrors :: Expectation -> Expectation
handleUnexpectedErrors :: Expectation -> Expectation
handleUnexpectedErrors (Expectation Task Failure ()
task') =
  Task Failure ()
task'
    Task Failure ()
-> (Task Failure () -> Task Failure ()) -> Task Failure ()
forall a b. a -> (a -> b) -> b
|> (SomeException -> Task Failure ())
-> Task Failure () -> Task Failure ()
forall e a. (SomeException -> Task e a) -> Task e a -> Task e a
onException (Failure -> Task Failure ()
forall x a. x -> Task x a
Task.fail (Failure -> Task Failure ())
-> (SomeException -> Failure) -> SomeException -> Task Failure ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< SomeException -> Failure
ThrewException)
    Task Failure ()
-> (Task Failure () -> Task Failure ()) -> Task Failure ()
forall a b. a -> (a -> b) -> b
|> Float -> Failure -> Task Failure () -> Task Failure ()
forall err a. Float -> err -> Task err a -> Task err a
Task.timeout Float
10_000 Failure
TookTooLong
    Task Failure ()
-> (Task Failure () -> Task Failure ()) -> Task Failure ()
forall a b. a -> (a -> b) -> b
|> (Failure -> Task Failure ()) -> Task Failure () -> Task Failure ()
forall x y a. (x -> Task y a) -> Task x a -> Task y a
Task.onError Failure -> Task Failure ()
forall x a. x -> Task x a
Task.fail
    Task Failure () -> (Task Failure () -> Expectation) -> Expectation
forall a b. a -> (a -> b) -> b
|> Task Failure () -> Expectation
forall a. Task Failure a -> Expectation' a
Expectation

runSingle :: SingleTest Expectation -> Task e (SingleTest (TracingSpan, TestResult))
runSingle :: SingleTest Expectation
-> Task e (SingleTest (TracingSpan, TestResult))
runSingle SingleTest Expectation
test' =
  (LogHandler
 -> IO (Result e (SingleTest (TracingSpan, TestResult))))
-> Task e (SingleTest (TracingSpan, TestResult))
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Platform.Internal.Task
    ( \LogHandler
_ -> do
        MVar TracingSpan
spanVar <- IO (MVar TracingSpan)
forall a. IO (MVar a)
MVar.newEmptyMVar
        Result Failure ()
res <-
          Text
-> (TracingSpan -> IO ())
-> Text
-> (LogHandler -> IO (Result Failure ()))
-> IO (Result Failure ())
forall a.
HasCallStack =>
Text
-> (TracingSpan -> IO ()) -> Text -> (LogHandler -> IO a) -> IO a
Platform.Internal.rootTracingSpanIO
            Text
""
            (MVar TracingSpan -> TracingSpan -> IO ()
forall a. MVar a -> a -> IO ()
MVar.putMVar MVar TracingSpan
spanVar)
            Text
"test"
            ( \LogHandler
log ->
                SingleTest Expectation -> Expectation
forall a. SingleTest a -> a
body SingleTest Expectation
test'
                  Expectation -> (Expectation -> Task Failure ()) -> Task Failure ()
forall a b. a -> (a -> b) -> b
|> Expectation -> Task Failure ()
forall a. Expectation' a -> Task Failure a
unExpectation
                  Task Failure ()
-> (Task Failure () -> Task Failure (Result Failure ()))
-> Task Failure (Result Failure ())
forall a b. a -> (a -> b) -> b
|> (() -> Result Failure ())
-> Task Failure () -> Task Failure (Result Failure ())
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map () -> Result Failure ()
forall error value. value -> Result error value
Ok
                  Task Failure (Result Failure ())
-> (Task Failure (Result Failure ())
    -> Task Never (Result Failure ()))
-> Task Never (Result Failure ())
forall a b. a -> (a -> b) -> b
|> (Failure -> Task Never (Result Failure ()))
-> Task Failure (Result Failure ())
-> Task Never (Result Failure ())
forall x y a. (x -> Task y a) -> Task x a -> Task y a
Task.onError (Result Failure () -> Task Never (Result Failure ())
forall a x. a -> Task x a
Task.succeed (Result Failure () -> Task Never (Result Failure ()))
-> (Failure -> Result Failure ())
-> Failure
-> Task Never (Result Failure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< Failure -> Result Failure ()
forall error value. error -> Result error value
Err)
                  Task Never (Result Failure ())
-> (Task Never (Result Failure ()) -> IO (Result Failure ()))
-> IO (Result Failure ())
forall a b. a -> (a -> b) -> b
|> LogHandler
-> Task Never (Result Failure ()) -> IO (Result Failure ())
forall a. LogHandler -> Task Never a -> IO a
Task.perform LogHandler
log
            )
        let testRest :: TestResult
testRest =
              case Result Failure ()
res of
                Ok () -> TestResult
Succeeded
                -- If you remove this branch, consider also removing the
                -- -fno-warn-overlapping-patterns warning above.
                Err Failure
err -> Failure -> TestResult
Failed Failure
err
        TracingSpan
span' <- MVar TracingSpan -> IO TracingSpan
forall a. MVar a -> IO a
MVar.takeMVar MVar TracingSpan
spanVar
        let span :: TracingSpan
span =
              TracingSpan
span'
                { summary :: Maybe Text
Platform.Internal.summary = Text -> Maybe Text
forall a. a -> Maybe a
Just (SingleTest Expectation -> Text
forall a. SingleTest a -> Text
name SingleTest Expectation
test'),
                  frame :: Maybe (Text, SrcLoc)
Platform.Internal.frame = (SrcLoc -> (Text, SrcLoc)) -> Maybe SrcLoc -> Maybe (Text, SrcLoc)
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (\SrcLoc
loc -> (Text
"", SrcLoc
loc)) (SingleTest Expectation -> Maybe SrcLoc
forall a. SingleTest a -> Maybe SrcLoc
loc SingleTest Expectation
test'),
                  succeeded :: Succeeded
Platform.Internal.succeeded = case TestResult
testRest of
                    TestResult
Succeeded -> Succeeded
Platform.Internal.Succeeded
                    Failed Failure
failure ->
                      Failure -> SomeException
forall e. Exception e => e -> SomeException
Exception.toException Failure
failure
                        SomeException -> (SomeException -> Succeeded) -> Succeeded
forall a b. a -> (a -> b) -> b
|> SomeException -> Succeeded
Platform.Internal.FailedWith
                }
        SingleTest Expectation
test' {body :: (TracingSpan, TestResult)
body = (TracingSpan
span, TestResult
testRest)}
          SingleTest (TracingSpan, TestResult)
-> (SingleTest (TracingSpan, TestResult)
    -> Result e (SingleTest (TracingSpan, TestResult)))
-> Result e (SingleTest (TracingSpan, TestResult))
forall a b. a -> (a -> b) -> b
|> SingleTest (TracingSpan, TestResult)
-> Result e (SingleTest (TracingSpan, TestResult))
forall error value. value -> Result error value
Ok
          Result e (SingleTest (TracingSpan, TestResult))
-> (Result e (SingleTest (TracingSpan, TestResult))
    -> IO (Result e (SingleTest (TracingSpan, TestResult))))
-> IO (Result e (SingleTest (TracingSpan, TestResult)))
forall a b. a -> (a -> b) -> b
|> Result e (SingleTest (TracingSpan, TestResult))
-> IO (Result e (SingleTest (TracingSpan, TestResult)))
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
    )

ioToTask :: Prelude.IO a -> Task Exception.SomeException a
ioToTask :: IO a -> Task SomeException a
ioToTask IO a
io =
  (LogHandler -> IO (Result SomeException a)) -> Task SomeException a
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Platform.Internal.Task ((LogHandler -> IO (Result SomeException a))
 -> Task SomeException a)
-> (LogHandler -> IO (Result SomeException a))
-> Task SomeException a
forall a b. (a -> b) -> a -> b
<| \LogHandler
_ ->
    (SomeException -> IO (Result SomeException a))
-> IO (Result SomeException a) -> IO (Result SomeException a)
forall (m :: * -> *) a.
MonadCatch m =>
(SomeException -> m a) -> m a -> m a
Exception.handleAny (Result SomeException a -> IO (Result SomeException a)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (Result SomeException a -> IO (Result SomeException a))
-> (SomeException -> Result SomeException a)
-> SomeException
-> IO (Result SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< SomeException -> Result SomeException a
forall error value. error -> Result error value
Err) ((a -> Result SomeException a)
-> IO a -> IO (Result SomeException a)
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map a -> Result SomeException a
forall error value. value -> Result error value
Ok IO a
io)

onException :: (Exception.SomeException -> Task e a) -> Task e a -> Task e a
onException :: (SomeException -> Task e a) -> Task e a -> Task e a
onException SomeException -> Task e a
f (Platform.Internal.Task LogHandler -> IO (Result e a)
run') =
  (LogHandler -> IO (Result e a)) -> Task e a
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Platform.Internal.Task
    ( \LogHandler
log ->
        LogHandler -> IO (Result e a)
run' LogHandler
log
          IO (Result e a)
-> (IO (Result e a) -> IO (Result e a)) -> IO (Result e a)
forall a b. a -> (a -> b) -> b
|> (SomeException -> IO (Result e a))
-> IO (Result e a) -> IO (Result e a)
forall (m :: * -> *) a.
MonadCatch m =>
(SomeException -> m a) -> m a -> m a
Exception.handleAny (LogHandler -> Task e a -> IO (Result e a)
forall x a. LogHandler -> Task x a -> IO (Result x a)
Task.attempt LogHandler
log (Task e a -> IO (Result e a))
-> (SomeException -> Task e a) -> SomeException -> IO (Result e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< SomeException -> Task e a
f)
    )

getFrame :: Stack.HasCallStack => Maybe Stack.SrcLoc
getFrame :: Maybe SrcLoc
getFrame =
  CallStack
HasCallStack => CallStack
Stack.callStack
    CallStack
-> (CallStack -> [(String, SrcLoc)]) -> [(String, SrcLoc)]
forall a b. a -> (a -> b) -> b
|> CallStack -> [(String, SrcLoc)]
Stack.getCallStack
    [(String, SrcLoc)]
-> ([(String, SrcLoc)] -> Maybe (String, SrcLoc))
-> Maybe (String, SrcLoc)
forall a b. a -> (a -> b) -> b
|> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. List a -> Maybe a
List.head
    Maybe (String, SrcLoc)
-> (Maybe (String, SrcLoc) -> Maybe SrcLoc) -> Maybe SrcLoc
forall a b. a -> (a -> b) -> b
|> ((String, SrcLoc) -> SrcLoc)
-> Maybe (String, SrcLoc) -> Maybe SrcLoc
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
Tuple.second

groupBy :: Ord key => (a -> key) -> [a] -> Dict.Dict key [a]
groupBy :: (a -> key) -> [a] -> Dict key [a]
groupBy a -> key
key [a]
xs =
  (a -> Dict key [a] -> Dict key [a])
-> Dict key [a] -> [a] -> Dict key [a]
forall a b. (a -> b -> b) -> b -> List a -> b
List.foldr
    ( \a
x Dict key [a]
acc ->
        key -> (Maybe [a] -> Maybe [a]) -> Dict key [a] -> Dict key [a]
forall comparable v.
Ord comparable =>
comparable
-> (Maybe v -> Maybe v) -> Dict comparable v -> Dict comparable v
Dict.update
          (a -> key
key a
x)
          ( \Maybe [a]
val ->
              [a] -> Maybe [a]
forall a. a -> Maybe a
Just
                ([a] -> Maybe [a]) -> [a] -> Maybe [a]
forall a b. (a -> b) -> a -> b
<| case Maybe [a]
val of
                  Maybe [a]
Nothing -> [a
x]
                  Just [a]
ys -> a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys
          )
          Dict key [a]
acc
    )
    Dict key [a]
forall k v. Dict k v
Dict.empty
    [a]
xs

append :: Expectation -> Expectation -> Expectation
append :: Expectation -> Expectation -> Expectation
append (Expectation Task Failure ()
task1) (Expectation Task Failure ()
task2) =
  Task Failure () -> Expectation
forall a. Task Failure a -> Expectation' a
Expectation (Task Failure () -> Expectation) -> Task Failure () -> Expectation
forall a b. (a -> b) -> a -> b
<| do
    Task Failure ()
task1
    Task Failure ()
task2

-- Assertion constructors
-- All exposed assertion functions should call these functions internally and
-- never each other, to ensure a single unnested 'expectation' entry from
-- appearing in log-explorer traces.

pass :: Stack.HasCallStack => Text -> a -> Expectation' a
pass :: Text -> a -> Expectation' a
pass Text
name a
a = (HasCallStack => Text -> Task Failure a -> Expectation' a)
-> Text -> Task Failure a -> Expectation' a
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Text -> Task Failure a -> Expectation' a
forall a. HasCallStack => Text -> Task Failure a -> Expectation' a
traceExpectation Text
name (a -> Task Failure a
forall a x. a -> Task x a
Task.succeed a
a)

failAssertion :: Stack.HasCallStack => Text -> Text -> Expectation' a
failAssertion :: Text -> Text -> Expectation' a
failAssertion Text
name Text
err =
  Text -> Maybe SrcLoc -> Failure
FailedAssertion Text
err ((HasCallStack => Maybe SrcLoc) -> Maybe SrcLoc
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Maybe SrcLoc
getFrame)
    Failure -> (Failure -> Task Failure a) -> Task Failure a
forall a b. a -> (a -> b) -> b
|> Failure -> Task Failure a
forall x a. x -> Task x a
Task.fail
    Task Failure a
-> (Task Failure a -> Expectation' a) -> Expectation' a
forall a b. a -> (a -> b) -> b
|> (HasCallStack => Text -> Task Failure a -> Expectation' a)
-> Text -> Task Failure a -> Expectation' a
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Text -> Task Failure a -> Expectation' a
forall a. HasCallStack => Text -> Task Failure a -> Expectation' a
traceExpectation Text
name

traceExpectation :: Stack.HasCallStack => Text -> Task Failure a -> Expectation' a
traceExpectation :: Text -> Task Failure a -> Expectation' a
traceExpectation Text
name Task Failure a
task =
  (HasCallStack => Text -> Task Failure a -> Task Failure a)
-> Text -> Task Failure a -> Task Failure a
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack
    HasCallStack => Text -> Task Failure a -> Task Failure a
forall e a. HasCallStack => Text -> Task e a -> Task e a
Platform.tracingSpan
    Text
name
    Task Failure a
task
    Task Failure a
-> (Task Failure a -> Expectation' a) -> Expectation' a
forall a b. a -> (a -> b) -> b
|> Task Failure a -> Expectation' a
forall a. Task Failure a -> Expectation' a
Expectation