diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,18 @@ +# 0.3.0.0 + +Breaking changs: + +- `Test.fromTestTree` has been removed. +- `Fuzz.Fuzzer` is now an opague type and no a synonomy for `Hedgehog.Gen`. +- `Expect.Task.TestFailure` renamed to `Expect.Task.failure`. +- `Test.Runner.Tasy.main` renamed to `Test.run`. + +Enhancements: + +- Test reports now show source locations of failing tests. +- `Fuzz` module has been extended and now covers almost the entire API of its Elm counterpart. +- Dependency on `tasty` has been dropped. + # 0.2.0.0 - Breaking change: drop `Platform.TracingSpan` constructor. diff --git a/nri-prelude.cabal b/nri-prelude.cabal --- a/nri-prelude.cabal +++ b/nri-prelude.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 1d5765ce153ffbf242d9ddffda10b587f0f07d26102b94f271297e3aad8d24ab +-- hash: 2de1014852d15f8dc7dd66b6540283d0fe7b3997b91e1a08d6f0ee4f5ea76271 name: nri-prelude -version: 0.2.0.0 +version: 0.3.0.0 synopsis: A Prelude inspired by the Elm programming language description: Please see the README at . category: Web @@ -52,18 +52,17 @@ Set Task Test - Test.Runner.Tasty Text Tuple other-modules: - Internal.Expectation Internal.Shortcut Internal.Terminal - Internal.Test - Internal.TestResult Platform.DoAnything Platform.Internal - Test.Console.Color + Test.Internal + Test.Reporter.ExitCode + Test.Reporter.Junit + Test.Reporter.Stdout Paths_nri_prelude hs-source-dirs: src @@ -76,19 +75,15 @@ , auto-update >=0.1.6 && <0.2 , base >=4.12.0.0 && <4.15 , bytestring >=0.10.8.2 && <0.12 - , concurrent-output >=1.10.11 && <1.11 , containers >=0.6.0.1 && <0.7 , directory >=1.3.3.0 && <1.4 , exceptions >=0.10.4 && <0.11 , filepath >=1.4.2.1 && <1.5 , hedgehog >=1.0.2 && <1.1 - , junit-xml >=0.1.0.0 && <0.2 + , junit-xml >=0.1.0.0 && <0.2.0.0 , pretty-diff >=0.1.0.0 && <0.3 , pretty-show >=1.9.5 && <1.11 - , resourcet >=1.2.2 && <1.3 , safe-exceptions >=0.1.7.0 && <1.3 - , tasty >=1.2.3 && <1.5 - , tasty-test-reporter >=0.1.1.1 && <0.2 , terminal-size >=0.3.2.1 && <0.4 , text >=1.2.3.1 && <1.3 , time >=1.8.0.2 && <1.12 @@ -106,6 +101,7 @@ LogSpec PlatformSpec SetSpec + TestSpec TextSpec Array Basics @@ -116,11 +112,8 @@ Expect Expect.Task Fuzz - Internal.Expectation Internal.Shortcut Internal.Terminal - Internal.Test - Internal.TestResult List Log Maybe @@ -133,8 +126,10 @@ Set Task Test - Test.Console.Color - Test.Runner.Tasty + Test.Internal + Test.Reporter.ExitCode + Test.Reporter.Junit + Test.Reporter.Stdout Text Tuple Paths_nri_prelude @@ -150,19 +145,15 @@ , auto-update >=0.1.6 && <0.2 , base >=4.12.0.0 && <4.15 , bytestring >=0.10.8.2 && <0.12 - , concurrent-output >=1.10.11 && <1.11 , containers >=0.6.0.1 && <0.7 , directory >=1.3.3.0 && <1.4 , exceptions >=0.10.4 && <0.11 , filepath >=1.4.2.1 && <1.5 , hedgehog >=1.0.2 && <1.1 - , junit-xml >=0.1.0.0 && <0.2 + , junit-xml >=0.1.0.0 && <0.2.0.0 , pretty-diff >=0.1.0.0 && <0.3 , pretty-show >=1.9.5 && <1.11 - , resourcet >=1.2.2 && <1.3 , safe-exceptions >=0.1.7.0 && <1.3 - , tasty >=1.2.3 && <1.5 - , tasty-test-reporter >=0.1.1.1 && <0.2 , terminal-size >=0.3.2.1 && <0.4 , text >=1.2.3.1 && <1.3 , time >=1.8.0.2 && <1.12 diff --git a/src/Expect.hs b/src/Expect.hs --- a/src/Expect.hs +++ b/src/Expect.hs @@ -48,25 +48,28 @@ import qualified Data.Text import qualified Data.Text.IO import qualified Debug -import qualified Internal.Expectation -import qualified Internal.TestResult import qualified List import List (List) import NriPrelude +import qualified Platform.Internal +import qualified Pretty.Diff as Diff +import qualified System.Console.Terminal.Size as Terminal import qualified System.Directory as Directory import qualified System.FilePath as FilePath +import qualified Task +import qualified Test.Internal as Internal +import Test.Internal (Expectation) +import qualified Text.Show.Pretty import Prelude (Eq, IO, Ord, Show, show) --- | The result of a single test run: either a 'pass' or a 'fail'. -type Expectation = - Internal.Expectation.Expectation Internal.TestResult.TestResult - -- | Run some IO and assert the value it produces. -- -- If the IO throws an exception the test will fail. withIO :: (a -> Expectation) -> IO a -> Expectation withIO fn io = - Internal.Expectation.fromIO io |> andThen fn + fromIO io + |> andThen (Internal.unExpectation << fn) + |> Internal.Expectation -- | Always passes. -- @@ -84,7 +87,7 @@ -- > Err err -> -- > Expect.fail err pass :: Expectation -pass = Internal.Expectation.pass +pass = Internal.Expectation (Task.succeed Internal.Succeeded) -- | Fails with the given message. -- @@ -102,7 +105,12 @@ -- > Err err -> -- > Expect.fail err fail :: Text -> Expectation -fail = Internal.Expectation.fail +fail msg = + msg + |> Internal.FailedAssertion + |> Internal.Failed + |> Task.succeed + |> Internal.Expectation -- | If the given expectation fails, replace its failure message with a custom one. -- @@ -110,7 +118,15 @@ -- > |> Expect.equal "something else" -- > |> Expect.onFail "thought those two strings would be the same" onFail :: Text -> Expectation -> Expectation -onFail = Internal.Expectation.onFail +onFail msg (Internal.Expectation task) = + task + |> Task.map + ( \res -> + case res of + Internal.Succeeded -> Internal.Succeeded + Internal.Failed _ -> Internal.Failed (Internal.FailedAssertion msg) + ) + |> Internal.Expectation -- | Passes if the arguments are equal. -- @@ -134,7 +150,7 @@ -- > -- > -} equal :: (Show a, Eq a) => a -> a -> Expectation -equal = Internal.Expectation.build (==) "Expect.equal" +equal = assert (==) "Expect.equal" -- | Passes if the arguments are not equal. -- @@ -157,7 +173,7 @@ -- > -- > -} notEqual :: (Show a, Eq a) => a -> a -> Expectation -notEqual = Internal.Expectation.build (/=) "Expect.notEqual" +notEqual = assert (/=) "Expect.notEqual" -- | Passes if the second argument is less than the first. -- @@ -182,7 +198,7 @@ -- > -- > -} lessThan :: (Show a, Ord a) => a -> a -> Expectation -lessThan = Internal.Expectation.build (>) "Expect.lessThan" +lessThan = assert (>) "Expect.lessThan" -- | Passes if the second argument is less than or equal to the first. -- @@ -206,7 +222,7 @@ -- > -- > -} atMost :: (Show a, Ord a) => a -> a -> Expectation -atMost = Internal.Expectation.build (>=) "Expect.atMost" +atMost = assert (>=) "Expect.atMost" -- | Passes if the second argument is greater than the first. -- @@ -230,7 +246,7 @@ -- > -- > -} greaterThan :: (Show a, Ord a) => a -> a -> Expectation -greaterThan = Internal.Expectation.build (<) "Expect.greaterThan" +greaterThan = assert (<) "Expect.greaterThan" -- | Passes if the second argument is greater than or equal to the first. -- @@ -254,7 +270,7 @@ -- > -- > -} atLeast :: (Show a, Ord a) => a -> a -> Expectation -atLeast = Internal.Expectation.build (<=) "Expect.atLeast" +atLeast = assert (<=) "Expect.atLeast" -- | Passes if the argument is 'True', and otherwise fails with the given message. -- @@ -274,7 +290,7 @@ -- > -- > -} true :: Bool -> Expectation -true x = Internal.Expectation.build (&&) "Expect.true" x True +true x = assert (&&) "Expect.true" x True -- | Passes if the argument is 'False', and otherwise fails with the given message. -- @@ -294,7 +310,7 @@ -- > -- > -} false :: Bool -> Expectation -false x = Internal.Expectation.build xor "Expect.false" x True +false x = assert xor "Expect.false" x True -- | Passes if each of the given functions passes when applied to the subject. -- @@ -327,11 +343,11 @@ all expectations subject = List.foldl ( \expectation acc -> - Internal.Expectation.join + Internal.append acc (expectation subject) ) - Internal.Expectation.pass + pass expectations -- | Combine multiple expectations into one. The resulting expectation is a @@ -340,11 +356,11 @@ concat expectations = List.foldl ( \expectation acc -> - Internal.Expectation.join + Internal.append acc expectation ) - Internal.Expectation.pass + pass expectations -- | Passes if the Result is an Ok rather than Err. This is useful for tests where you expect not to see an error, but you don't care what the actual result is. @@ -373,7 +389,7 @@ ok :: Show b => Result b a -> Expectation ok res = case res of - Ok _ -> Expect.pass + Ok _ -> pass Err message -> fail ("I expected a Ok but got Err (" ++ Debug.toString message ++ ")") -- | Passes if the Result is an Err rather than Ok. This is useful for tests where you expect to get an error but you don't care what the actual error is. @@ -403,7 +419,7 @@ err res = case res of Ok value -> fail ("I expected a Err but got Ok (" ++ Debug.toString value ++ ")") - Err _ -> Expect.pass + Err _ -> pass -- | Check if a string is equal to the contents of a file. -- @@ -418,22 +434,24 @@ -- use @git diff golden-results/complicated-object.txt@ to check whether the -- changes are acceptable. equalToContentsOf :: Text -> Text -> Expectation -equalToContentsOf filepath' actual = do - let filepath = Data.Text.unpack filepath' - exists <- Internal.Expectation.fromIO <| do - Directory.createDirectoryIfMissing True (FilePath.takeDirectory filepath) - Directory.doesFileExist filepath - if exists - then do - expected <- Internal.Expectation.fromIO (Data.Text.IO.readFile filepath) - Internal.Expectation.build - (==) - "Expect.equalToContentsOf" - (UnescapedShow expected) - (UnescapedShow actual) - else do - Internal.Expectation.fromIO (Data.Text.IO.writeFile filepath actual) - Internal.Expectation.pass +equalToContentsOf filepath' actual = + Internal.Expectation <| do + let filepath = Data.Text.unpack filepath' + exists <- fromIO <| do + Directory.createDirectoryIfMissing True (FilePath.takeDirectory filepath) + Directory.doesFileExist filepath + if exists + then do + expected <- fromIO (Data.Text.IO.readFile filepath) + assert + (==) + "Expect.equalToContentsOf" + (UnescapedShow expected) + (UnescapedShow actual) + |> Internal.unExpectation + else do + fromIO (Data.Text.IO.writeFile filepath actual) + Internal.unExpectation pass -- By default we will compare values with each other after they have been -- passed to @show@. Unfortunately @show@ for the @Text@ type escapes special @@ -454,3 +472,30 @@ instance Show UnescapedShow where show (UnescapedShow text) = Data.Text.unpack text + +assert :: Show a => (a -> a -> Bool) -> Text -> a -> a -> Expectation +assert pred funcName actual expected = + if pred actual expected + then pass + else Internal.Expectation <| do + window <- fromIO Terminal.size + let terminalWidth = case window of + Just Terminal.Window {Terminal.width} -> width - 4 -- indentation + Nothing -> 80 + Diff.pretty + Diff.Config + { Diff.separatorText = Just funcName, + Diff.wrapping = Diff.Wrap terminalWidth + } + (PrettyShow expected) + (PrettyShow actual) + |> fail + |> Internal.unExpectation + +fromIO :: Prelude.IO a -> Task e a +fromIO io = Platform.Internal.Task (\_ -> map Ok io) + +newtype PrettyShow a = PrettyShow a + +instance Show a => Show (PrettyShow a) where + show (PrettyShow x) = Text.Show.Pretty.ppShow x diff --git a/src/Expect/Task.hs b/src/Expect/Task.hs --- a/src/Expect/Task.hs +++ b/src/Expect/Task.hs @@ -4,39 +4,34 @@ andCheck, succeeds, fails, - TestFailure, + Failure, ) where import qualified Debug import qualified Expect -import qualified Internal.Expectation -import qualified Internal.TestResult -import Internal.TestResult (TestFailure) import NriPrelude -import qualified Platform -import qualified Platform.DoAnything as DoAnything import qualified Task +import qualified Test.Internal as Internal +-- | Error generated when a test expectation is not met. +type Failure = Internal.Failure + -- | Check a task returns an expected value, than pass that value on. -- -- > task "Greetings are friendly" <| do -- > getGreeting -- > |> andCheck (Expect.equal "Hi!") -andCheck :: (a -> Expect.Expectation) -> Task TestFailure a -> Task TestFailure a -andCheck expectation t = do - x <- t - expectation x - |> Internal.Expectation.toResult - |> map Ok - |> Platform.doAnything DoAnything.Handler - |> Task.andThen - ( \res -> case res of - Internal.TestResult.Passed -> Task.succeed () - Internal.TestResult.Skipped -> Task.succeed () - Internal.TestResult.Failed message -> Task.fail message - ) - Task.succeed x +andCheck :: (a -> Expect.Expectation) -> Task Failure a -> Task Failure a +andCheck expectation task = do + x <- task + res <- + expectation x + |> Internal.unExpectation + |> Task.mapError never + case res of + Internal.Succeeded -> task + Internal.Failed failure -> Task.fail failure -- | Check an expectation in the middle of a @do@ block. -- @@ -45,7 +40,7 @@ -- > check (weightInKgs |> Expect.atMost 8) -- > soapInWasher -- > startMachine -check :: Expect.Expectation -> Task TestFailure () +check :: Expect.Expectation -> Task Failure () check expectation = Task.succeed () |> andCheck (\() -> expectation) @@ -55,18 +50,21 @@ -- > task "solve rubicskube" <| do -- > solveRubicsKube -- > |> succeeds -succeeds :: Show err => Task err a -> Task TestFailure a -succeeds = +succeeds :: Show err => Task err a -> Task Failure a +succeeds task = Task.mapError ( \message -> - Internal.TestResult.TestFailure (Debug.toString message) + Internal.FailedAssertion (Debug.toString message) ) + task -- | Check a task fails. -- -- > task "chemistry experiment" <| do -- > mixRedAndGreenLiquids -- > |> fails -fails :: Text -> Task TestFailure a -fails = - Task.fail << Internal.TestResult.TestFailure << Debug.toString +fails :: Text -> Task Failure a +fails msg = + msg + |> Internal.FailedAssertion + |> Task.fail diff --git a/src/Fuzz.hs b/src/Fuzz.hs --- a/src/Fuzz.hs +++ b/src/Fuzz.hs @@ -1,49 +1,218 @@ --- | This is a library of fuzzers you can use to supply values to your fuzz tests. You can typically pick out which ones you need according to their types. --- A @Fuzzer@ a knows how to create values of type @a@ in two different ways. It can create them randomly, so that your test's expectations are run against many values. Fuzzers will often generate edge cases likely to find bugs. If the fuzzer can make your test fail, it also knows how to "shrink" that failing input into more minimal examples, some of which might also cause the tests to fail. In this way, fuzzers can usually find the smallest or simplest input that reproduces a bug. +-- | This is a library of fuzzers you can use to supply values to your fuzz +-- tests. You can typically pick out which ones you need according to their +-- types. +-- +-- A @Fuzzer a@ knows how to create values of type @a@ in two different ways. +-- It can create them randomly, so that your test's expectations are run +-- against many values. Fuzzers will often generate edge cases likely to find +-- bugs. If the fuzzer can make your test fail, it also knows how to "shrink" +-- that failing input into more minimal examples, some of which might also +-- cause the tests to fail. In this way, fuzzers can usually find the smallest +-- or simplest input that reproduces a bug. module Fuzz ( -- * Common Fuzzers int, intRange, + float, + floatRange, + percentage, + text, + bool, + maybe, + result, list, + array, -- * Working with Fuzzers Fuzzer, + oneOf, + constant, + frequency, + + -- * Tuple Fuzzers + tuple, + tuple3, + + -- * Uncommon Fuzzers + char, + unit, + order, ) where -import qualified Hedgehog +import qualified Array import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import NriPrelude - -type Fuzzer = Hedgehog.Gen +import Test.Internal (Fuzzer (Fuzzer, unFuzzer)) +import qualified Prelude --- | A fuzzer for int values. It will never produce @NaN@, @Infinity@, or @-Infinity@. --- It's possible for this fuzzer to generate any 32-bit integer, signed or unsigned, but it favors --- numbers between -50 and 50 and especially zero. +-- | A fuzzer for int values. It will never produce @NaN@, @Infinity@, or +-- @-Infinity@. It's possible for this fuzzer to generate any 64-bit integer, +-- signed or unsigned, but it favors smaller numbers. int :: Fuzzer Int int = - Gen.frequency - [ (30, intRange (-50) 50), - (2, Gen.constant 0), - (10, intRange 0 (maxInt - minInt)), - (10, intRange (minInt - maxInt) 0) - ] + Gen.integral Range.exponentialBounded + |> Fuzzer -- | A fuzzer for int values between a given minimum and maximum value, --- inclusive. Shrunken values will also be within the range. --- Remember that [Random.maxInt](http://package.elm-lang.org/packages/elm-lang/core/latest/Random#maxInt) --- is the maximum possible int value, so you can do @intRange x Random.maxInt@ to get all --- the ints x or bigger. +-- inclusive. intRange :: Int -> Int -> Fuzzer Int -intRange min_ max_ = Gen.integral (Range.linear min_ max_) +intRange min_ max_ = + Gen.integral (Range.linearFrom (clamp min_ max_ 0) min_ max_) + |> Fuzzer --- | Given a fuzzer of a type, create a fuzzer of a list of that type. Generates random lists of varying length, favoring shorter lists. +-- | A fuzzer for float values. It will never produce NaN, Infinity, or +-- -Infinity. +-- +-- It's possible for this fuzzer to generate other floating-point value, but it +-- favors smaller numbers. +float :: Fuzzer Float +float = + Gen.double (Range.exponentialFloatFrom 0 (-1e100) 1e100) + |> Fuzzer + +-- | A fuzzer for float values within between a given minimum and maximum +-- value, inclusive. +floatRange :: Float -> Float -> Fuzzer Float +floatRange min_ max_ = + Gen.double (Range.linearFracFrom (clamp min_ max_ 0) min_ max_) + |> Fuzzer + +-- | A fuzzer for percentage values. Generates random floats between 0.0 and +-- 1.0. +percentage :: Fuzzer Float +percentage = + Gen.double (Range.linearFrac 0 1) + |> Fuzzer + +-- | Generates random printable ASCII strings of up to 1000 characters. +-- +-- Shorter strings are more common, especially the empty string. +text :: Fuzzer Text +text = + Gen.text (Range.exponential 0 1000) Gen.ascii + |> Fuzzer + +-- | A fuzzer for boolean values. It's useful when building up fuzzers of +-- complex types that contain a boolean somewhere. + +-- We recommend against writing tests fuzzing over booleans. Write a unit test +-- for the true and false cases explicitly. +bool :: Fuzzer Bool +bool = + Gen.bool + |> Fuzzer + +-- | Given a fuzzer of a type, create a fuzzer of a maybe for that type. +maybe :: Fuzzer a -> Fuzzer (Maybe a) +maybe (Fuzzer gen) = + Gen.maybe gen + |> Fuzzer + +-- | Given fuzzers for an error type and a success type, create a fuzzer for a +-- result. +result :: Fuzzer error -> Fuzzer value -> Fuzzer (Result error value) +result errorFuzzer valueFuzzer = + oneOf + [ map Err errorFuzzer, + map Ok valueFuzzer + ] + +-- | Given a fuzzer of a type, create a fuzzer of a list of that type. +-- Generates random lists of varying length, favoring shorter lists. list :: Fuzzer a -> Fuzzer (List a) -list = Gen.list (Range.linear 0 10) +list (Fuzzer gen) = + Gen.list (Range.exponential 0 100) gen + |> Fuzzer -maxInt :: Int -maxInt = 2147483647 +-- | Given a fuzzer of a type, create a fuzzer of an array of that type. +-- Generates random arrays of varying length, favoring shorter arrays. +array :: Fuzzer a -> Fuzzer (Array.Array a) +array itemFuzzer = + list itemFuzzer + |> map Array.fromList -minInt :: Int -minInt = -2147483648 +-- | Choose one of the given fuzzers at random. Each fuzzer has an equal chance +-- of being chosen; to customize the probabilities, use 'frequency'. +oneOf :: List (Fuzzer a) -> Fuzzer a +oneOf optionFuzzers = + map unFuzzer optionFuzzers + |> Gen.choice + |> Fuzzer + +-- | Create a fuzzer that only and always returns the value provided, and +-- performs no shrinking. This is hardly random, and so this function is best +-- used as a helper when creating more complicated fuzzers. +constant :: a -> Fuzzer a +constant x = + Gen.constant x + |> Fuzzer + +-- | Create a new Fuzzer by providing a list of probabilistic weights to use +-- with other fuzzers. For example, to create a Fuzzer that has a 1/4 chance of +-- generating an int between -1 and -100, and a 3/4 chance of generating one +-- between 1 and 100, you could do this: +-- +-- > Fuzz.frequency +-- > [ ( 1, Fuzz.intRange -100 -1 ) +-- > , ( 3, Fuzz.intRange 1 100 ) +-- > ] +-- +-- There are a few circumstances in which this function will return an invalid +-- fuzzer, which causes it to fail any test that uses it: +-- +-- - If you provide an empty list of frequencies +-- - If any of the weights are less than 0 +-- - If the weights sum to 0 +-- - Be careful recursively using this fuzzer in its arguments. Often using map +-- is a better way to do what you want. If you are fuzzing a tree-like data +-- structure, you should include a depth limit so to avoid infinite recursion, +-- like so: +-- +-- > data Tree +-- > = Leaf +-- > | Branch Tree Tree +-- > +-- > tree :: Int -> Fuzzer Tree +-- > tree i = +-- > if i <= 0 then +-- > Fuzz.constant Leaf +-- > +-- > else +-- > Fuzz.frequency +-- > [ ( 1, Fuzz.constant Leaf ) +-- > , ( 2, Fuzz.map2 Branch (tree (i - 1)) (tree (i - 1)) ) +-- > ] +frequency :: List (Float, Fuzzer a) -> Fuzzer a +frequency optionFuzzers = + optionFuzzers + |> map (\(float', (Fuzzer gen)) -> (Prelude.round (float' * 1000000), gen)) + |> Gen.frequency + |> Fuzzer + +-- | Turn a tuple of fuzzers into a fuzzer of tuples. +tuple :: (Fuzzer a, Fuzzer b) -> Fuzzer (a, b) +tuple (fuzzerA, fuzzerB) = + map2 (,) fuzzerA fuzzerB + +-- | Turn a 3-tuple of fuzzers into a fuzzer of 3-tuples. +tuple3 :: (Fuzzer a, Fuzzer b, Fuzzer c) -> Fuzzer (a, b, c) +tuple3 (fuzzerA, fuzzerB, fuzzerC) = + map3 (,,) fuzzerA fuzzerB fuzzerC + +-- | A fuzzer for char values. Generates random ascii chars disregarding the +-- control characters and the extended character set. +char :: Fuzzer Char +char = + Gen.ascii + |> Fuzzer + +-- | A fuzzer for the unit value. Unit is a type with only one value, commonly +-- used as a placeholder. +unit :: Fuzzer () +unit = constant () + +-- | A fuzzer for order values. +order :: Fuzzer Ordering +order = oneOf [constant EQ, constant LT, constant GT] diff --git a/src/Internal/Expectation.hs b/src/Internal/Expectation.hs deleted file mode 100644 --- a/src/Internal/Expectation.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Internal.Expectation - ( Expectation, - pass, - fail, - join, - build, - toResult, - fromResult, - fromIO, - onFail, - ) -where - -import Control.Monad.IO.Class (liftIO) -import qualified Internal.TestResult as TestResult -import Internal.TestResult (TestResult) -import NriPrelude -import Prelude (Applicative, Functor, IO, Monad, Show, pure) - -newtype Expectation a = Expectation (IO a) - deriving (Functor, Applicative, Monad) - -fromIO :: IO a -> Expectation a -fromIO = Expectation << liftIO - -join :: Expectation TestResult -> Expectation TestResult -> Expectation TestResult -join (Expectation x) (Expectation y) = Expectation (map2 TestResult.join x y) - -pass :: Expectation TestResult -pass = Expectation (pure TestResult.passed) - -fail :: Text -> Expectation TestResult -fail = Expectation << pure << TestResult.failed - -onFail :: Text -> Expectation TestResult -> Expectation TestResult -onFail message = - fmap (TestResult.onFail message) - -build :: Show a => (a -> a -> Bool) -> Text -> a -> a -> Expectation TestResult -build pred funcName x y = - TestResult.fromPredicate pred funcName x y - |> Expectation - -toResult :: Expectation TestResult -> IO TestResult -toResult (Expectation r) = r - -fromResult :: TestResult.TestFailure -> Expectation TestResult -fromResult r = Expectation (pure (TestResult.Failed r)) diff --git a/src/Internal/Test.hs b/src/Internal/Test.hs deleted file mode 100644 --- a/src/Internal/Test.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE GADTs #-} - -module Internal.Test - ( Test (Describe, Test, Skip, Only, Todo, Fuzz, FromTestTree), - FuzzerFunction (Fuzzer1, Fuzzer2, Fuzzer3), - FuzzReplay (FuzzReplay), - run, - name, - hasOnly, - rejectTestTree, - ) -where - -import qualified Control.Exception.Safe as Exception -import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Data.Text -import Fuzz (Fuzzer) -import qualified Hedgehog -import qualified Hedgehog.Internal.Property as Hedgehog.Property -import qualified Hedgehog.Internal.Report as Hedgehog.Report -import qualified Hedgehog.Internal.Runner as Hedgehog.Runner -import qualified Hedgehog.Internal.Seed as Seed -import qualified Internal.Expectation -import Internal.Expectation (Expectation) -import qualified Internal.TestResult -import Internal.TestResult (TestResult) -import List (List) -import qualified List -import NriPrelude -import Test.Tasty (TestTree) -import qualified Text -import Prelude (IO, Monad, Show, pure, show, traverse) - -data Test where - Test :: Text -> (() -> Expectation TestResult) -> Test - Describe :: Text -> List Test -> Test - Skip :: Test -> Test - Only :: Test -> Test - Todo :: Text -> Test - Fuzz :: FuzzerFunction -> Text -> Test - FromTestTree :: Text -> TestTree -> Test - -data FuzzerFunction where - Fuzzer1 :: - forall a. - (Show a) => - Fuzzer a -> - (a -> Expectation TestResult) -> - FuzzerFunction - Fuzzer2 :: - forall a b. - (Show a, Show b) => - Fuzzer a -> - Fuzzer b -> - (a -> b -> Expectation TestResult) -> - FuzzerFunction - Fuzzer3 :: - forall a b c. - (Show a, Show b, Show c) => - Fuzzer a -> - Fuzzer b -> - Fuzzer c -> - (a -> b -> c -> Expectation TestResult) -> - FuzzerFunction - --- - --- | The replay token to use for replaying a previous test run -newtype FuzzReplay = FuzzReplay (Maybe (Hedgehog.Size, Hedgehog.Seed)) - -run :: FuzzReplay -> Test -> IO TestResult -run replay test = - Exception.handle handleException <| case test of - Describe _ tests -> - -- NOTE: Tasty actually never runs this, because it builds it's own tree. - tests - |> rejectTestTree - |> traverse (run replay) - |> fmap Internal.TestResult.concat - Test _ testToRun -> Internal.Expectation.toResult (testToRun ()) - Skip _ -> pure Internal.TestResult.skipped - Only test_ -> run replay test_ - Todo _ -> pure <| Internal.TestResult.failed "TODO" - FromTestTree _ _ -> - "This should never happen sorry." - |> Internal.TestResult.failed - |> pure - Fuzz gen _ -> - genForAll gen - |> andThen (liftIO << Internal.Expectation.toResult) - |> andThen (liftIO << Internal.TestResult.throwFailingTest) - |> handleProperty replay - |> andThen - ( \reportStatus -> - case reportStatus of - Hedgehog.Report.OK -> pure Internal.TestResult.passed - Hedgehog.Report.GaveUp -> - [ "Gave up!", - "You can rerun this test with the following command:", - " stack test {package} --test-arguments '--seed \"Size {size} Seed {seed} {seed}\"'", - "Search for a line containing the word `recheck` to locate the Size and Seed" - ] - |> Text.join "\n" - |> Internal.TestResult.failed - |> pure - Hedgehog.Report.Failed - Hedgehog.Report.FailureReport - { Hedgehog.Report.failureMessage, - Hedgehog.Report.failureSeed, - Hedgehog.Report.failureSize - } -> - [ Data.Text.pack failureMessage, - "You can rerun this test with the following command:", - " stack test {package} --test-arguments '--seed \"" - ++ Data.Text.pack (show failureSize) - ++ " " - ++ Data.Text.pack (show failureSeed) - ++ "\"'", - "Search for a line containing the word `recheck` to locate the Size and Seed" - ] - |> Text.join "\n" - |> Internal.TestResult.failed - |> pure - ) - -rejectTestTree :: List Test -> List Test -rejectTestTree tests = - case tests of - [] -> [] - FromTestTree _ _ : rest -> rejectTestTree rest - t : rest -> t : rejectTestTree rest - -genForAll :: - Monad m => - FuzzerFunction -> - Hedgehog.PropertyT m (Expectation TestResult) -genForAll fuzzerFunction = - case fuzzerFunction of - Fuzzer1 a cb -> - map cb (Hedgehog.forAll a) - Fuzzer2 a b cb -> - map2 - cb - (Hedgehog.forAll a) - (Hedgehog.forAll b) - Fuzzer3 a b c cb -> - map3 - cb - (Hedgehog.forAll a) - (Hedgehog.forAll b) - (Hedgehog.forAll c) - -handleProperty :: FuzzReplay -> Hedgehog.PropertyT IO () -> IO Hedgehog.Report.Result -handleProperty (FuzzReplay replay) prop = - case replay of - Nothing -> Hedgehog.property prop |> checkProperty - Just (size, seed) -> Hedgehog.property prop |> recheck size seed - --- | Check a property using a specific size and seed. -recheck :: MonadIO m => Hedgehog.Size -> Hedgehog.Seed -> Hedgehog.Property -> m Hedgehog.Report.Result -recheck size seed prop0 = - Hedgehog.withTests 1 prop0 - |> checkHedgehog size seed - |> liftIO - -checkProperty :: MonadIO m => Hedgehog.Property -> m Hedgehog.Report.Result -checkProperty prop = liftIO <| do - seed <- Seed.random - checkHedgehog 0 seed prop - -checkHedgehog :: - MonadIO m => - Hedgehog.Size -> - Hedgehog.Seed -> - Hedgehog.Property -> - m Hedgehog.Report.Result -checkHedgehog - size - seed - Hedgehog.Property.Property - { Hedgehog.Property.propertyConfig, - Hedgehog.Property.propertyTest - } = - Hedgehog.Runner.checkReport propertyConfig size seed propertyTest (\_ -> pure ()) - |> map Hedgehog.Report.reportStatus - |> liftIO - -handleException :: Exception.SomeException -> IO TestResult -handleException exception = - let exceptionMessage = - exception - |> Exception.displayException - |> Data.Text.pack - in [ "There was an unexpected exception!", - "", - " " ++ exceptionMessage, - "" - ] - |> Data.Text.unlines - |> Internal.TestResult.failed - |> pure - -name :: Test -> Text -name test = - case test of - Test n _ -> n - Describe n _ -> n - Skip test_ -> name test_ - Only test_ -> name test_ - Todo n -> n - FromTestTree n _ -> n - Fuzz _ n -> n - -hasOnly :: Test -> Maybe Test -hasOnly test = - case test of - Only t -> Just t - Test _ _ -> Nothing - Describe _ tests -> - tests - |> rejectTestTree - |> List.filterMap hasOnly - |> List.head - Skip _ -> Nothing - Todo _ -> Nothing - FromTestTree _ _ -> Nothing - Fuzz {} -> Nothing diff --git a/src/Internal/TestResult.hs b/src/Internal/TestResult.hs deleted file mode 100644 --- a/src/Internal/TestResult.hs +++ /dev/null @@ -1,108 +0,0 @@ -module Internal.TestResult - ( TestResult (Passed, Failed, Skipped), - TestFailure (TestFailure), - concat, - join, - passed, - failed, - skipped, - onFail, - fromPredicate, - throwFailingTest, - ) -where - -import Control.Exception.Safe (Exception, throwIO) -import Data.Dynamic (Typeable) -import qualified Data.Text -import List (List) -import qualified List -import NriPrelude -import qualified Pretty.Diff as Diff -import qualified System.Console.Terminal.Size as Terminal -import qualified Text -import qualified Text.Show.Pretty -import Prelude (IO, Monoid, Semigroup ((<>)), Show, pure, show) - -data TestResult - = Passed - | Skipped - | Failed TestFailure - -passed :: TestResult -passed = Passed - -failed :: Text -> TestResult -failed = Failed << TestFailure - -skipped :: TestResult -skipped = Skipped - -onFail :: Text -> TestResult -> TestResult -onFail message result = - case result of - Passed -> result - Skipped -> result - Failed _ -> failed message - -concat :: List TestResult -> TestResult -concat xs = - case xs of - [] -> Passed - x : rest -> join x (concat rest) - -join :: TestResult -> TestResult -> TestResult -join a b = - case (a, b) of - (Passed, Passed) -> Passed - (Passed, Failed x) -> Failed x - (Passed, Skipped) -> Skipped - (Failed x, Failed y) -> Failed (x <> y) - (Failed x, Passed) -> Failed x - (Failed x, Skipped) -> Failed x - (Skipped, Skipped) -> Skipped - (Skipped, Passed) -> Skipped - (Skipped, Failed x) -> Failed x - -fromPredicate :: Show a => (a -> a -> Bool) -> Text -> a -> a -> IO TestResult -fromPredicate pred funcName actual expected = - if pred actual expected - then pure Passed - else do - window <- Terminal.size - let terminalWidth = case window of - Just Terminal.Window {Terminal.width} -> width - 4 -- indentation - Nothing -> 80 - Diff.pretty - Diff.Config - { Diff.separatorText = Just funcName, - Diff.wrapping = Diff.Wrap terminalWidth - } - (PrettyShow expected) - (PrettyShow actual) - |> failed - |> pure - -newtype PrettyShow a = PrettyShow a - -instance Show a => Show (PrettyShow a) where - show (PrettyShow x) = Text.Show.Pretty.ppShow x - --- | Error generated when a test expectation is not met. -newtype TestFailure = TestFailure Text - deriving (Typeable, Semigroup, Monoid) - -instance Exception TestFailure - -instance Show TestFailure where - show (TestFailure err) = Data.Text.unpack (indent err) - -throwFailingTest :: TestResult -> IO () -throwFailingTest result = - case result of - Passed -> pure () - Skipped -> pure () - Failed err -> throwIO err - -indent :: Text -> Text -indent = Data.Text.lines >> List.map (" " <>) >> Text.join "\n" diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -1,231 +1,61 @@ -- | A module containing functions for creating and managing tests. module Test ( -- * Organizing Tests - Test, - test, - describe, - concat, - skip, - only, - todo, + Internal.Test, + Internal.test, + Internal.describe, + Internal.skip, + Internal.only, + Internal.todo, -- * Fuzz Testing - fuzz, - fuzz2, - fuzz3, - fromTestTree, + Internal.fuzz, + Internal.fuzz2, + Internal.fuzz3, -- * Task Testing - task, + Internal.task, + + -- * Running test + run, ) where -import qualified Data.Text -import qualified Expect -import Fuzz (Fuzzer) -import qualified Internal.Expectation -import qualified Internal.Test -import Internal.TestResult (TestFailure) import NriPrelude import qualified Platform +import qualified System.Environment +import qualified System.FilePath as FilePath +import qualified System.IO import qualified Task -import Test.Tasty (TestName, TestTree) -import Prelude (Show) - --- | 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@. -type Test = Internal.Test.Test - --- | 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 -> List Test -> Test -describe = - Internal.Test.Describe - --- | Run each of the given tests. --- --- > concat [ testDecoder, testSorting ] -concat :: List Test -> Test -concat = - Internal.Test.Describe "" - --- | 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 :: Text -> (() -> Expect.Expectation) -> Test -test = - Internal.Test.Test - --- | 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 = Internal.Test.Skip - --- | 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 = Internal.Test.Only - --- | 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 :: Text -> Test -todo = Internal.Test.Todo +import qualified Test.Internal as Internal +import qualified Test.Reporter.ExitCode +import qualified Test.Reporter.Junit +import qualified Test.Reporter.Stdout +import qualified Prelude --- | Take a function that produces a test, and calls it several times, using a --- randomly-generated input from a 'Fuzz.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](https://en.wikipedia.org/wiki/Fuzz_testing)" because of the randomness. You may find them elsewhere called [property-based tests](http://blog.jessitron.com/2013/04/property-based-testing-what-is-it.html), [generative tests](http://www.pivotaltracker.com/community/tracker-blog/generative-testing), or [QuickCheck-style tests](https://en.wikipedia.org/wiki/QuickCheck). +-- | Turn a test suite into a program that can be executed in Haskell. Use like +-- this: -- --- > import Test (fuzz) --- > import Fuzz (list, int) --- > import Expect +-- > module Main (main) where -- > --- > fuzz (list int) "List.length should always be positive" <| --- > -- This anonymous function will be run 100 times, each time with a --- > -- randomly-generated fuzzList value. --- > \fuzzList -> --- > fuzzList --- > |> List.length --- > |> Expect.atLeast 0 --- --- NOTE: You can use any Hedgehog.Gen for Fuzzer. -fuzz :: Show a => Fuzzer a -> Text -> (a -> Expect.Expectation) -> Test -fuzz a name cb = Internal.Test.Fuzz (Internal.Test.Fuzzer1 a cb) name - --- | Run a fuzz test using two random inputs. --- --- > import Test (fuzz2) --- > import Fuzz (list, int) +-- > import qualified Test -- > --- > fuzz2 (list int) int "List.reverse never influences List.member" <| --- > \nums target -> --- > List.member target (List.reverse nums) --- > |> Expect.equal (List.member target nums) -fuzz2 :: (Show a, Show b) => Fuzzer a -> Fuzzer b -> Text -> (a -> b -> Expect.Expectation) -> Test -fuzz2 a b name cb = Internal.Test.Fuzz (Internal.Test.Fuzzer2 a b cb) name - --- | Run a fuzz test using three random inputs. -fuzz3 :: (Show a, Show b, Show c) => Fuzzer a -> Fuzzer b -> Fuzzer c -> Text -> (a -> b -> c -> Expect.Expectation) -> Test -fuzz3 a b c name cb = Internal.Test.Fuzz (Internal.Test.Fuzzer3 a b c cb) name - --- | Embed arbitrary Tasty @TestTree@ among your other tests. -fromTestTree :: Text -> (TestName -> TestTree) -> Test -fromTestTree n f = - Internal.Test.FromTestTree n (f (Data.Text.unpack n)) - --- | Run a test that executes a task. The test passes if the task returns a --- success value. -task :: Text -> Task TestFailure a -> Test -task n expectation = - Internal.Test.Test n (\() -> runTask expectation) +-- > main :: IO () +-- > main = Test.run (Test.todo "write your tests here!") +run :: Internal.Test -> Prelude.IO () +run suite = do + log <- Platform.silentHandler + results <- Task.perform log (Internal.run suite) + Test.Reporter.Stdout.report System.IO.stdout results + args <- System.Environment.getArgs + case getPath args of + Nothing -> Prelude.pure () + Just path -> Test.Reporter.Junit.report path results + Test.Reporter.ExitCode.report results -runTask :: Task TestFailure a -> Expect.Expectation -runTask t = - Expect.withIO - ( \res -> - case res of - Ok _ -> Expect.pass - Err message -> Internal.Expectation.fromResult message - ) - <| do - noLogger <- Platform.silentHandler - Task.attempt noLogger t +getPath :: [Prelude.String] -> Maybe FilePath.FilePath +getPath args = + case args of + [] -> Nothing + "--xml" : path : _ -> Just path + _ : rest -> getPath rest diff --git a/src/Test/Console/Color.hs b/src/Test/Console/Color.hs deleted file mode 100644 --- a/src/Test/Console/Color.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Test.Console.Color - ( Style, - styled, - - -- * colors - blue, - grey, - magenta, - red, - yellow, - ) -where - -import qualified Data.Text -import List (List) -import NriPrelude -import qualified System.Console.ANSI as Console -import Text (Text) - -type Style = List Console.SGR - -code :: Style -> Text -code = Data.Text.pack << Console.setSGRCode - -styled :: Style -> Text -> Text -styled col t = code col ++ t ++ code [reset] - -reset :: Console.SGR -reset = Console.Reset - -red :: Console.SGR -red = Console.SetColor Console.Foreground Console.Dull Console.Red - -magenta :: Console.SGR -magenta = Console.SetColor Console.Foreground Console.Dull Console.Magenta - -blue :: Console.SGR -blue = Console.SetColor Console.Foreground Console.Dull Console.Blue - -yellow :: Console.SGR -yellow = Console.SetColor Console.Foreground Console.Dull Console.Yellow - -grey :: Console.SGR -grey = Console.SetColor Console.Foreground Console.Dull Console.White diff --git a/src/Test/Internal.hs b/src/Test/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Test/Internal.hs @@ -0,0 +1,475 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NumericUnderscores #-} + +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.Internal +import qualified Task +import qualified Tuple +import qualified Prelude + +data SingleTest a + = SingleTest + { describes :: [Text], + name :: Text, + label :: Label, + loc :: Maybe Stack.SrcLoc, + body :: a + } + deriving (Prelude.Functor) + +data Label = None | Skip | Only | Todo + deriving (Eq, Ord) + +data TestResult + = Succeeded + | Failed Failure + +data Failure + = FailedAssertion Text + | ThrewException Exception.SomeException + | TookTooLong + | TestRunnerMessedUp Text + deriving (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 {unTest :: [SingleTest Expectation]} + +-- | The result of a single test run: either a 'pass' or a 'fail'. +newtype Expectation = Expectation {unExpectation :: Task Never TestResult} + +-- | 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 {unFuzzer :: Hedgehog.Gen a} + deriving (Prelude.Functor, 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 description tests = + tests + |> List.concatMap unTest + |> List.map (\test' -> test' {describes = description : describes 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 name = + Test + [ SingleTest + { describes = [], + name = name, + loc = Stack.withFrozenCallStack getFrame, + label = Todo, + body = Expectation (Task.succeed Succeeded) + } + ] + +-- | 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 name expectation = + Test + [ SingleTest + { describes = [], + name = name, + loc = Stack.withFrozenCallStack getFrame, + label = None, + body = handleUnexpectedErrors (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 name expectation = + Test + [ SingleTest + { describes = [], + name = name, + loc = Stack.withFrozenCallStack getFrame, + label = None, + body = fuzzBody fuzzer 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 genA) (Fuzzer genB) name expectation = + Test + [ SingleTest + { describes = [], + name = name, + loc = Stack.withFrozenCallStack getFrame, + label = None, + body = + fuzzBody + (Fuzzer (map2 (,) genA genB)) + (\(a, b) -> expectation a 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 genA) (Fuzzer genB) (Fuzzer genC) name expectation = + Test + [ SingleTest + { describes = [], + name = name, + loc = Stack.withFrozenCallStack getFrame, + label = None, + body = + fuzzBody + (Fuzzer (map3 (,,) genA genB genC)) + (\(a, b, c) -> expectation a b c) + } + ] + +fuzzBody :: Show a => Fuzzer a -> (a -> Expectation) -> Expectation +fuzzBody (Fuzzer gen) expectation = + Expectation + <| Platform.Internal.Task + ( \log -> do + seed <- Hedgehog.Internal.Seed.random + failureRef <- IORef.newIORef Nothing + hedgehogResult <- + Hedgehog.Internal.Runner.checkReport + Hedgehog.Internal.Property.defaultConfig + 0 -- Same value used as in Hedgehog internals. + seed + ( do + generated <- Hedgehog.forAll gen + result <- + expectation generated + |> handleUnexpectedErrors + |> unExpectation + |> Task.perform log + |> Control.Monad.IO.Class.liftIO + case result of + Succeeded -> Prelude.pure () + Failed failure -> do + IORef.writeIORef failureRef (Just failure) + |> Control.Monad.IO.Class.liftIO + Hedgehog.failure + ) + (\_ -> Prelude.pure ()) + case Hedgehog.Internal.Report.reportStatus hedgehogResult of + Hedgehog.Internal.Report.Failed _ -> do + maybeFailure <- IORef.readIORef failureRef + case maybeFailure of + Nothing -> + TestRunnerMessedUp "I lost the error report of a failed fuzz test test." + |> Failed + |> Ok + |> Prelude.pure + Just failure -> + Failed failure + |> Ok + |> Prelude.pure + Hedgehog.Internal.Report.GaveUp -> + TestRunnerMessedUp "I couldn't generate any values for a fuzz test." + |> Failed + |> Ok + |> Prelude.pure + Hedgehog.Internal.Report.OK -> + Ok Succeeded + |> 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 tests) = + Test <| List.map (\test' -> test' {label = Skip}) 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 tests) = + Test <| List.map (\test' -> test' {label = Only}) tests + +-- | Run a test that executes a task. The test passes if the task returns a +-- success value. +task :: Stack.HasCallStack => Text -> Task Failure a -> Test +task name expectation = + Test + [ SingleTest + { describes = [], + name = name, + loc = Stack.withFrozenCallStack getFrame, + label = None, + body = + expectation + |> Task.map (\_ -> Succeeded) + |> Task.onError (Task.succeed << Failed) + |> Expectation + |> handleUnexpectedErrors + } + ] + +run :: Test -> Task e SuiteResult +run (Test all) = do + let grouped = groupBy label all + let skipped = Dict.get Skip grouped |> Maybe.withDefault [] + let todos = Dict.get Todo grouped |> Maybe.withDefault [] + let containsOnlys = + case Dict.get Only grouped |> Maybe.withDefault [] of + [] -> False + _ -> True + let doRun label = + if containsOnlys + then label == Only + else label == None + let (toRun, notToRun') = + Dict.toList grouped + |> List.partition (doRun << Tuple.first) + |> Tuple.mapBoth (List.concatMap Tuple.second) (List.concatMap Tuple.second) + let notToRun = List.map (\test' -> test' {body = NotRan}) notToRun' + results <- Task.parallel (List.map runSingle toRun) + let (failed, passed) = + results + |> List.map + ( \test' -> + case body test' of + (tracingSpan, Failed failure) -> + Prelude.Left test' {body = (tracingSpan, failure)} + (tracingSpan, Succeeded) -> + Prelude.Right test' {body = tracingSpan} + ) + |> Data.Either.partitionEithers + let summary = + Summary + { noTests = List.isEmpty all, + allPassed = List.isEmpty failed, + anyOnlys = containsOnlys, + noneSkipped = List.isEmpty (skipped ++ todos) + } + Task.succeed <| case summary of + Summary {noTests = True} -> NoTestsInSuite + Summary {allPassed = False} -> TestsFailed passed notToRun failed + Summary {anyOnlys = True} -> OnlysPassed passed notToRun + Summary {noneSkipped = False} -> PassedWithSkipped passed notToRun + Summary {} -> AllPassed passed + +data Summary + = Summary + { noTests :: Bool, + allPassed :: Bool, + anyOnlys :: Bool, + noneSkipped :: Bool + } + +handleUnexpectedErrors :: Expectation -> Expectation +handleUnexpectedErrors (Expectation task') = + task' + |> Task.mapError never + |> onException (Task.succeed << Failed << ThrewException) + |> Task.timeout 10_000 TookTooLong + |> Task.onError (Task.succeed << Failed) + |> Expectation + +runSingle :: SingleTest Expectation -> Task e (SingleTest (TracingSpan, TestResult)) +runSingle test' = + Platform.Internal.Task + ( \_ -> do + spanVar <- MVar.newEmptyMVar + res <- + Platform.Internal.rootTracingSpanIO + "" + (MVar.putMVar spanVar) + "run single test" + ( \log -> + body test' + |> unExpectation + |> Task.mapError never + |> map Ok + |> Task.perform log + ) + span <- MVar.takeMVar spanVar + res + |> map (\res' -> test' {body = (span, res')}) + |> Prelude.pure + ) + +ioToTask :: Prelude.IO a -> Task Exception.SomeException a +ioToTask io = + Platform.Internal.Task <| \_ -> + Exception.handleAny (Prelude.pure << Err) (map Ok io) + +onException :: (Exception.SomeException -> Task e a) -> Task e a -> Task e a +onException f (Platform.Internal.Task run') = + Platform.Internal.Task + ( \log -> + run' log + |> Exception.handleAny (Task.attempt log << f) + ) + +getFrame :: Stack.HasCallStack => Maybe Stack.SrcLoc +getFrame = + Stack.callStack + |> Stack.getCallStack + |> List.head + |> map Tuple.second + +groupBy :: Ord key => (a -> key) -> [a] -> Dict.Dict key [a] +groupBy key xs = + List.foldr + ( \x acc -> + Dict.update + (key x) + ( \val -> + Just + <| case val of + Nothing -> [x] + Just ys -> x : ys + ) + acc + ) + Dict.empty + xs + +append :: Expectation -> Expectation -> Expectation +append (Expectation task1) (Expectation task2) = + task1 + |> andThen + ( \result1 -> + case result1 of + Succeeded -> task2 + Failed _ -> task1 + ) + |> Expectation diff --git a/src/Test/Reporter/ExitCode.hs b/src/Test/Reporter/ExitCode.hs new file mode 100644 --- /dev/null +++ b/src/Test/Reporter/ExitCode.hs @@ -0,0 +1,11 @@ +module Test.Reporter.ExitCode (report) where + +import qualified System.Exit +import qualified Test.Internal as Internal +import qualified Prelude + +report :: Internal.SuiteResult -> Prelude.IO () +report results = + case results of + Internal.AllPassed _ -> System.Exit.exitSuccess + _ -> System.Exit.exitFailure diff --git a/src/Test/Reporter/Junit.hs b/src/Test/Reporter/Junit.hs new file mode 100644 --- /dev/null +++ b/src/Test/Reporter/Junit.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE NumericUnderscores #-} + +-- | Module for presenting test results as a Junit XML file. +-- +-- Lifted in large part from: https://github.com/stoeffel/tasty-test-reporter +module Test.Reporter.Junit + ( report, + ) +where + +import qualified Control.Exception.Safe as Exception +import qualified Data.Text +import qualified GHC.Stack as Stack +import qualified List +import NriPrelude +import qualified Platform +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath +import qualified Test.Internal as Internal +import qualified Text +import qualified Text.XML.JUnit as JUnit +import qualified Prelude + +report :: FilePath.FilePath -> Internal.SuiteResult -> Prelude.IO () +report path result = do + createPathDirIfMissing path + JUnit.writeXmlReport path (testResults result) + +testResults :: Internal.SuiteResult -> List JUnit.TestSuite +testResults result = + case result of + Internal.AllPassed passed -> + List.map renderPassed passed + Internal.OnlysPassed passed skipped -> + List.map renderSkipped skipped + ++ List.map renderPassed passed + Internal.PassedWithSkipped passed skipped -> + List.map renderSkipped skipped + ++ List.map renderPassed passed + Internal.TestsFailed passed skipped failed -> + List.map renderFailed failed + ++ List.map renderSkipped skipped + ++ List.map renderPassed passed + Internal.NoTestsInSuite -> [] + +renderPassed :: Internal.SingleTest Platform.TracingSpan -> JUnit.TestSuite +renderPassed test = + JUnit.passed (Internal.name test) + |> JUnit.time (duration (Internal.body test)) + |> JUnit.inSuite (suiteName test) + +renderSkipped :: Internal.SingleTest Internal.NotRan -> JUnit.TestSuite +renderSkipped test = + JUnit.skipped (Internal.name test) + |> JUnit.inSuite (suiteName test) + +renderFailed :: Internal.SingleTest (Platform.TracingSpan, Internal.Failure) -> JUnit.TestSuite +renderFailed test = + case Internal.body test of + (tracingSpan, Internal.FailedAssertion msg) -> + JUnit.failed (Internal.name test) + |> JUnit.stderr msg + |> ( case stackFrame test of + Nothing -> identity + Just frame -> JUnit.failureStackTrace [frame] + ) + |> JUnit.time (duration tracingSpan) + |> JUnit.inSuite (suiteName test) + (tracingSpan, Internal.ThrewException err) -> + JUnit.errored (Internal.name test) + |> JUnit.errorMessage "This test threw an exception." + |> JUnit.stderr (Data.Text.pack (Exception.displayException err)) + |> ( case stackFrame test of + Nothing -> identity + Just frame -> JUnit.errorStackTrace [frame] + ) + |> JUnit.time (duration tracingSpan) + |> JUnit.inSuite (suiteName test) + (tracingSpan, Internal.TookTooLong) -> + JUnit.errored (Internal.name test) + |> JUnit.errorMessage "This test timed out." + |> ( case stackFrame test of + Nothing -> identity + Just frame -> JUnit.errorStackTrace [frame] + ) + |> JUnit.time (duration tracingSpan) + |> JUnit.inSuite (suiteName test) + (tracingSpan, Internal.TestRunnerMessedUp msg) -> + JUnit.errored (Internal.name test) + |> JUnit.errorMessage + ( Text.join + "\n" + [ "Test runner encountered an unexpected error:", + msg, + "", + "This is a bug.", + "If you have some time to report the bug it would be much appreciated!", + "You can do so here: https://github.com/NoRedInk/haskell-libraries/issues" + ] + ) + |> ( case stackFrame test of + Nothing -> identity + Just frame -> JUnit.errorStackTrace [frame] + ) + |> JUnit.time (duration tracingSpan) + |> JUnit.inSuite (suiteName test) + +suiteName :: Internal.SingleTest a -> Text +suiteName test = + Internal.describes test + |> Text.join " - " + +stackFrame :: Internal.SingleTest a -> Maybe Text +stackFrame test = + Internal.loc test + |> map + ( \loc -> + Data.Text.pack + ( Stack.srcLocFile loc + ++ ":" + ++ Prelude.show (Stack.srcLocStartLine loc) + ) + ) + +duration :: Platform.TracingSpan -> Float +duration test = + let duration' = Platform.finished test - Platform.started test + in Prelude.fromIntegral (Platform.inMicroseconds duration') / 1000_000 + +createPathDirIfMissing :: FilePath.FilePath -> Prelude.IO () +createPathDirIfMissing path = do + dirPath <- map FilePath.takeDirectory (Directory.canonicalizePath path) + Directory.createDirectoryIfMissing True dirPath diff --git a/src/Test/Reporter/Stdout.hs b/src/Test/Reporter/Stdout.hs new file mode 100644 --- /dev/null +++ b/src/Test/Reporter/Stdout.hs @@ -0,0 +1,173 @@ +-- | Module for presenting test results on the console. +-- +-- Lifted in large part from: https://github.com/stoeffel/tasty-test-reporter +module Test.Reporter.Stdout + ( report, + ) +where + +import qualified Control.Exception as Exception +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text.Encoding as TE +import qualified GHC.Stack as Stack +import qualified List +import NriPrelude +import qualified System.Console.ANSI as ANSI +import qualified System.IO +import qualified Test.Internal as Internal +import qualified Tuple +import qualified Prelude + +report :: System.IO.Handle -> Internal.SuiteResult -> Prelude.IO () +report handle results = do + color <- ANSI.hSupportsANSIColor handle + let styled = + if color + then (\styles builder -> sgr styles ++ builder ++ sgr [ANSI.Reset]) + else (\_ builder -> builder) + let reportByteString = renderReport styled results + Builder.hPutBuilder handle reportByteString + System.IO.hFlush handle + +renderReport :: + ([ANSI.SGR] -> Builder.Builder -> Builder.Builder) -> + Internal.SuiteResult -> + Builder.Builder +renderReport styled results = + case results of + Internal.AllPassed passed -> + let amountPassed = List.length passed + in styled [green, underlined] "TEST RUN PASSED" + ++ "\n\n" + ++ styled [black] ("Passed: " ++ Builder.int64Dec amountPassed) + ++ "\n" + Internal.OnlysPassed passed skipped -> + let amountPassed = List.length passed + amountSkipped = List.length skipped + in Prelude.foldMap + ( \only -> + prettyPath styled [yellow] only + ++ "This test passed, but there is a `Test.only` in your test.\n" + ++ "I failed the test, because it's easy to forget to remove `Test.only`.\n" + ++ "\n\n" + ) + passed + ++ styled [yellow, underlined] "TEST RUN INCOMPLETE" + ++ styled [yellow] " because there is an `only` in your tests." + ++ "\n\n" + ++ styled [black] ("Passed: " ++ Builder.int64Dec amountPassed) + ++ "\n" + ++ styled [black] ("Skipped: " ++ Builder.int64Dec amountSkipped) + ++ "\n" + Internal.PassedWithSkipped passed skipped -> + let amountPassed = List.length passed + amountSkipped = List.length skipped + in Prelude.foldMap + ( \only -> + prettyPath styled [yellow] only + ++ "This test was skipped." + ++ "\n\n" + ) + skipped + ++ styled [yellow, underlined] "TEST RUN INCOMPLETE" + ++ styled + [yellow] + ( case List.length skipped of + 1 -> " because 1 test was skipped" + n -> " because " ++ Builder.int64Dec n ++ " tests were skipped" + ) + ++ "\n\n" + ++ styled [black] ("Passed: " ++ Builder.int64Dec amountPassed) + ++ "\n" + ++ styled [black] ("Skipped: " ++ Builder.int64Dec amountSkipped) + ++ "\n" + Internal.TestsFailed passed skipped failed -> + let amountPassed = List.length passed + amountFailed = List.length failed + amountSkipped = List.length skipped + in Prelude.foldMap + ( \test -> + prettyPath styled [red] test + ++ testFailure test + ++ "\n\n" + ) + (List.map (map Tuple.second) failed) + ++ styled [red, underlined] "TEST RUN FAILED" + ++ "\n\n" + ++ styled [black] ("Passed: " ++ Builder.int64Dec amountPassed) + ++ "\n" + ++ ( if amountSkipped == 0 + then "" + else + styled [black] ("Skipped: " ++ Builder.int64Dec amountSkipped) + ++ "\n" + ) + ++ styled [black] ("Failed: " ++ Builder.int64Dec amountFailed) + ++ "\n" + Internal.NoTestsInSuite -> + styled [yellow, underlined] "TEST RUN INCOMPLETE" + ++ styled [yellow] (" because the test suite is empty.") + ++ "\n" + +prettyPath :: + ([ANSI.SGR] -> Builder.Builder -> Builder.Builder) -> + [ANSI.SGR] -> + Internal.SingleTest a -> + Builder.Builder +prettyPath styled styles test = + ( case Internal.loc test of + Nothing -> "" + Just loc -> + styled + [grey] + ( "↓ " + ++ Builder.stringUtf8 (Stack.srcLocFile loc) + ++ ":" + ++ Builder.intDec (Stack.srcLocStartLine loc) + ++ "\n" + ) + ) + ++ Prelude.foldMap + (\text -> styled [grey] ("↓ " ++ TE.encodeUtf8Builder text) ++ "\n") + (Internal.describes test) + ++ styled styles ("✗ " ++ TE.encodeUtf8Builder (Internal.name test)) + ++ "\n" + +testFailure :: Internal.SingleTest Internal.Failure -> Builder.Builder +testFailure test = + case Internal.body test of + Internal.FailedAssertion msg -> + TE.encodeUtf8Builder msg + Internal.ThrewException exception -> + "Test threw an exception\n" + ++ Builder.stringUtf8 (Exception.displayException exception) + Internal.TookTooLong -> + "Test timed out" + Internal.TestRunnerMessedUp msg -> + "Test runner encountered an unexpected error:\n" + ++ TE.encodeUtf8Builder msg + ++ "\n" + ++ "This is a bug.\n\n" + ++ "If you have some time to report the bug it would be much appreciated!\n" + ++ "You can do so here: https://github.com/NoRedInk/haskell-libraries/issues" + +sgr :: [ANSI.SGR] -> Builder.Builder +sgr = Builder.stringUtf8 << ANSI.setSGRCode + +red :: ANSI.SGR +red = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red + +yellow :: ANSI.SGR +yellow = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Yellow + +green :: ANSI.SGR +green = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Green + +grey :: ANSI.SGR +grey = ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Black + +black :: ANSI.SGR +black = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.White + +underlined :: ANSI.SGR +underlined = ANSI.SetUnderlining ANSI.SingleUnderline diff --git a/src/Test/Runner/Tasty.hs b/src/Test/Runner/Tasty.hs deleted file mode 100644 --- a/src/Test/Runner/Tasty.hs +++ /dev/null @@ -1,115 +0,0 @@ --- | Run tests. -module Test.Runner.Tasty - ( main, - ) -where - -import Control.Exception.Safe (throw) -import Data.Proxy (Proxy (Proxy)) -import qualified Data.Text -import Data.Typeable (Typeable) -import qualified Internal.Test -import qualified Internal.TestResult as Result -import qualified List -import NriPrelude -import qualified System.Environment as Env -import qualified Test -import qualified Test.Tasty as Tasty -import qualified Test.Tasty.Options as Options -import qualified Test.Tasty.Providers as Providers -import qualified Test.Tasty.Runners.Reporter as Reporter -import qualified Text -import Prelude (IO, pure, show) - --- | Run tests. -main :: Test.Test -> IO () -main test = do - -- NOTE: We need to always run AntXML, - -- because this ingredient actually runs the tests. - let tastyXmlEnv = "TASTY_XML" - maybeXml <- Env.lookupEnv tastyXmlEnv - case maybeXml of - Just _ -> pure () - Nothing -> Env.setEnv tastyXmlEnv "_build/report.xml" - Tasty.defaultMainWithIngredients [Reporter.ingredient] (setup test) - -data TestToRun - = TestToRun Test.Test - | Only TestToRun - deriving (Typeable) - -instance Providers.IsTest TestToRun where - testOptions = pure [Options.Option (Proxy :: Proxy FuzzReplay)] - - run options (Only (TestToRun testToRun)) _progress = do - result <- runTest options testToRun - throw (Reporter.TestOnly result) - run options (Only testToRun) progress = Providers.run options testToRun progress - run options (TestToRun testToRun) _progress = do - result <- runTest options testToRun - case result of - Reporter.OnlyTestPassed str -> pure (Providers.testPassed str) - Reporter.OnlyTestFailed str -> pure (Providers.testFailed str) - -runTest :: Options.OptionSet -> Test.Test -> IO Reporter.OnlyTestResult -runTest options testToRun = do - let FuzzReplay replay = Options.lookupOption options - testResult <- Internal.Test.run replay testToRun - case testResult of - Result.Passed -> pure (Reporter.OnlyTestPassed "") - Result.Skipped -> throw Reporter.TestSkipped - Result.Failed message -> - show message - |> Reporter.OnlyTestFailed - |> pure - --- - --- | The replay token to use for replaying a previous test run -newtype FuzzReplay = FuzzReplay Internal.Test.FuzzReplay - deriving (Typeable) - -instance Options.IsOption FuzzReplay where - defaultValue = FuzzReplay (Internal.Test.FuzzReplay Nothing) - - parseValue v = map (FuzzReplay << Internal.Test.FuzzReplay << Just) replay - where - -- Reads a replay token in the form "{size} {seed}" - size = List.take 2 (Text.words <| Data.Text.pack v) - seed = List.drop 2 (Text.words <| Data.Text.pack v) - replay = - map2 - (,) - (Options.safeRead (Data.Text.unpack <| Text.join " " size)) - (Options.safeRead (Data.Text.unpack <| Text.join " " seed)) - - optionName = pure "seed" - - optionHelp = pure "Allow running the tests with a predefined seed, rather than a randomly generated seed. This is especially helpful when trying to reproduce a failing fuzz-test." - -setup :: Test.Test -> Providers.TestTree -setup tests = - case Internal.Test.hasOnly tests of - Just sub -> - -- only run tests that are wrapped in @only@. - setup_ True sub - Nothing -> - setup_ False tests - -setup_ :: Bool -> Test.Test -> Providers.TestTree -setup_ hasOnly test = - case test of - Internal.Test.Describe name tests -> - tests - |> List.map - ( \test' -> - case test' of - Internal.Test.FromTestTree _ t -> t - t -> setup_ hasOnly t - ) - |> Tasty.testGroup (Data.Text.unpack name) - _ -> - Providers.singleTest (Data.Text.unpack (Internal.Test.name test)) - <| if hasOnly - then Only (TestToRun test) - else TestToRun test diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -7,16 +7,20 @@ import qualified BitwiseSpec import qualified DebugSpec import qualified DictSpec +import qualified GHC.IO.Encoding import qualified LogSpec import qualified PlatformSpec import qualified SetSpec -import Test (Test, describe) -import qualified Test.Runner.Tasty +import qualified System.IO +import Test (Test, describe, run) +import qualified TestSpec import qualified TextSpec -import Prelude (IO) +import qualified Prelude -main :: IO () -main = Test.Runner.Tasty.main tests +main :: Prelude.IO () +main = do + GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 + run tests tests :: Test tests = @@ -26,6 +30,7 @@ BitwiseSpec.tests, DictSpec.tests, SetSpec.tests, + TestSpec.tests, TextSpec.tests, LogSpec.tests, PlatformSpec.tests, diff --git a/tests/TestSpec.hs b/tests/TestSpec.hs new file mode 100644 --- /dev/null +++ b/tests/TestSpec.hs @@ -0,0 +1,318 @@ +module TestSpec (tests) where + +import qualified Control.Exception.Safe as Exception +import qualified Data.Text +import qualified Data.Text.IO +import qualified Expect +import qualified Expect.Task +import qualified Fuzz +import qualified GHC.Exts +import qualified GHC.Stack as Stack +import NriPrelude +import qualified Platform.Internal +import qualified System.IO +import Test (Test, describe, fuzz, fuzz2, fuzz3, only, skip, task, test, todo) +import qualified Test.Internal as Internal +import qualified Test.Reporter.Stdout +import qualified Prelude + +tests :: Test +tests = + describe + "Test" + [ api, + stdoutReporter + ] + +api :: Test +api = + describe + "Api" + [ task "suite result is 'AllPassed' when all tests passed" <| do + let suite = + describe + "suite" + [ test "test 1" (\_ -> Expect.pass), + test "test 2" (\_ -> Expect.pass) + ] + result <- Internal.run suite + result + |> simplify + |> Expect.equal (AllPassed ["test 1", "test 2"]) + |> Expect.Task.check, + task "suite result is 'OnlysPassed' when containing an `only`" <| do + let suite = + describe + "suite" + [ test "test 1" (\_ -> Expect.pass), + only <| test "test 2" (\_ -> Expect.pass) + ] + result <- Internal.run suite + result + |> simplify + |> Expect.equal (OnlysPassed ["test 2"] ["test 1"]) + |> Expect.Task.check, + task "suite result is 'PassedWithSkipped' when containing skipped test" <| do + let suite = + describe + "suite" + [ test "test 1" (\_ -> Expect.pass), + skip <| test "test 2" (\_ -> Expect.pass) + ] + result <- Internal.run suite + result + |> simplify + |> Expect.equal (PassedWithSkipped ["test 1"] ["test 2"]) + |> Expect.Task.check, + task "suite result is 'PassedWithSkipped' when containing a todo test" <| do + let suite = + describe + "suite" + [ test "test 1" (\_ -> Expect.pass), + todo "test 2" + ] + result <- Internal.run suite + result + |> simplify + |> Expect.equal (PassedWithSkipped ["test 1"] ["test 2"]) + |> Expect.Task.check, + task "suite result is 'NoTestsInSuite' when it contains no tests" <| do + let suite = describe "suite" [] + result <- Internal.run suite + result + |> simplify + |> Expect.equal NoTestsInSuite + |> Expect.Task.check, + task "suite result is 'TestsFailed' when it contains a failing test" <| do + let suite = + describe + "suite" + [ test "test 1" (\_ -> Expect.pass), + skip <| test "test 2" (\_ -> Expect.pass), + test "test 3" (\_ -> Expect.fail "oops") + ] + result <- Internal.run suite + result + |> simplify + |> Expect.equal (TestsFailed ["test 1"] ["test 2"] ["test 3"]) + |> Expect.Task.check, + test "nested describes are exposed on each test" <| \_ -> + let suite = + describe + "suite" + [ describe + "sub suite" + [ test "test 1" (\_ -> Expect.pass) + ] + ] + in suite + |> expectSingleTest + ( \test' -> + Internal.describes test' + |> Expect.equal ["suite", "sub suite"] + ), + test "source location of `test` are the file in which the test is defined" <| \_ -> + test "test 1" (\_ -> Expect.pass) + |> expectSingleTest (expectSrcFile "tests/TestSpec.hs"), + test "source location of `todo` are the file in which the test is defined" <| \_ -> + todo "test 1" + |> expectSingleTest (expectSrcFile "tests/TestSpec.hs"), + test "source location of `task` are the file in which the test is defined" <| \_ -> + task "test 1" (Expect.Task.check Expect.pass) + |> expectSingleTest (expectSrcFile "tests/TestSpec.hs"), + test "source location of `fuzz` are the file in which the test is defined" <| \_ -> + fuzz Fuzz.int "test 1" (\_ -> Expect.pass) + |> expectSingleTest (expectSrcFile "tests/TestSpec.hs"), + test "source location of `fuzz2` are the file in which the test is defined" <| \_ -> + fuzz2 Fuzz.int Fuzz.int "test 1" (\_ _ -> Expect.pass) + |> expectSingleTest (expectSrcFile "tests/TestSpec.hs"), + test "source location of `fuzz3` are the file in which the test is defined" <| \_ -> + fuzz3 Fuzz.int Fuzz.int Fuzz.int "test 1" (\_ _ _ -> Expect.pass) + |> expectSingleTest (expectSrcFile "tests/TestSpec.hs") + ] + +expectSingleTest :: + (Internal.SingleTest Internal.Expectation -> Expect.Expectation) -> + Test -> + Expect.Expectation +expectSingleTest check (Internal.Test tests') = + case tests' of + [test'] -> check test' + _ -> Expect.fail "I didn't find a single test as I expected." + +expectSrcFile :: Text -> Internal.SingleTest a -> Expect.Expectation +expectSrcFile expected test' = + case Internal.loc test' of + Nothing -> + Expect.fail "Expected source file location for test, but none was set." + Just loc -> + Stack.srcLocFile loc + |> Data.Text.pack + |> Expect.equal expected + +-- | A type mirroring `Internal.SuiteResult`, simplified to allow easy +-- comparisons in tests. +data SimplifiedSuiteResult + = AllPassed [Text] + | OnlysPassed [Text] [Text] + | PassedWithSkipped [Text] [Text] + | TestsFailed [Text] [Text] [Text] + | NoTestsInSuite + deriving (Eq, Show) + +simplify :: Internal.SuiteResult -> SimplifiedSuiteResult +simplify suiteResult = + case suiteResult of + Internal.AllPassed passed -> + AllPassed + (map Internal.name passed) + Internal.OnlysPassed passed skipped -> + OnlysPassed + (map Internal.name passed) + (map Internal.name skipped) + Internal.PassedWithSkipped passed skipped -> + PassedWithSkipped + (map Internal.name passed) + (map Internal.name skipped) + Internal.TestsFailed passed skipped failed -> + TestsFailed + (map Internal.name passed) + (map Internal.name skipped) + (map Internal.name failed) + Internal.NoTestsInSuite -> NoTestsInSuite + +stdoutReporter :: Test +stdoutReporter = + describe + "Stdout Reporter" + [ task "all passed" <| do + contents <- + withTempFile + ( \_ handle -> + Internal.AllPassed + [ mockTest "test 1" mockTracingSpan, + mockTest "test 2" mockTracingSpan + ] + |> Test.Reporter.Stdout.report handle + ) + contents + |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-all-passed" + |> Expect.Task.check, + task "onlys passed" <| do + contents <- + withTempFile + ( \_ handle -> + Internal.OnlysPassed + [ mockTest "test 1" mockTracingSpan, + mockTest "test 2" mockTracingSpan + ] + [ mockTest "test 3" Internal.NotRan, + mockTest "test 4" Internal.NotRan + ] + |> Test.Reporter.Stdout.report handle + ) + contents + |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-onlys-passed" + |> Expect.Task.check, + task "passed with skipped" <| do + contents <- + withTempFile + ( \_ handle -> + Internal.PassedWithSkipped + [ mockTest "test 1" mockTracingSpan, + mockTest "test 2" mockTracingSpan + ] + [ mockTest "test 3" Internal.NotRan, + mockTest "test 4" Internal.NotRan + ] + |> Test.Reporter.Stdout.report handle + ) + contents + |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-passed-with-skipped" + |> Expect.Task.check, + task "no tests in suite" <| do + contents <- + withTempFile + ( \_ handle -> + Internal.NoTestsInSuite + |> Test.Reporter.Stdout.report handle + ) + contents + |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-no-tests-in-suite" + |> Expect.Task.check, + task "tests failed" <| do + contents <- + withTempFile + ( \_ handle -> + Internal.TestsFailed + [ mockTest "test 1" mockTracingSpan, + mockTest "test 2" mockTracingSpan + ] + [ mockTest "test 3" Internal.NotRan, + mockTest "test 4" Internal.NotRan + ] + [ mockTest "test 5" (mockTracingSpan, Internal.FailedAssertion "assertion error"), + mockTest "test 6" (mockTracingSpan, Internal.ThrewException mockException), + mockTest "test 7" (mockTracingSpan, Internal.TookTooLong), + mockTest "test 7" (mockTracingSpan, Internal.TestRunnerMessedUp "sorry") + ] + |> Test.Reporter.Stdout.report handle + ) + contents + |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-tests-failed" + |> Expect.Task.check + ] + +-- | Provide a temporary file for a test to do some work in, then return the +-- contents of the file when the test is done with it. +withTempFile :: (System.IO.FilePath -> System.IO.Handle -> Prelude.IO ()) -> Task e Text +withTempFile go = do + Platform.Internal.Task + ( \_ -> do + (path, handle) <- + System.IO.openTempFile "/tmp" "nri-haskell-libraries-test-file" + go path handle + System.IO.hClose handle + Data.Text.IO.readFile path + |> map Ok + ) + +mockTest :: Text -> body -> Internal.SingleTest body +mockTest name body = + Internal.SingleTest + { Internal.describes = ["suite", "sub suite"], + Internal.name = name, + Internal.label = Internal.None, + Internal.loc = Just mockSrcLoc, + Internal.body = body + } + +mockTracingSpan :: Platform.Internal.TracingSpan +mockTracingSpan = + Platform.Internal.TracingSpan + { Platform.Internal.name = "name", + Platform.Internal.started = Platform.Internal.MonotonicTime 0, + Platform.Internal.finished = Platform.Internal.MonotonicTime 0, + Platform.Internal.frame = Nothing, + Platform.Internal.details = Nothing, + Platform.Internal.succeeded = Platform.Internal.Succeeded, + Platform.Internal.allocated = 1, + Platform.Internal.children = [] + } + +mockSrcLoc :: Stack.SrcLoc +mockSrcLoc = + Stack.SrcLoc + { Stack.srcLocPackage = "package", + Stack.srcLocModule = "Module", + Stack.srcLocFile = "Module.hs", + Stack.srcLocStartLine = 2, + Stack.srcLocStartCol = 4, + Stack.srcLocEndLine = 12, + Stack.srcLocEndCol = 14 + } + +mockException :: Exception.SomeException +mockException = + Exception.StringException "exception" (GHC.Exts.fromList []) + |> Exception.toException