diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,8 @@ +Copyright (c) 2020 Tom Sydney Kerckhove + +All Rights Reserved + + +You can use this software under the AGPL license **with the additional condition** that it is not used for commercial purposes. +Alternatively you can automatically receive a commercial license while you are [a github sponsor of NorfairKing](https://github.com/sponsors/NorfairKing) or a contributor. + diff --git a/output-test/Spec.hs b/output-test/Spec.hs new file mode 100644 --- /dev/null +++ b/output-test/Spec.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-missing-fields -fno-warn-missing-methods -fno-warn-partial-fields -fno-warn-incomplete-uni-patterns -fno-warn-incomplete-record-updates #-} + +module Main where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as SB +import qualified Data.ByteString.Char8 as SB8 +import Data.List +import Data.Text (Text) +import Rainbow +import System.Exit +import Test.QuickCheck +import Test.Syd +import Test.Syd.OptParse + +data DangerousRecord = Cons1 {field :: String} | Cons2 + +class ToUnit a where + toUnit :: a -> () + +instance ToUnit Int -- No implementation on purpose + +main :: IO () +main = do + sets <- getSettings + testForest <- execTestDefM sets spec + _ <- runSpecForestInterleavedWithOutputSynchronously (settingColour sets) (settingFailFast sets) testForest + _ <- runSpecForestInterleavedWithOutputAsynchronously (settingColour sets) (settingFailFast sets) 8 testForest + rf1 <- timeItT $ runSpecForestSynchronously (settingFailFast sets) testForest + printOutputSpecForest (settingColour sets) rf1 + rf2 <- timeItT $ runSpecForestAsynchronously (settingFailFast sets) 8 testForest + printOutputSpecForest (settingColour sets) rf2 + pure () + +spec :: Spec +spec = do + it "Passes" (pure () :: IO ()) + describe "error" $ do + it "Pure error" (pure (error "foobar") :: IO ()) + it "Impure error" (error "foobar" :: IO ()) + describe "undefined" $ do + it "Pure undefined" (pure undefined :: IO ()) + it "Impure undefined" (undefined :: IO ()) + it "Exit code" $ do + exitWith $ ExitFailure 1 :: IO () + describe "exceptions" $ do + it "Record construction error" (throw $ RecConError "test" :: IO ()) + exceptionTest "Record construction error" $ let c = Cons1 {} in field c + it "Record selection error" (throw $ RecSelError "test" :: IO ()) + exceptionTest "Record selection error" $ let c = Cons2 in field c + it "Record update error" (throw $ RecUpdError "test" :: IO ()) + exceptionTest "Record update error" $ let c = Cons2 in c {field = "this will throw"} + it "Pattern matching error" (throw $ PatternMatchFail "test" :: IO ()) + exceptionTest "Pattern matching error" $ let Cons1 s = Cons2 in s + it "ArithException" (throw Underflow :: IO ()) + exceptionTest "Pattern matching error" $ 1 `div` (0 :: Int) + it "NoMethodError" (throw (NoMethodError "test") :: IO ()) + exceptionTest "Pattern matching error" $ toUnit (5 :: Int) + describe "Printing" $ do + it "print" $ print 'a' + it "putStrLn" $ putStrLn "hi" + modifyMaxSuccess (`div` 10) $ + modifyMaxSize (`div` 1) $ + modifyMaxShrinks (const 1) $ + modifyMaxDiscardRatio (const 1) $ + describe "Property tests" $ do + describe "pure" $ do + it "reversing a list twice is the same as reversing it once" $ + property $ + \ls -> reverse (reverse ls) == (ls :: [Int]) + it "should fail to show that sorting does nothing" $ + property $ + \ls -> sort ls == (ls :: [Int]) + it "should work with custom generators too" $ forAll arbitrary $ \b -> b || True + describe "impure" $ do + it "reversing a list twice is the same as reversing it once" $ + property $ + \ls -> reverse (reverse ls) `shouldBe` (ls :: [Int]) + it "should fail to show that sorting does nothing" $ + property $ + \ls -> sort ls `shouldBe` (ls :: [Int]) + it "should work with custom generators too" $ forAll arbitrary $ \b -> (b || True) `shouldBe` True + describe "Long running tests" $ + forM_ [1 :: Int .. 10] $ + \i -> + it (concat ["takes a while (", show i, ")"]) $ + threadDelay 100_000 + describe "Diff" $ do + it "shows nice multi-line diffs" $ + ("foo", replicate 7 "quux", "bar") `shouldBe` (("foofoo", replicate 6 "quux", "baz") :: (String, [String], String)) + it "shows nice multi-line diffs" $ + ("foo", [], "bar") `shouldBe` (("foofoo", replicate 6 "quux", "baz") :: (String, [String], String)) + describe "assertions" $ do + it "shouldBe" $ 3 `shouldBe` (4 :: Int) + it "shouldNotBe" $ 3 `shouldNotBe` (3 :: Int) + it "shouldSatisfy" $ (3 :: Int) `shouldSatisfy` even + it "shouldNotSatisfy" $ (3 :: Int) `shouldNotSatisfy` odd + pending "pending test" + describe "Golden" $ do + it "does not fail the suite when an exception happens while reading" $ + GoldenTest + { goldenTestRead = die "test", + goldenTestProduce = pure (), + goldenTestWrite = \() -> do + pure (), + goldenTestCompare = \() () -> Nothing + } + it "does not fail the suite when an exception happens while producing" $ + GoldenTest + { goldenTestRead = pure Nothing, + goldenTestProduce = die "test", + goldenTestWrite = \() -> do + pure (), + goldenTestCompare = \() () -> Nothing + } + it "does not fail the suite when an exception happens while writing" $ + GoldenTest + { goldenTestRead = pure Nothing, + goldenTestProduce = pure (), + goldenTestWrite = \() -> die "test", + goldenTestCompare = \() () -> Nothing + } + it "does not fail the suite when an exception happens while checking for equality" $ + GoldenTest + { goldenTestRead = pure (Just ()), + goldenTestProduce = pure (), + goldenTestWrite = \() -> pure (), + goldenTestCompare = \actual expected -> case 1 `div` (0 :: Int) of + 1 -> Nothing + _ -> + if actual == expected + then Nothing + else Just $ NotEqualButShouldHaveBeenEqual (show actual) (show expected) + } + + describe "outputResultForest" $ do + it "outputs the same as last time" $ do + pureGoldenByteStringFile + "test_resources/output.golden" + (SB8.intercalate (SB8.pack "\n") $ map SB.concat $ outputSpecForestByteString toByteStringsColors256 (Timed [] 0)) + doNotRandomiseExecutionOrder $ + describe "Around" $ + do + describe "before" $ do + before (() <$ throwIO (userError "test")) $ + it "does not kill the test suite" $ \() -> + pure () :: IO () + + describe "before_" $ do + before_ (throwIO (userError "test")) $ + it "does not kill the test suite" $ \() -> + pure () :: IO () + + describe "after" $ do + after (\_ -> throwIO (userError "test")) $ + it "does not kill the test suite" $ \() -> + pure () :: IO () + + describe "after_" $ do + after_ (throwIO (userError "test")) $ + it "does not kill the test suite" $ \() -> + pure () :: IO () + + describe "around" $ do + around (\_ -> throwIO (userError "test")) $ + it "does not kill the test suite" $ \() -> + pure () :: IO () + + describe "around_" $ do + around_ (\_ -> throwIO (userError "test")) $ + it "does not kill the test suite" $ \() -> + pure () :: IO () + + describe "aroundWith" $ do + aroundWith (\_ () -> throwIO (userError "test")) $ + it "does not kill the test suite" $ \() -> + pure () :: IO () + + describe "aroundWith'" $ do + aroundWith' (\_ () () -> throwIO (userError "test")) $ + it "does not kill the test suite" $ \() -> + pure () :: IO () + it "expectationFailure" (expectationFailure "fails" :: IO ()) + describe "String" $ do + it "compares strings" $ ("foo\nbar\tquux " :: String) `shouldBe` "foq\nbaz\tqex" + it "compares strings" $ ("foo\nbar\tquux " :: String) `stringShouldBe` "foq\nbaz\tqex" + it "compares texts" $ ("foo\nbar\tquux " :: Text) `shouldBe` "foq\nbaz\tqex" + it "compares texts" $ ("foo\nbar\tquux " :: Text) `textShouldBe` "foq\nbaz\tqex" + it "compares bytestrings" $ ("foo\nbar\tquux " :: ByteString) `shouldBe` "foq\nbaz\tqex" + describe "Context" $ do + it "shows a nice context" $ context "Context" $ True `shouldBe` False + it "shows a nice context multiple levels deep" $ + context "Context1" $ + context "Context2" $ + context "Context3" $ + True `shouldBe` False + modifyMaxSize (`div` 10) $ + describe "Property" $ do + describe "generated values" $ + it "shows many generated values too" $ + property $ \i -> + property $ \j -> + property $ \k -> + property $ \l -> + property $ \m -> + i + j + k + l + m `shouldBe` m + l + k + j + i + (1 :: Int) + let magnitude :: Int -> Int + magnitude = (ceiling :: Double -> Int) . logBase 10 . fromIntegral + describe "labels" $ do + it "shows the labels in use on success" $ + property $ \xs -> + label ("length of input is " ++ show (length xs)) $ + reverse (reverse xs) `shouldBe` (xs :: [Int]) + it "shows the labels in use on success" $ + property $ \xs -> + label ("length of input is " ++ show (length xs)) $ + label ("magnitude (digits) of sum of input is " ++ show (magnitude (sum xs))) $ + reverse (reverse xs) `shouldBe` (xs :: [Int]) + it "shows the labels in use on failure" $ + property $ \xs -> + label ("length of input is " ++ show (length xs)) $ + label ("magnitude (digits) of sum of input is " ++ show (magnitude (sum xs))) $ + reverse (reverse xs) `shouldBe` (0 : xs :: [Int]) + describe "classes" $ do + it "shows the classes in use on success" $ + forAll (sort <$> arbitrary) $ \xs -> + classify (length xs > 1) "non-trivial" $ + sort xs `shouldBe` (xs :: [Int]) + it "shows the classes in use on success" $ + forAll (sort <$> arbitrary) $ \xs -> + classify (null xs) "empty" $ + classify (length xs == 1) "single element" $ + classify (length xs > 1) "non-trivial" $ + sort xs `shouldBe` (xs :: [Int]) + it "shows the classes in use on failure" $ + forAll (sort <$> arbitrary) $ \xs -> + classify (null xs) "empty" $ + classify (length xs == 1) "single element" $ + classify (length xs > 1) "non-trivial" $ + sort xs `shouldBe` (0 : xs :: [Int]) + describe "tables" $ do + it "shows the tables in use on success" $ + forAll (sort <$> arbitrary) $ \xs -> + tabulate "List elements" (map show xs) $ + sort xs `shouldBe` (xs :: [Int]) + it "shows the tables in use on success" $ + forAll (sort <$> arbitrary) $ \xs -> + tabulate "List elements" (map show xs) $ + tabulate "List magnitudes" (map (show . magnitude) xs) $ + sort xs `shouldBe` (xs :: [Int]) + +exceptionTest :: String -> a -> Spec +exceptionTest s a = describe s $ do + it "fails in IO, as the result" (pure (seq a ()) :: IO ()) + it "fails in IO, as the action" (seq a (pure ()) :: IO ()) + it "fails in pure code" $ seq a True diff --git a/src/Test/Syd.hs b/src/Test/Syd.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} + +module Test.Syd + ( -- * Top level API functions + sydTest, + sydTestWith, + + -- * Defining a test suite + + -- * Declaring tests + describe, + it, + itWithOuter, + itWithBoth, + itWithAll, + specify, + specifyWithOuter, + specifyWithBoth, + specifyWithAll, + + -- ** Commented-out tests + xdescribe, + xit, + xitWithOuter, + xitWithBoth, + xitWithAll, + xspecify, + xspecifyWithOuter, + xspecifyWithBoth, + xspecifyWithAll, + + -- ** Pending tests + pending, + pendingWith, + + -- ** Environment-based tests + eit, + withTestEnv, + + -- ** Golden tests + pureGoldenByteStringFile, + goldenByteStringFile, + pureGoldenTextFile, + goldenTextFile, + pureGoldenStringFile, + goldenStringFile, + goldenShowInstance, + goldenPrettyShowInstance, + + -- ** Expectations + shouldBe, + shouldNotBe, + shouldSatisfy, + shouldSatisfyNamed, + shouldNotSatisfy, + shouldNotSatisfyNamed, + shouldReturn, + shouldNotReturn, + shouldStartWith, + shouldEndWith, + shouldContain, + expectationFailure, + context, + Expectation, + shouldThrow, + Selector, + anyException, + anyErrorCall, + errorCall, + anyIOException, + anyArithException, + + -- *** String expectations + stringShouldBe, + textShouldBe, + + -- *** For throwing raw assertions + stringsNotEqualButShouldHaveBeenEqual, + textsNotEqualButShouldHaveBeenEqual, + bytestringsNotEqualButShouldHaveBeenEqual, + Assertion (..), + + -- ** Declaring test dependencies + + -- *** Dependencies around all of a group of tests + beforeAll, + beforeAll_, + beforeAllWith, + afterAll, + afterAll', + afterAll_, + aroundAll, + aroundAll_, + aroundAllWith, + + -- *** Dependencies around each of a group of tests + before, + before_, + after, + after_, + around, + around_, + aroundWith, + + -- **** Setup functions + + -- ***** Using setup functions + setupAround, + setupAroundWith, + setupAroundWith', + + -- ***** Creating setup functions + SetupFunc (..), + makeSimpleSetupFunc, + useSimpleSetupFunc, + connectSetupFunc, + composeSetupFunc, + wrapSetupFunc, + unwrapSetupFunc, + + -- *** Declaring different test settings + modifyMaxSuccess, + modifyMaxDiscardRatio, + modifyMaxSize, + modifyMaxShrinks, + modifyRunSettings, + TestRunSettings (..), + + -- *** Declaring parallelism + sequential, + parallel, + withParallelism, + Parallelism (..), + + -- *** Declaring randomisation order + randomiseExecutionOrder, + doNotRandomiseExecutionOrder, + withExecutionOrderRandomisation, + ExecutionOrderRandomisation (..), + + -- *** Doing IO during test definition + runIO, + + -- ** Test definition types + TestDefM (..), + TestDef, + execTestDefM, + runTestDefM, + + -- ** Test suite types + TDef (..), + TestForest, + TestTree, + SpecDefForest, + SpecDefTree (..), + ResultForest, + ResultTree, + shouldExitFail, + + -- ** Hspec synonyms + + -- + -- These synonyms have been provided so that you can more or less "just" replace "hspec" by "sydTest" and have things work. + -- However, hspec does not distinguish between inner and outer resources, so these synonyms assume that all resources are inner resources. + Spec, + SpecWith, + SpecM, + + -- * Utilities + ppShow, + + -- * Reexports + module Test.Syd.Def, + module Test.Syd.Expectation, + module Test.Syd.HList, + module Test.Syd.Modify, + module Test.Syd.Output, + module Test.Syd.Run, + module Test.Syd.Runner, + module Test.Syd.SpecDef, + module Test.Syd.SpecForest, + module Control.Monad.IO.Class, + ) +where + +import Control.Monad +import Control.Monad.IO.Class +import System.Exit +import Test.QuickCheck.IO () +import Test.Syd.Def +import Test.Syd.Expectation +import Test.Syd.HList +import Test.Syd.Modify +import Test.Syd.OptParse +import Test.Syd.Output +import Test.Syd.Run +import Test.Syd.Runner +import Test.Syd.SpecDef +import Test.Syd.SpecForest +import Text.Show.Pretty (ppShow) + +-- | Evaluate a test suite definition and then run it, with default 'Settings' +sydTest :: Spec -> IO () +sydTest spec = do + sets <- getSettings + sydTestWith sets spec + +-- | Evaluate a test suite definition and then run it, with given 'Settings' +sydTestWith :: Settings -> Spec -> IO () +sydTestWith sets spec = do + resultForest <- sydTestResult sets spec + when (shouldExitFail (timedValue resultForest)) (exitWith (ExitFailure 1)) + +runIO :: IO e -> TestDefM a b e +runIO = liftIO diff --git a/src/Test/Syd/Def.hs b/src/Test/Syd/Def.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Def.hs @@ -0,0 +1,20 @@ +-- | This module exports all the functions you will use to define your test suite. +module Test.Syd.Def + ( -- * Rexports + module Test.Syd.Def.Env, + module Test.Syd.Def.Specify, + module Test.Syd.Def.Around, + module Test.Syd.Def.AroundAll, + module Test.Syd.Def.SetupFunc, + module Test.Syd.Def.Golden, + module Test.Syd.Def.TestDefM, + ) +where + +import Test.Syd.Def.Around +import Test.Syd.Def.AroundAll +import Test.Syd.Def.Env +import Test.Syd.Def.Golden +import Test.Syd.Def.SetupFunc +import Test.Syd.Def.Specify +import Test.Syd.Def.TestDefM diff --git a/src/Test/Syd/Def/Around.hs b/src/Test/Syd/Def/Around.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Def/Around.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Syd.Def.Around where + +import Control.Exception +import Control.Monad.RWS.Strict +import Data.Kind +import Test.QuickCheck.IO () +import Test.Syd.Def.TestDefM +import Test.Syd.HList +import Test.Syd.Run +import Test.Syd.SpecDef + +-- | Run a custom action before every spec item, to set up an inner resource 'c'. +before :: IO c -> TestDefM a c e -> TestDefM a () e +before action = around (action >>=) + +-- | Run a custom action before every spec item without setting up any inner resources. +before_ :: IO () -> TestDefM a c e -> TestDefM a c e +before_ action = around_ (action >>) + +-- | Run a custom action after every spec item, using the inner resource 'c'. +after :: (c -> IO ()) -> TestDefM a c e -> TestDefM a c e +after action = aroundWith $ \e x -> e x `finally` action x + +-- | Run a custom action after every spec item without using any inner resources. +after_ :: IO () -> TestDefM a c e -> TestDefM a c e +after_ action = after $ \_ -> action + +-- | Run a custom action before and/or after every spec item, to provide access to an inner resource 'c'. +-- +-- See the @FOOTGUN@ note in the docs for 'around_'. +around :: ((c -> IO ()) -> IO ()) -> TestDefM a c e -> TestDefM a () e +around action = aroundWith $ \e () -> action e + +-- | Run a custom action before and/or after every spec item without accessing any inner resources. +-- +-- It is important that the wrapper function that you provide runs the action that it gets _exactly once_. +-- +-- == __FOOTGUN__ +-- +-- This combinator gives the programmer a lot of power. +-- In fact, it gives the programmer enough power to break the test framework. +-- Indeed, you can provide a wrapper function that just _doesn't_ run the function like this: +-- +-- > spec :: Spec +-- > spec = do +-- > let don'tDo :: IO () -> IO () +-- > don'tDo _ = pure () +-- > around_ don'tDo $ do +-- > it "should pass" True +-- +-- During execution, you'll then get an error like this: +-- +-- > thread blocked indefinitely in an MVar operation +-- +-- The same problem exists when using 'Test.Syd.Def.Around.aroundAll_'. +-- +-- The same thing will go wrong if you run the given action more than once like this: +-- +-- > spec :: Spec +-- > spec = do +-- > let doTwice :: IO () -> IO () +-- > doTwice f = f >> f +-- > around_ doTwice $ do +-- > it "should pass" True +-- +-- +-- Note: If you're interested in fixing this, talk to me, but only after GHC has gotten impredicative types because that will likely be a requirement. +around_ :: (IO () -> IO ()) -> TestDefM a c e -> TestDefM a c e +around_ action = aroundWith $ \e a -> action (e a) + +-- | Run a custom action before and/or after every spec item, to provide access to an inner resource 'c' while using the inner resource 'd'. +-- +-- See the @FOOTGUN@ note in the docs for 'around_'. +aroundWith :: forall a c d r. ((c -> IO ()) -> (d -> IO ())) -> TestDefM a c r -> TestDefM a d r +aroundWith func = + aroundWith' $ + \(takeAC :: HList a -> c -> IO ()) -- Just to make sure the 'a' is not ambiguous. + a + d -> + func (\c -> takeAC a c) d + +-- | Run a custom action before and/or after every spec item, to provide access to an inner resource 'c' while using the inner resource 'd' and any outer resource available. +aroundWith' :: forall a c d r (u :: [Type]). HContains u a => ((a -> c -> IO ()) -> (a -> d -> IO ())) -> TestDefM u c r -> TestDefM u d r +aroundWith' func (TestDefM rwst) = TestDefM $ + flip mapRWST rwst $ \inner -> do + (res, s, forest) <- inner + let modifyVal :: + forall x. + HContains x a => + (((HList x -> c -> IO ()) -> IO ()) -> IO TestRunResult) -> + ((HList x -> d -> IO ()) -> IO ()) -> + IO TestRunResult + modifyVal takeSupplyXC supplyXD = + let supplyXC :: (HList x -> c -> IO ()) -> IO () + supplyXC takeXC = + let takeXD :: HList x -> d -> IO () + takeXD x d = + let takeAC _ c = takeXC x c + in func takeAC (getElem x) d + in supplyXD takeXD + in takeSupplyXC supplyXC + + -- For this function to work recursively, the first parameter of the input and the output types must be the same + modifyTree :: forall x e. HContains x a => SpecDefTree x c e -> SpecDefTree x d e + modifyTree = \case + DefDescribeNode t sdf -> DefDescribeNode t $ modifyForest sdf + DefPendingNode t mr -> DefPendingNode t mr + DefSpecifyNode t td e -> DefSpecifyNode t (modifyVal <$> td) e + DefWrapNode f sdf -> DefWrapNode f $ modifyForest sdf + DefBeforeAllNode f sdf -> DefBeforeAllNode f $ modifyForest sdf + DefAroundAllNode f sdf -> DefAroundAllNode f $ modifyForest sdf + DefAroundAllWithNode f sdf -> DefAroundAllWithNode f $ modifyForest sdf + DefAfterAllNode f sdf -> DefAfterAllNode f $ modifyForest sdf + DefParallelismNode f sdf -> DefParallelismNode f $ modifyForest sdf + DefRandomisationNode f sdf -> DefRandomisationNode f $ modifyForest sdf + modifyForest :: forall x e. HContains x a => SpecDefForest x c e -> SpecDefForest x d e + modifyForest = map modifyTree + let forest' :: SpecDefForest u d () + forest' = modifyForest forest + pure (res, s, forest') diff --git a/src/Test/Syd/Def/AroundAll.hs b/src/Test/Syd/Def/AroundAll.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Def/AroundAll.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module defines all the functions you will use to define your test suite. +module Test.Syd.Def.AroundAll where + +import Control.Monad.RWS.Strict +import Test.QuickCheck.IO () +import Test.Syd.Def.TestDefM +import Test.Syd.HList +import Test.Syd.SpecDef + +-- | Run a custom action before all spec items in a group, to set up an outer resource 'a'. +beforeAll :: IO a -> TestDefM (a ': l) c e -> TestDefM l c e +beforeAll action = wrapRWST $ \forest -> DefBeforeAllNode action forest + +-- | Run a custom action before all spec items in a group without setting up any outer resources. +beforeAll_ :: IO () -> TestDefM a b e -> TestDefM a b e +beforeAll_ action = aroundAll_ (action >>) + +-- | Run a custom action before all spec items in a group, to set up an outer resource 'b' by using the outer resource 'a'. +beforeAllWith :: (b -> IO a) -> TestDefM (a ': b ': l) c e -> TestDefM (b ': l) c e +beforeAllWith action = aroundAllWith $ \func b -> do + a <- action b + func a + +-- | Run a custom action after all spec items, using the outer resource 'a'. +afterAll :: (a -> IO ()) -> TestDefM (a ': l) b e -> TestDefM (a ': l) b e +afterAll func = afterAll' $ \(HCons a _) -> func a + +-- | Run a custom action after all spec items, using all the outer resources. +afterAll' :: (HList l -> IO ()) -> TestDefM l b e -> TestDefM l b e +afterAll' func = wrapRWST $ \forest -> DefAfterAllNode func forest + +-- | Run a custom action after all spec items without using any outer resources. +afterAll_ :: IO () -> TestDefM a b e -> TestDefM a b e +afterAll_ action = afterAll' $ \_ -> action + +-- | Run a custom action before and/or after all spec items in group, to provide access to a resource 'a'. +-- +-- See the @FOOTGUN@ note in the docs for 'around_'. +aroundAll :: ((a -> IO ()) -> IO ()) -> TestDefM (a ': l) c e -> TestDefM l c e +aroundAll func = wrapRWST $ \forest -> DefAroundAllNode func forest + +-- | Run a custom action before and/or after all spec items in a group without accessing any resources. +-- +-- == __FOOTGUN__ +-- +-- This combinator gives the programmer a lot of power. +-- In fact, it gives the programmer enough power to break the test framework. +-- Indeed, you can provide a wrapper function that just _doesn't_ run the function like this: +-- +-- > spec :: Spec +-- > spec = do +-- > let don'tDo :: IO () -> IO () +-- > don'tDo _ = pure () +-- > aroundAll_ don'tDo $ do +-- > it "should pass" True +-- +-- During execution, you'll then get an error like this: +-- +-- > thread blocked indefinitely in an MVar operation +-- +-- The same problem exists when using 'Test.Syd.Def.Around.around_'. +-- +-- Something even more pernicious goes wrong when you run the given action more than once like this: +-- +-- > spec :: Spec +-- > spec = do +-- > let doTwice :: IO () -> IO () +-- > doTwice f = f >> f +-- > aroundAll_ doTwice $ do +-- > it "should pass" True +-- +-- In this case, the test will "just work", but it will be executed twice even if the output reports that it only passed once. +-- +-- Note: If you're interested in fixing this, talk to me, but only after GHC has gotten impredicative types because that will likely be a requirement. +aroundAll_ :: (IO () -> IO ()) -> TestDefM a b e -> TestDefM a b e +aroundAll_ func = wrapRWST $ \forest -> DefWrapNode func forest + +-- | Run a custom action before and/or after all spec items in a group to provide access to a resource 'a' while using a resource 'b' +-- +-- See the @FOOTGUN@ note in the docs for 'around_'. +aroundAllWith :: + forall a b c l r. + ((a -> IO ()) -> (b -> IO ())) -> + TestDefM (a ': b ': l) c r -> + TestDefM (b ': l) c r +aroundAllWith func = wrapRWST $ \forest -> DefAroundAllWithNode func forest + +-- | Declare a node in the spec def forest +wrapRWST :: (TestForest a c -> TestTree b d) -> TestDefM a c l -> TestDefM b d l +wrapRWST func (TestDefM rwst) = TestDefM $ + flip mapRWST rwst $ \inner -> do + (res, s, forest) <- inner + let forest' = [func forest] + pure (res, s, forest') diff --git a/src/Test/Syd/Def/Env.hs b/src/Test/Syd/Def/Env.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Def/Env.hs @@ -0,0 +1,48 @@ +module Test.Syd.Def.Env where + +import Control.Monad.Reader +import GHC.Stack +import Test.Syd.Def.Specify +import Test.Syd.Def.TestDefM + +-- | For defining a part of a test suite in 'ReaderT IO' instead of in 'IO'. +-- +-- This way you can write this: +-- +-- > spec :: Spec +-- > spec = around withConnectionPool $ +-- > it "can read what it writes" $ \pool -> +-- > let person = Person { name = "Dave", age = 25 } +-- > i <- runSqlPool (insert person) pool +-- > person' <- runSqlPool (get i) pool +-- > person' `shouldBe` person +-- +-- like this instead: +-- +-- > spec :: Spec +-- > spec = around withConnectionPool $ +-- > eit "can read what it writes" $ do +-- > let person = Person { name = "Dave", age = 25 } +-- > i <- runDB $ insert person +-- > person' <- runDB $ get i +-- > liftIO $ person' `shouldBe` person +-- > +-- > runDB :: ReaderT ConnectionPool IO a -> IO a +-- +-- Note that you use `eit` with a property test. In that case you would have to write it like this: +-- +-- > spec :: Spec +-- > spec = around withConnectionPool $ +-- > it "can read what it writes" $ \pool -> do +-- > forAllValid $ \person -> withTestEnv pool $ do +-- > i <- runDB $ insert person +-- > person' <- runDB $ get i +-- > liftIO $ person' `shouldBe` person +eit :: HasCallStack => String -> ReaderT env IO () -> TestDef l env +eit s f = it s (\env -> runReaderT f env) + +-- | Helper function to run a property test with an 'env'. +-- +-- > withTestEnv = flip runReaderT +withTestEnv :: env -> ReaderT env IO a -> IO a +withTestEnv = flip runReaderT diff --git a/src/Test/Syd/Def/Golden.hs b/src/Test/Syd/Def/Golden.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Def/Golden.hs @@ -0,0 +1,89 @@ +module Test.Syd.Def.Golden where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as SB +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Path +import Path.IO +import Test.Syd.Expectation +import Test.Syd.Run +import Text.Show.Pretty + +-- | Test that the given bytestring is the same as what we find in the given golden file. +pureGoldenByteStringFile :: FilePath -> ByteString -> GoldenTest ByteString +pureGoldenByteStringFile fp bs = goldenByteStringFile fp (pure bs) + +-- | Test that the produced bytestring is the same as what we find in the given golden file. +goldenByteStringFile :: FilePath -> IO ByteString -> GoldenTest ByteString +goldenByteStringFile fp produceBS = + GoldenTest + { goldenTestRead = do + resolvedFile <- resolveFile' fp + forgivingAbsence $ SB.readFile $ fromAbsFile resolvedFile, + goldenTestProduce = produceBS, + goldenTestWrite = \actual -> do + resolvedFile <- resolveFile' fp + ensureDir $ parent resolvedFile + SB.writeFile (fromAbsFile resolvedFile) actual, + goldenTestCompare = \actual expected -> + if actual == expected + then Nothing + else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp) + } + +-- | Test that the given text is the same as what we find in the given golden file. +pureGoldenTextFile :: FilePath -> Text -> GoldenTest Text +pureGoldenTextFile fp bs = goldenTextFile fp (pure bs) + +-- | Test that the produced text is the same as what we find in the given golden file. +goldenTextFile :: FilePath -> IO Text -> GoldenTest Text +goldenTextFile fp produceBS = + GoldenTest + { goldenTestRead = do + resolvedFile <- resolveFile' fp + forgivingAbsence $ TE.decodeUtf8 <$> SB.readFile (fromAbsFile resolvedFile), + goldenTestProduce = produceBS, + goldenTestWrite = \actual -> do + resolvedFile <- resolveFile' fp + ensureDir $ parent resolvedFile + SB.writeFile (fromAbsFile resolvedFile) (TE.encodeUtf8 actual), + goldenTestCompare = \actual expected -> + if actual == expected + then Nothing + else Just $ Context (textsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp) + } + +-- | Test that the given string is the same as what we find in the given golden file. +pureGoldenStringFile :: FilePath -> String -> GoldenTest String +pureGoldenStringFile fp bs = goldenStringFile fp (pure bs) + +-- | Test that the produced string is the same as what we find in the given golden file. +goldenStringFile :: FilePath -> IO String -> GoldenTest String +goldenStringFile fp produceBS = + GoldenTest + { goldenTestRead = do + resolvedFile <- resolveFile' fp + forgivingAbsence $ fmap T.unpack $ TE.decodeUtf8 <$> SB.readFile (fromAbsFile resolvedFile), + goldenTestProduce = produceBS, + goldenTestWrite = \actual -> do + resolvedFile <- resolveFile' fp + ensureDir $ parent resolvedFile + SB.writeFile (fromAbsFile resolvedFile) (TE.encodeUtf8 (T.pack actual)), + goldenTestCompare = \actual expected -> + if actual == expected + then Nothing + else Just $ Context (stringsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp) + } + +-- | Test that the show instance has not changed for the given value. +goldenShowInstance :: Show a => FilePath -> a -> GoldenTest String +goldenShowInstance fp a = pureGoldenStringFile fp (show a) + +-- | Test that the show instance has not changed for the given value, via `ppShow`. +goldenPrettyShowInstance :: Show a => FilePath -> a -> GoldenTest String +goldenPrettyShowInstance fp a = pureGoldenStringFile fp (ppShow a) + +goldenContext :: FilePath -> String +goldenContext fp = "The golden results are in: " <> fp diff --git a/src/Test/Syd/Def/SetupFunc.hs b/src/Test/Syd/Def/SetupFunc.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Def/SetupFunc.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.Syd.Def.SetupFunc where + +import Control.Category as Cat +import Control.Monad.IO.Class +import Test.Syd.Def.Around +import Test.Syd.Def.TestDefM +import Test.Syd.HList + +-- | A function that can provide an 'a' given a 'b'. +-- +-- You can think of this as a potentially-resource-aware version of 'b -> IO a'. +newtype SetupFunc b a = SetupFunc + { unSetupFunc :: forall r. (a -> IO r) -> (b -> IO r) + } + +instance Functor (SetupFunc c) where + fmap f (SetupFunc provideA) = SetupFunc $ \takeB c -> + let takeA = \a -> takeB $ f a + in provideA takeA c + +instance Applicative (SetupFunc c) where + pure a = SetupFunc $ \aFunc _ -> aFunc a + (SetupFunc provideF) <*> (SetupFunc provideA) = SetupFunc $ \takeB c -> + provideF + ( \f -> + provideA + ( \a -> + takeB (f a) + ) + c + ) + c + +instance Monad (SetupFunc c) where + (SetupFunc provideA) >>= m = SetupFunc $ \takeB c -> + provideA + ( \a -> + let (SetupFunc provideB) = m a + in provideB (\b -> takeB b) c + ) + c + +instance MonadIO (SetupFunc c) where + liftIO ioFunc = SetupFunc $ \takeA _ -> do + ioFunc >>= takeA + +instance Category SetupFunc where + id = SetupFunc Prelude.id + (.) = composeSetupFunc + +-- | Turn a simple provider function into a 'SetupFunc'. +-- +-- This works together nicely with most supplier functions. +-- Some examples: +-- +-- * [Network.Wai.Handler.Warp.testWithApplication](https://hackage.haskell.org/package/warp-3.3.13/docs/Network-Wai-Handler-Warp.html#v:testWithApplication) +-- * [Path.IO.withSystemTempDir](https://hackage.haskell.org/package/path-io-1.6.2/docs/Path-IO.html#v:withSystemTempDir) +makeSimpleSetupFunc :: (forall r. (a -> IO r) -> IO r) -> SetupFunc () a +makeSimpleSetupFunc provideA = SetupFunc $ \takeA () -> provideA $ \a -> takeA a + +-- | Use a 'SetupFunc ()' as a simple provider function. +-- +-- This is the opposite of the 'makeSimpleSetupFunc' function +useSimpleSetupFunc :: SetupFunc () a -> (forall r. (a -> IO r) -> IO r) +useSimpleSetupFunc (SetupFunc provideAWithUnit) takeA = provideAWithUnit (\a -> takeA a) () + +-- | Wrap a function that produces a 'SetupFunc' to into a 'SetupFunc'. +-- +-- This is useful to combine a given 'SetupFunc b' with other 'SetupFunc ()'s as follows: +-- +-- > mySetupFunc :: SetupFunc B A +-- > mySetupFunc = wrapSetupFunc $ \b -> do +-- > r <- setupSomething +-- > c <- setupSomethingElse b r +-- > pure $ somehowCombine c r +-- > +-- > setupSomething :: SetupFunc () R +-- > setupSomething :: B -> R -> SetupFunc () C +-- > somehowCombine :: C -> R -> A +wrapSetupFunc :: (b -> SetupFunc () a) -> SetupFunc b a +wrapSetupFunc bFunc = SetupFunc $ \takeA b -> + let SetupFunc provideAWithUnit = bFunc b + in provideAWithUnit (\a -> takeA a) () + +-- | Unwrap a 'SetupFunc' into a function that produces a 'SetupFunc' +-- +-- This is the opposite of 'wrapSetupFunc'. +unwrapSetupFunc :: SetupFunc b a -> (b -> SetupFunc () a) +unwrapSetupFunc (SetupFunc provideAWithB) b = SetupFunc $ \takeA () -> + provideAWithB (\a -> takeA a) b + +-- | Compose two setup functions. +-- +-- This is basically '(.)' but for 'SetupFunc's +composeSetupFunc :: SetupFunc b a -> SetupFunc c b -> SetupFunc c a +composeSetupFunc (SetupFunc provideAWithB) (SetupFunc provideBWithC) = SetupFunc $ \takeA c -> + provideBWithC + ( \b -> + provideAWithB + ( \a -> takeA a + ) + b + ) + c + +-- | Connect two setup functions. +-- +-- This is basically 'flip (.)' but for 'SetupFunc's. +-- It's exactly 'flip composeSetupFunc'. +connectSetupFunc :: SetupFunc c b -> SetupFunc b a -> SetupFunc c a +connectSetupFunc = flip composeSetupFunc + +-- | Use 'around' with a 'SetupFunc' +setupAround :: SetupFunc () c -> TestDefM a c e -> TestDefM a () e +setupAround = setupAroundWith + +-- | Use 'aroundWith' with a 'SetupFunc' +setupAroundWith :: SetupFunc d c -> TestDefM a c e -> TestDefM a d e +setupAroundWith (SetupFunc f) = aroundWith f + +-- | Use 'aroundWith'' with a 'SetupFunc' +setupAroundWith' :: HContains l a => (a -> SetupFunc d c) -> TestDefM l c e -> TestDefM l d e +setupAroundWith' setupFuncFunc = aroundWith' $ \takeAC a d -> + let (SetupFunc provideCWithD) = setupFuncFunc a + in provideCWithD (\c -> takeAC a c) d diff --git a/src/Test/Syd/Def/Specify.hs b/src/Test/Syd/Def/Specify.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Def/Specify.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +-- | This module defines all the functions you will use to define your test suite. +module Test.Syd.Def.Specify + ( -- * API Functions + + -- ** Declaring tests + describe, + it, + itWithOuter, + itWithBoth, + itWithAll, + specify, + specifyWithOuter, + specifyWithBoth, + specifyWithAll, + + -- ** Declaring commented-out tests + xdescribe, + xit, + xitWithOuter, + xitWithBoth, + xitWithAll, + xspecify, + xspecifyWithOuter, + xspecifyWithBoth, + xspecifyWithAll, + + -- ** Pending tests + pending, + pendingWith, + ) +where + +import Control.Monad.RWS.Strict +import qualified Data.Text as T +import GHC.Stack +import Test.QuickCheck.IO () +import Test.Syd.Def.TestDefM +import Test.Syd.HList +import Test.Syd.Run +import Test.Syd.SpecDef + +-- | Declare a test group +-- +-- === Example usage: +-- +-- > describe "addition" $ do +-- > it "adds 3 to 5 to result in 8" $ +-- > 3 + 5 `shouldBe` 8 +-- > it "adds 4 to 7 to result in 11" $ +-- > 4 + 7 `shouldBe` 11 +describe :: String -> TestDefM a b () -> TestDefM a b () +describe s func = censor ((: []) . DefDescribeNode (T.pack s)) func + +-- TODO maybe we want to keep all tests below but replace them with a "Pending" instead. +xdescribe :: String -> TestDefM a b () -> TestDefM a b () +xdescribe s _ = pending s + +-- | Declare a test +-- +-- __Note: Don't look at the type signature unless you really have to, just follow the examples.__ +-- +-- === Example usage: +-- +-- ==== Tests without resources +-- +-- ===== Pure test +-- +-- > describe "addition" $ +-- > it "adds 3 to 5 to result in 8" $ +-- > 3 + 5 == 8 +-- +-- +-- ===== IO test +-- +-- > describe "readFile and writeFile" $ +-- > it "reads back what it wrote for this example" $ do +-- > let cts = "hello world" +-- > let fp = "test.txt" +-- > writeFile fp cts +-- > cts' <- readFile fp +-- > cts' `shouldBe` cts +-- +-- +-- ===== Pure Property test +-- +-- > describe "sort" $ +-- > it "is idempotent" $ +-- > forAllValid $ \ls -> +-- > sort (sort ls) `shouldBe` (sort (ls :: [Int])) +-- +-- +-- ===== IO Property test +-- +-- > describe "readFile and writeFile" $ +-- > it "reads back what it wrote for any example" $ do +-- > forAllValid $ \fp -> +-- > forAllValid $ \cts -> do +-- > writeFile fp cts +-- > cts' <- readFile fp +-- > cts' `shouldBe` cts +-- +-- +-- ==== Tests with an inner resource +-- +-- ===== Pure test +-- +-- This is quite a rare use-case but here is an example anyway: +-- +-- > before (pure 3) $ describe "addition" $ +-- > it "adds 3 to 5 to result in 8" $ \i -> +-- > i + 5 == 8 +-- +-- +-- ===== IO test +-- +-- This test sets up a temporary directory as an inner resource, and makes it available to each test in the group below. +-- +-- > let setUpTempDir func = withSystemTempDir $ \tempDir -> func tempDir +-- > in around setUpTempDir describe "readFile and writeFile" $ +-- > it "reads back what it wrote for this example" $ \tempDir -> do +-- > let cts = "hello world" +-- > let fp = tempDir "test.txt" +-- > writeFile fp cts +-- > cts' <- readFile fp +-- > cts' `shouldBe` cts +-- +-- +-- ===== Pure property test +-- +-- This is quite a rare use-case but here is an example anyway: +-- +-- > before (pure 3) $ describe "multiplication" $ +-- > it "is commutative for 5" $ \i -> +-- > i * 5 == 5 * 3 +-- +-- +-- ===== IO property test +-- +-- > let setUpTempDir func = withSystemTempDir $ \tempDir -> func tempDir +-- > in around setUpTempDir describe "readFile and writeFile" $ +-- > it "reads back what it wrote for this example" $ \tempDir -> +-- > property $ \cts -> do +-- > let fp = tempDir "test.txt" +-- > writeFile fp cts +-- > cts' <- readFile fp +-- > cts' `shouldBe` cts +it :: forall outers test. (HasCallStack, IsTest test, Arg1 test ~ ()) => String -> test -> TestDefM outers (Arg2 test) () +it s t = do + sets <- ask + let testDef = + TDef + { testDefVal = \supplyArgs -> + runTest + t + sets + ( \func -> supplyArgs (\_ arg2 -> func () arg2) + ), + testDefCallStack = callStack + } + tell [DefSpecifyNode (T.pack s) testDef ()] + +xit :: forall outers test. (HasCallStack, IsTest test, Arg1 test ~ ()) => String -> test -> TestDefM outers (Arg2 test) () +xit s _ = pending s + +-- | Declare a test that uses an outer resource +-- +-- === Example usage: +-- +-- ==== Tests with an outer resource +-- +-- ===== __Pure test__ +-- +-- This is quite a rare use-case but here is an example anyway: +-- +-- > beforeAll (pure 3) $ describe "addition" $ +-- > itWithBoth "adds 3 to 5 to result in 8" $ \i -> +-- > i + 5 == 8 +-- +-- +-- ===== IO test +-- +-- This test sets up a temporary directory as an inner resource, and makes it available to each test in the group below. +-- +-- > let setUpTempDir func = withSystemTempDir $ \tempDir -> func tempDir +-- > in aroundAll setUpTempDir describe "readFile and writeFile" $ +-- > itWithBoth "reads back what it wrote for this example" $ \tempDir -> do +-- > let cts = "hello world" +-- > let fp = tempDir "test.txt" +-- > writeFile fp cts +-- > cts' <- readFile fp +-- > cts' `shouldBe` cts +-- +-- +-- ===== __Pure property test__ +-- +-- This is quite a rare use-case but here is an example anyway: +-- +-- > beforeAll (pure 3) $ describe "multiplication" $ +-- > itWithBoth "is commutative for 5" $ \i -> +-- > i * 5 == 5 * 3 +-- +-- +-- ===== IO property test +-- +-- > let setUpTempDir func = withSystemTempDir $ \tempDir -> func tempDir +-- > in aroundAll setUpTempDir describe "readFile and writeFile" $ +-- > itWithBoth "reads back what it wrote for this example" $ \tempDir -> +-- > property $ \cts -> do +-- > let fp = tempDir "test.txt" +-- > writeFile fp cts +-- > cts' <- readFile fp +-- > cts' `shouldBe` cts +itWithOuter :: (HasCallStack, IsTest test) => String -> test -> TestDefM (Arg2 test ': l) (Arg1 test) () +itWithOuter s t = do + sets <- ask + let testDef = + TDef + { testDefVal = \supplyArgs -> + runTest + t + sets + (\func -> supplyArgs $ \(HCons outerArgs _) innerArg -> func innerArg outerArgs), + testDefCallStack = callStack + } + tell [DefSpecifyNode (T.pack s) testDef ()] + +xitWithOuter :: (HasCallStack, IsTest test) => String -> test -> TestDefM (Arg2 test ': l) (Arg1 test) () +xitWithOuter s _ = pending s + +-- | Declare a test that uses both an inner and an outer resource +-- +-- === Example usage: +-- +-- ==== Tests with both an inner and an outer resource +-- +-- ===== __Pure test__ +-- +-- This is quite a rare use-case but here is an example anyway: +-- +-- > beforeAll (pure 3) $ before (pure 5) $ describe "addition" $ +-- > itWithBoth "adds 3 to 5 to result in 8" $ \i j -> +-- > i + j == 8 +-- +-- +-- ===== IO test +-- +-- This test sets up a temporary directory as an inner resource, and makes it available to each test in the group below. +-- +-- > let setUpTempDir func = withSystemTempDir $ \tempDir -> func tempDir +-- > in aroundAll setUpTempDir describe "readFile and writeFile" $ before (pure "hello world") $ +-- > itWithBoth "reads back what it wrote for this example" $ \tempDir cts -> do +-- > let fp = tempDir "test.txt" +-- > writeFile fp cts +-- > cts' <- readFile fp +-- > cts' `shouldBe` cts +-- +-- +-- ===== __Pure property test__ +-- +-- This is quite a rare use-case but here is an example anyway: +-- +-- > beforeAll (pure 3) $ before (pure 5) $ describe "multiplication" $ +-- > itWithBoth "is commutative" $ \i j -> +-- > i * j == 5 * 3 +-- +-- +-- ===== IO property test +-- +-- > let setUpTempDir func = withSystemTempDir $ \tempDir -> func tempDir +-- > in aroundAll setUpTempDir describe "readFile and writeFile" $ before (pure "test.txt") $ +-- > itWithBoth "reads back what it wrote for this example" $ \tempDir fileName -> +-- > property $ \cts -> do +-- > let fp = tempDir fileName +-- > writeFile fp cts +-- > cts' <- readFile fp +-- > cts' `shouldBe` cts +itWithBoth :: (HasCallStack, IsTest test) => String -> test -> TestDefM (Arg1 test ': l) (Arg2 test) () +itWithBoth s t = do + sets <- ask + let testDef = + TDef + { testDefVal = \supplyArgs -> + runTest + t + sets + (\func -> supplyArgs $ \(HCons outerArgs _) innerArg -> func outerArgs innerArg), + testDefCallStack = callStack + } + tell [DefSpecifyNode (T.pack s) testDef ()] + +xitWithBoth :: (HasCallStack, IsTest test) => String -> test -> TestDefM (Arg1 test ': l) (Arg2 test) () +xitWithBoth s _ = pending s + +-- | Declare a test that uses all outer resources +-- +-- You will most likely never need this function, but in case you do: +-- Note that this will always require a type annotation, along with the @GADTs@ and @ScopedTypeVariables@ extensions. +-- +-- === Example usage +-- +-- > beforeAll (pure 'a') $ beforeAll (pure 5) $ +-- > itWithAll "example" $ +-- > \(HCons c (HCons i HNil) :: HList '[Char, Int]) () -> +-- > (c, i) `shouldeBe` ('a', 5) +itWithAll :: (HasCallStack, IsTest test, Arg1 test ~ HList l) => String -> test -> TestDefM l (Arg2 test) () +itWithAll s t = do + sets <- ask + let testDef = + TDef + { testDefVal = \supplyArgs -> + runTest + t + sets + (\func -> supplyArgs func), + testDefCallStack = callStack + } + tell [DefSpecifyNode (T.pack s) testDef ()] + +xitWithAll :: (HasCallStack, IsTest test, Arg1 test ~ HList l) => String -> test -> TestDefM l (Arg2 test) () +xitWithAll s _ = pending s + +-- | A synonym for 'it' +specify :: forall outers test. (HasCallStack, IsTest test, Arg1 test ~ ()) => String -> test -> TestDefM outers (Arg2 test) () +specify = it + +xspecify :: forall outers test. (HasCallStack, IsTest test, Arg1 test ~ ()) => String -> test -> TestDefM outers (Arg2 test) () +xspecify = xit + +-- | A synonym for 'itWithOuter' +specifyWithOuter :: (HasCallStack, IsTest test) => String -> test -> TestDefM (Arg2 test ': l) (Arg1 test) () +specifyWithOuter = itWithOuter + +xspecifyWithOuter :: (HasCallStack, IsTest test) => String -> test -> TestDefM (Arg2 test ': l) (Arg1 test) () +xspecifyWithOuter = xitWithOuter + +-- | A synonym for 'itWithBoth' +specifyWithBoth :: (HasCallStack, IsTest test) => String -> test -> TestDefM (Arg1 test ': l) (Arg2 test) () +specifyWithBoth = itWithBoth + +xspecifyWithBoth :: (HasCallStack, IsTest test) => String -> test -> TestDefM (Arg1 test ': l) (Arg2 test) () +xspecifyWithBoth = xitWithBoth + +-- | A synonym for 'itWithAll' +specifyWithAll :: (HasCallStack, IsTest test, Arg1 test ~ HList l) => String -> test -> TestDefM l (Arg2 test) () +specifyWithAll = itWithAll + +xspecifyWithAll :: (HasCallStack, IsTest test, Arg1 test ~ HList l) => String -> test -> TestDefM l (Arg2 test) () +xspecifyWithAll = xitWithAll + +-- | Declare a test that has not been written yet. +pending :: String -> TestDefM a b () +pending s = tell [DefPendingNode (T.pack s) Nothing] + +-- | Declare a test that has not been written yet for the given reason. +pendingWith :: String -> String -> TestDefM a b () +pendingWith s reason = tell [DefPendingNode (T.pack s) (Just (T.pack reason))] diff --git a/src/Test/Syd/Def/TestDefM.hs b/src/Test/Syd/Def/TestDefM.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Def/TestDefM.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Syd.Def.TestDefM where + +import Control.Monad +import Control.Monad.RWS.Strict +import Control.Monad.Random +import Data.DList (DList) +import qualified Data.DList as DList +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import System.Random.Shuffle +import Test.QuickCheck.IO () +import Test.Syd.OptParse +import Test.Syd.Run +import Test.Syd.SpecDef + +-- | A synonym for easy migration from hspec +type Spec = SpecWith () + +-- | A synonym for easy migration from hspec +type SpecWith a = SpecM a () + +-- | A synonym for easy migration from hspec +type SpecM a b = TestDefM '[] a b + +-- | A synonym for a test suite definition +type TestDef a b = TestDefM a b () + +-- | The test definition monad +-- +-- This type has three parameters: +-- +-- * @a@: The type of the result of `aroundAll` +-- * @b@: The type of the result of `around` +-- * @c@: The result +-- +-- In practice, all of these three parameters should be '()' at the top level. +newtype TestDefM a b c = TestDefM + { unTestDefM :: RWST TestRunSettings (TestForest a b) () IO c + } + deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestRunSettings, MonadWriter (TestForest a b), MonadState ()) + +execTestDefM :: Settings -> TestDefM a b c -> IO (TestForest a b) +execTestDefM sets = fmap snd . runTestDefM sets + +runTestDefM :: Settings -> TestDefM a b c -> IO (c, TestForest a b) +runTestDefM sets defFunc = do + let func = unTestDefM defFunc + (a, _, testForest) <- runRWST func (toTestRunSettings sets) () -- TODO allow passing in settings from the command-line + let testForest' = filterTestForest (settingFilter sets) testForest + let testForest'' = + if settingRandomiseExecutionOrder sets + then evalRand (randomiseTestForest testForest') (mkStdGen (settingSeed sets)) + else testForest' + pure (a, testForest'') + +toTestRunSettings :: Settings -> TestRunSettings +toTestRunSettings Settings {..} = + TestRunSettings + { testRunSettingSeed = settingSeed, + testRunSettingMaxSuccess = settingMaxSuccess, + testRunSettingMaxSize = settingMaxSize, + testRunSettingMaxDiscardRatio = settingMaxDiscard, + testRunSettingMaxShrinks = settingMaxShrinks, + testRunSettingGoldenStart = settingGoldenStart, + testRunSettingGoldenReset = settingGoldenReset + } + +filterTestForest :: Maybe Text -> SpecDefForest a b c -> SpecDefForest a b c +filterTestForest mf = fromMaybe [] . goForest DList.empty + where + goForest :: DList Text -> SpecDefForest a b c -> Maybe (SpecDefForest a b c) + goForest ts sdf = do + let sdf' = mapMaybe (goTree ts) sdf + guard $ not $ null sdf' + pure sdf' + + filterGuard :: DList Text -> Bool + filterGuard dl = case mf of + Just f -> f `T.isInfixOf` T.intercalate "." (DList.toList dl) + Nothing -> True + + goTree :: DList Text -> SpecDefTree a b c -> Maybe (SpecDefTree a b c) + goTree dl = \case + DefSpecifyNode t td e -> do + let tl = DList.snoc dl t + guard $ filterGuard tl + pure $ DefSpecifyNode t td e + DefPendingNode t mr -> do + let tl = DList.snoc dl t + guard $ filterGuard tl + pure $ DefPendingNode t mr + DefDescribeNode t sdf -> DefDescribeNode t <$> goForest (DList.snoc dl t) sdf + DefWrapNode func sdf -> DefWrapNode func <$> goForest dl sdf + DefBeforeAllNode func sdf -> DefBeforeAllNode func <$> goForest dl sdf + DefAroundAllNode func sdf -> DefAroundAllNode func <$> goForest dl sdf + DefAroundAllWithNode func sdf -> DefAroundAllWithNode func <$> goForest dl sdf + DefAfterAllNode func sdf -> DefAfterAllNode func <$> goForest dl sdf + DefParallelismNode func sdf -> DefParallelismNode func <$> goForest dl sdf + DefRandomisationNode func sdf -> DefRandomisationNode func <$> goForest dl sdf + +randomiseTestForest :: MonadRandom m => SpecDefForest a b c -> m (SpecDefForest a b c) +randomiseTestForest = goForest + where + goForest :: MonadRandom m => SpecDefForest a b c -> m (SpecDefForest a b c) + goForest = traverse goTree >=> shuffleM + goTree :: MonadRandom m => SpecDefTree a b c -> m (SpecDefTree a b c) + goTree = \case + DefSpecifyNode t td e -> pure $ DefSpecifyNode t td e + DefPendingNode t mr -> pure $ DefPendingNode t mr + DefDescribeNode t sdf -> DefDescribeNode t <$> goForest sdf + DefWrapNode func sdf -> DefWrapNode func <$> goForest sdf + DefBeforeAllNode func sdf -> DefBeforeAllNode func <$> goForest sdf + DefAroundAllNode func sdf -> DefAroundAllNode func <$> goForest sdf + DefAroundAllWithNode func sdf -> DefAroundAllWithNode func <$> goForest sdf + DefAfterAllNode func sdf -> DefAfterAllNode func <$> goForest sdf + DefParallelismNode func sdf -> DefParallelismNode func <$> goForest sdf + DefRandomisationNode eor sdf -> + DefRandomisationNode eor <$> case eor of + RandomiseExecutionOrder -> goForest sdf + DoNotRandomiseExecutionOrder -> pure sdf diff --git a/src/Test/Syd/Expectation.hs b/src/Test/Syd/Expectation.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Expectation.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +-- | This module defines all the functions you will use to define your tests +module Test.Syd.Expectation where + +import Control.Exception +import Control.Monad.Reader +import Data.ByteString (ByteString) +import Data.List +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +import GHC.Stack +import Test.QuickCheck.IO () +import Test.Syd.Run +import Text.Show.Pretty + +-- | Assert that two values are equal according to `==`. +shouldBe :: (HasCallStack, Show a, Eq a) => a -> a -> IO () +shouldBe actual expected = unless (actual == expected) $ throwIO $ NotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected) + +infix 1 `shouldBe` + +-- | Assert that two values are not equal according to `==`. +shouldNotBe :: (HasCallStack, Show a, Eq a) => a -> a -> IO () +shouldNotBe actual expected = unless (actual /= expected) $ throwIO $ EqualButShouldNotHaveBeenEqual (ppShow actual) (ppShow expected) + +infix 1 `shouldNotBe` + +-- | Assert that a value satisfies the given predicate. +shouldSatisfy :: (HasCallStack, Show a) => a -> (a -> Bool) -> IO () +shouldSatisfy actual p = unless (p actual) $ throwIO $ PredicateFailedButShouldHaveSucceeded (ppShow actual) Nothing + +-- | Assert that a value satisfies the given predicate with the given predicate name. +shouldSatisfyNamed :: (HasCallStack, Show a) => a -> String -> (a -> Bool) -> IO () +shouldSatisfyNamed actual name p = unless (p actual) $ throwIO $ PredicateFailedButShouldHaveSucceeded (ppShow actual) (Just name) + +infix 1 `shouldSatisfy` + +-- | Assert that a value does not satisfy the given predicate. +shouldNotSatisfy :: (HasCallStack, Show a) => a -> (a -> Bool) -> IO () +shouldNotSatisfy actual p = when (p actual) $ throwIO $ PredicateSucceededButShouldHaveFailed (ppShow actual) Nothing + +infix 1 `shouldNotSatisfy` + +-- | Assert that a value does not satisfy the given predicate with the given predicate name. +shouldNotSatisfyNamed :: (HasCallStack, Show a) => a -> String -> (a -> Bool) -> IO () +shouldNotSatisfyNamed actual name p = when (p actual) $ throwIO $ PredicateSucceededButShouldHaveFailed (ppShow actual) (Just name) + +-- | Assert that computation returns the given value (according to `==`). +shouldReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> IO () +shouldReturn computeActual expected = do + actual <- computeActual + unless (actual == expected) $ throwIO $ NotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected) + +infix 1 `shouldReturn` + +-- | Assert that computation returns the given value (according to `==`). +shouldNotReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> IO () +shouldNotReturn computeActual expected = do + actual <- computeActual + unless (actual /= expected) $ throwIO $ EqualButShouldNotHaveBeenEqual (ppShow actual) (ppShow expected) + +infix 1 `shouldNotReturn` + +-- | Assert that the given list has the given prefix +shouldStartWith :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +shouldStartWith a i = shouldSatisfyNamed a ("has infix\n" <> ppShow i) (isInfixOf i) + +infix 1 `shouldStartWith` + +-- | Assert that the given list has the given suffix +shouldEndWith :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +shouldEndWith a s = shouldSatisfyNamed a ("has suffix\n" <> ppShow s) (isSuffixOf s) + +infix 1 `shouldEndWith` + +-- | Assert that the given list has the given infix +shouldContain :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +shouldContain a i = shouldSatisfyNamed a ("has infix\n" <> ppShow i) (isInfixOf i) + +infix 1 `shouldContain` + +-- | Assert that two 'String's are equal according to `==`. +-- +-- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes. +-- In that case you may want to `show` your values first or use `shouldBe` instead. +stringShouldBe :: HasCallStack => String -> String -> IO () +stringShouldBe actual expected = unless (actual == expected) $ throwIO $ stringsNotEqualButShouldHaveBeenEqual actual expected + +-- | Assert that two 'Text's are equal according to `==`. +-- +-- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes. +-- In that case you may want to `show` your values first or use `shouldBe` instead. +textShouldBe :: HasCallStack => Text -> Text -> IO () +textShouldBe actual expected = unless (actual == expected) $ throwIO $ textsNotEqualButShouldHaveBeenEqual actual expected + +-- | An assertion that says two 'String's should have been equal according to `==`. +-- +-- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes. +-- In that case you may want to `show` your values first or use `shouldBe` instead. +stringsNotEqualButShouldHaveBeenEqual :: String -> String -> Assertion +stringsNotEqualButShouldHaveBeenEqual actual expected = NotEqualButShouldHaveBeenEqual actual expected + +-- | An assertion that says two 'Text's should have been equal according to `==`. +-- +-- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes. +-- In that case you may want to `show` your values first or use `shouldBe` instead. +textsNotEqualButShouldHaveBeenEqual :: Text -> Text -> Assertion +textsNotEqualButShouldHaveBeenEqual actual expected = NotEqualButShouldHaveBeenEqual (T.unpack actual) (T.unpack expected) + +-- | An assertion that says two 'ByteString's should have been equal according to `==`. +bytestringsNotEqualButShouldHaveBeenEqual :: ByteString -> ByteString -> Assertion +bytestringsNotEqualButShouldHaveBeenEqual actual expected = NotEqualButShouldHaveBeenEqual (show actual) (show expected) + +-- | Make a test fail +-- +-- Note that this is mostly backward compatible, but it has return type 'a' instead of '()' because execution will not continue beyond this function. +-- In this way it is not entirely backward compatible with hspec because now there could be an ambiguous type error. +expectationFailure :: HasCallStack => String -> IO a +expectationFailure = throwIO . ExpectationFailed + +-- | Annotate a given action with a context, for contextual assertions +context :: String -> IO a -> IO a +context s action = (action >>= evaluate) `catch` (\a -> throwIO (Context a s)) + +-- | For easy hspec migration +type Expectation = IO () + +-- | For easy hspec migration +type Selector a = (a -> Bool) + +-- | Assert that a given IO action throws an exception that matches the given exception +shouldThrow :: forall e a. (HasCallStack, Exception e) => IO a -> Selector e -> Expectation +action `shouldThrow` p = do + r <- try action + case r of + Right _ -> + expectationFailure $ + "did not get expected exception: " ++ exceptionType + Left e -> + context ("predicate failed on expected exception: " ++ exceptionType ++ " (" ++ show e ++ ")") $ + e `shouldSatisfy` p + where + -- a string repsentation of the expected exception's type + exceptionType = (show . typeOf @e) undefined + +infix 1 `shouldThrow` + +anyException :: Selector SomeException +anyException = const True + +anyErrorCall :: Selector ErrorCall +anyErrorCall = const True + +errorCall :: String -> Selector ErrorCall +errorCall s (ErrorCallWithLocation msg _) = s == msg + +anyIOException :: Selector IOException +anyIOException = const True + +anyArithException :: Selector ArithException +anyArithException = const True diff --git a/src/Test/Syd/HList.hs b/src/Test/Syd/HList.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/HList.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Syd.HList where + +import Data.Kind + +data HList (r :: [Type]) where + HNil :: HList '[] + HCons :: e -> HList l -> HList (e ': l) + +class HContains (l :: [Type]) a where + getElem :: HList l -> a + +instance HContains '[] () where + getElem HNil = () + +instance HContains l (HList l) where + getElem = id + +instance HContains '[a] a where + getElem (HCons a _) = a + +instance HContains (a ': l) a where + getElem (HCons a _) = a + +instance HContains l a => HContains (b ': l) a where + getElem (HCons _ hl) = getElem hl diff --git a/src/Test/Syd/Modify.hs b/src/Test/Syd/Modify.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Modify.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module defines functions for declaring different test settings +module Test.Syd.Modify + ( -- * Declaring different test settings + modifyMaxSuccess, + modifyMaxDiscardRatio, + modifyMaxSize, + modifyMaxShrinks, + modifyRunSettings, + TestRunSettings (..), + + -- * Declaring parallelism + sequential, + parallel, + withParallelism, + Parallelism (..), + + -- * Declaring randomisation order + randomiseExecutionOrder, + doNotRandomiseExecutionOrder, + withExecutionOrderRandomisation, + ExecutionOrderRandomisation (..), + ) +where + +import Control.Monad.RWS.Strict +import Test.QuickCheck.IO () +import Test.Syd.Def +import Test.Syd.Run +import Test.Syd.SpecDef + +modifyRunSettings :: (TestRunSettings -> TestRunSettings) -> TestDefM a b c -> TestDefM a b c +modifyRunSettings = local + +modifyMaxSuccess :: (Int -> Int) -> TestDefM a b c -> TestDefM a b c +modifyMaxSuccess func = modifyRunSettings $ \trs -> trs {testRunSettingMaxSuccess = func (testRunSettingMaxSuccess trs)} + +modifyMaxDiscardRatio :: (Int -> Int) -> TestDefM a b c -> TestDefM a b c +modifyMaxDiscardRatio func = modifyRunSettings $ \trs -> trs {testRunSettingMaxDiscardRatio = func (testRunSettingMaxDiscardRatio trs)} + +modifyMaxSize :: (Int -> Int) -> TestDefM a b c -> TestDefM a b c +modifyMaxSize func = modifyRunSettings $ \trs -> trs {testRunSettingMaxSize = func (testRunSettingMaxSize trs)} + +modifyMaxShrinks :: (Int -> Int) -> TestDefM a b c -> TestDefM a b c +modifyMaxShrinks func = modifyRunSettings $ \trs -> trs {testRunSettingMaxShrinks = func (testRunSettingMaxShrinks trs)} + +-- | Declare that all tests below must be run sequentially +sequential :: TestDefM a b c -> TestDefM a b c +sequential = withParallelism Sequential + +-- | Declare that all tests below may be run in parallel. (This is the default.) +parallel :: TestDefM a b c -> TestDefM a b c +parallel = withParallelism Parallel + +withParallelism :: Parallelism -> TestDefM a b c -> TestDefM a b c +withParallelism p = censor ((: []) . DefParallelismNode p) + +randomiseExecutionOrder :: TestDefM a b c -> TestDefM a b c +randomiseExecutionOrder = withExecutionOrderRandomisation RandomiseExecutionOrder + +doNotRandomiseExecutionOrder :: TestDefM a b c -> TestDefM a b c +doNotRandomiseExecutionOrder = withExecutionOrderRandomisation DoNotRandomiseExecutionOrder + +withExecutionOrderRandomisation :: ExecutionOrderRandomisation -> TestDefM a b c -> TestDefM a b c +withExecutionOrderRandomisation p = censor ((: []) . DefRandomisationNode p) diff --git a/src/Test/Syd/OptParse.hs b/src/Test/Syd/OptParse.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/OptParse.hs @@ -0,0 +1,443 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.OptParse where + +import Control.Applicative +import Control.Monad +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Yaml +import qualified Env +import GHC.Generics (Generic) +import Options.Applicative as OptParse +import qualified Options.Applicative.Help as OptParse (string) +import Path +import Path.IO +import Test.Syd.Run +import YamlParse.Applicative as YamlParse + +getSettings :: IO Settings +getSettings = do + flags <- getFlags + env <- getEnvironment + config <- getConfiguration flags env + combineToSettings flags env config + +-- | Test suite definition and run settings +data Settings = Settings + { -- | The seed to use for deterministic randomness + settingSeed :: !Int, + -- | Randomise the execution order of the tests in the test suite + settingRandomiseExecutionOrder :: !Bool, + -- | How parallel to run the test suite + settingThreads :: !Threads, + -- | How many examples to run a property test with + settingMaxSuccess :: !Int, + -- | The maximum size parameter to supply to generators + settingMaxSize :: !Int, + -- | The maximum number of discarded examples per tested example + settingMaxDiscard :: !Int, + -- | The maximum number of tries to use while shrinking a counterexample. + settingMaxShrinks :: !Int, + -- | Whether to write golden tests if they do not exist yet + settingGoldenStart :: !Bool, + -- | Whether to overwrite golden tests instead of having them fail + settingGoldenReset :: !Bool, + -- | Whether to use colour in the output + settingColour :: !(Maybe Bool), + -- | The filter to use to select which tests to run + settingFilter :: !(Maybe Text), + -- | Whether to stop upon the first test failure + settingFailFast :: !Bool, + -- | How many iterations to use to look diagnose flakiness + settingIterations :: Iterations + } + deriving (Show, Eq, Generic) + +defaultSettings :: Settings +defaultSettings = + let d func = func defaultTestRunSettings + in Settings + { settingSeed = d testRunSettingSeed, + settingRandomiseExecutionOrder = True, + settingThreads = ByCapabilities, + settingMaxSuccess = d testRunSettingMaxSuccess, + settingMaxSize = d testRunSettingMaxSize, + settingMaxDiscard = d testRunSettingMaxDiscardRatio, + settingMaxShrinks = d testRunSettingMaxShrinks, + settingGoldenStart = d testRunSettingGoldenStart, + settingGoldenReset = d testRunSettingGoldenReset, + settingColour = Nothing, + settingFilter = Nothing, + settingFailFast = False, + settingIterations = OneIteration + } + +data Threads + = -- | One thread + Synchronous + | -- | As many threads as 'getNumCapabilities' tells you you have + ByCapabilities + | -- | A given number of threads + Asynchronous Int + deriving (Show, Eq, Generic) + +data Iterations + = -- | Run the test suite once, the default + OneIteration + | -- | Run the test suite for the given number of iterations, or until we can find flakiness + Iterations Int + | -- | Run the test suite over and over, until we can find some flakiness + Continuous + deriving (Show, Eq, Generic) + +-- | Combine everything to 'Settings' +combineToSettings :: Flags -> Environment -> Maybe Configuration -> IO Settings +combineToSettings Flags {..} Environment {..} mConf = do + let d func = func defaultSettings + pure + Settings + { settingSeed = fromMaybe (d settingSeed) $ flagSeed <|> envSeed <|> mc configSeed, + settingRandomiseExecutionOrder = fromMaybe (d settingRandomiseExecutionOrder) $ flagRandomiseExecutionOrder <|> envRandomiseExecutionOrder <|> mc configRandomiseExecutionOrder, + settingThreads = fromMaybe (d settingThreads) $ flagThreads <|> envThreads <|> mc configThreads, + settingMaxSuccess = fromMaybe (d settingMaxSuccess) $ flagMaxSuccess <|> envMaxSuccess <|> mc configMaxSuccess, + settingMaxSize = fromMaybe (d settingMaxSize) $ flagMaxSize <|> envMaxSize <|> mc configMaxSize, + settingMaxDiscard = fromMaybe (d settingMaxDiscard) $ flagMaxDiscard <|> envMaxDiscard <|> mc configMaxDiscard, + settingMaxShrinks = fromMaybe (d settingMaxShrinks) $ flagMaxShrinks <|> envMaxShrinks <|> mc configMaxShrinks, + settingGoldenStart = fromMaybe (d settingGoldenStart) $ flagGoldenStart <|> envGoldenStart <|> mc configGoldenStart, + settingGoldenReset = fromMaybe (d settingGoldenReset) $ flagGoldenReset <|> envGoldenReset <|> mc configGoldenReset, + settingColour = flagColour <|> envColour <|> mc configColour, + settingFilter = flagFilter <|> envFilter <|> mc configFilter, + settingFailFast = fromMaybe (d settingFailFast) $ flagFailFast <|> envFailFast <|> mc configFailFast, + settingIterations = fromMaybe (d settingIterations) $ flagIterations <|> envIterations <|> mc configIterations + } + where + mc :: (Configuration -> Maybe a) -> Maybe a + mc f = mConf >>= f + +-- | What we find in the configuration variable. +-- +-- Do nothing clever here, just represent the configuration file. +-- For example, use 'Maybe FilePath', not 'Path Abs File'. +-- +-- Use 'YamlParse.readConfigFile' or 'YamlParse.readFirstConfigFile' to read a configuration. +data Configuration = Configuration + { configSeed :: !(Maybe Int), + configRandomiseExecutionOrder :: !(Maybe Bool), + configThreads :: !(Maybe Threads), + configMaxSize :: !(Maybe Int), + configMaxSuccess :: !(Maybe Int), + configMaxDiscard :: !(Maybe Int), + configMaxShrinks :: !(Maybe Int), + configGoldenStart :: !(Maybe Bool), + configGoldenReset :: !(Maybe Bool), + configColour :: !(Maybe Bool), + configFilter :: !(Maybe Text), + configFailFast :: !(Maybe Bool), + configIterations :: !(Maybe Iterations) + } + deriving (Show, Eq, Generic) + +instance FromJSON Configuration where + parseJSON = viaYamlSchema + +-- | We use 'yamlparse-applicative' for parsing a YAML config. +instance YamlSchema Configuration where + yamlSchema = + objectParser "Configuration" $ + Configuration + <$> optionalField "seed" "Seed for random generation of test cases" + <*> optionalField "randomise-execution-order" "Randomise the execution order of the tests in the test suite" + <*> optionalField "parallelism" "How parallel to execute the tests" + <*> optionalField "max-success" "Number of quickcheck examples to run" + <*> optionalField "max-size" "Maximum size parameter to pass to generators" + <*> optionalField "max-discard" "Maximum number of discarded tests per successful test before giving up" + <*> optionalField "max-shrinks" "Maximum number of shrinks of a failing test input" + <*> optionalField "golden-start" "Whether to write golden tests if they do not exist yet" + <*> optionalField "golden-reset" "Whether to overwrite golden tests instead of having them fail" + <*> optionalField "colour" "Whether to use coloured output" + <*> optionalField "filter" "Filter to select which parts of the test tree to run" + <*> optionalField "fail-fast" "Whether to stop executing upon the first test failure" + <*> optionalField "iterations" "How many iterations to use to look diagnose flakiness" + +instance YamlSchema Threads where + yamlSchema = flip fmap yamlSchema $ \case + Nothing -> ByCapabilities + Just 1 -> Synchronous + Just n -> Asynchronous n + +instance YamlSchema Iterations where + yamlSchema = flip fmap yamlSchema $ \case + Nothing -> OneIteration + Just 0 -> Continuous + Just 1 -> OneIteration + Just n -> Iterations n + +-- | Get the configuration +-- +-- We use the flags and environment because they can contain information to override where to look for the configuration files. +-- We return a 'Maybe' because there may not be a configuration file. +getConfiguration :: Flags -> Environment -> IO (Maybe Configuration) +getConfiguration Flags {..} Environment {..} = + case flagConfigFile <|> envConfigFile of + Nothing -> defaultConfigFile >>= YamlParse.readConfigFile + Just cf -> do + afp <- resolveFile' cf + YamlParse.readConfigFile afp + +-- | Where to get the configuration file by default. +defaultConfigFile :: IO (Path Abs File) +defaultConfigFile = resolveFile' ".sydtest.yaml" + +-- | What we find in the configuration variable. +-- +-- Do nothing clever here, just represent the relevant parts of the environment. +-- For example, use 'Text', not 'SqliteConfig'. +data Environment = Environment + { envConfigFile :: Maybe FilePath, + envSeed :: !(Maybe Int), + envRandomiseExecutionOrder :: !(Maybe Bool), + envThreads :: !(Maybe Threads), + envMaxSize :: !(Maybe Int), + envMaxSuccess :: !(Maybe Int), + envMaxDiscard :: !(Maybe Int), + envMaxShrinks :: !(Maybe Int), + envGoldenStart :: !(Maybe Bool), + envGoldenReset :: !(Maybe Bool), + envColour :: !(Maybe Bool), + envFilter :: !(Maybe Text), + envFailFast :: !(Maybe Bool), + envIterations :: !(Maybe Iterations) + } + deriving (Show, Eq, Generic) + +getEnvironment :: IO Environment +getEnvironment = Env.parse (Env.header "Environment") environmentParser + +-- | The 'envparse' parser for the 'Environment' +environmentParser :: Env.Parser Env.Error Environment +environmentParser = + Env.prefixed "SYDTEST_" $ + Environment + <$> Env.var (fmap Just . Env.str) "CONFIG_FILE" (mE <> Env.help "Config file") + <*> Env.var (fmap Just . Env.auto) "SEED" (mE <> Env.help "Seed for random generation of test cases") + <*> Env.var (fmap Just . Env.auto) "RANDOMISE_EXECUTION_ORDER" (mE <> Env.help "Randomise the execution order of the tests in the test suite") + <*> Env.var (fmap Just . (Env.auto >=> parseThreads)) "PARALLELISM" (mE <> Env.help "How parallel to execute the tests") + <*> Env.var (fmap Just . Env.auto) "MAX_SUCCESS" (mE <> Env.help "Number of quickcheck examples to run") + <*> Env.var (fmap Just . Env.auto) "MAX_SIZE" (mE <> Env.help "Maximum size parameter to pass to generators") + <*> Env.var (fmap Just . Env.auto) "MAX_DISCARD" (mE <> Env.help "Maximum number of discarded tests per successful test before giving up") + <*> Env.var (fmap Just . Env.auto) "MAX_SHRINKS" (mE <> Env.help "Maximum number of shrinks of a failing test input") + <*> Env.var (fmap Just . Env.auto) "GOLDEN_START" (mE <> Env.help "Whether to write golden tests if they do not exist yet") + <*> Env.var (fmap Just . Env.auto) "GOLDEN_RESET" (mE <> Env.help "Whether to overwrite golden tests instead of having them fail") + <*> Env.var (fmap Just . Env.auto) "COLOUR" (mE <> Env.help "Whether to use coloured output") + <*> Env.var (fmap Just . Env.str) "FILTER" (mE <> Env.help "Filter to select which parts of the test tree to run") + <*> Env.var (fmap Just . Env.auto) "FAIL_FAST" (mE <> Env.help "Whether to stop executing upon the first test failure") + <*> Env.var (fmap Just . (Env.auto >=> parseIterations)) "ITERATIONS" (mE <> Env.help "How many iterations to use to look diagnose flakiness") + where + parseThreads :: Int -> Either e Threads + parseThreads 1 = Right Synchronous + parseThreads i = Right (Asynchronous i) + parseIterations :: Int -> Either e Iterations + parseIterations 0 = Right Continuous + parseIterations 1 = Right OneIteration + parseIterations i = Right (Iterations i) + mE = Env.def Nothing + +-- | Get the command-line flags +getFlags :: IO Flags +getFlags = customExecParser prefs_ flagsParser + +-- | The 'optparse-applicative' parsing preferences +prefs_ :: OptParse.ParserPrefs +prefs_ = + -- I like these preferences. Use what you like. + OptParse.defaultPrefs + { OptParse.prefShowHelpOnError = True, + OptParse.prefShowHelpOnEmpty = True + } + +-- | The @optparse-applicative@ parser for 'Flags' +flagsParser :: OptParse.ParserInfo Flags +flagsParser = + OptParse.info + (OptParse.helper <*> parseFlags) + (OptParse.fullDesc <> OptParse.footerDoc (Just $ OptParse.string footerStr)) + where + -- Show the variables from the environment that we parse and the config file format + footerStr = + unlines + [ Env.helpDoc environmentParser, + "", + "Configuration file format:", + T.unpack (YamlParse.prettyColourisedSchemaDoc @Configuration) + ] + +-- | The flags that are common across commands. +data Flags = Flags + { flagConfigFile :: !(Maybe FilePath), + flagSeed :: !(Maybe Int), + flagRandomiseExecutionOrder :: !(Maybe Bool), + flagThreads :: !(Maybe Threads), + flagMaxSuccess :: !(Maybe Int), + flagMaxSize :: !(Maybe Int), + flagMaxDiscard :: !(Maybe Int), + flagMaxShrinks :: !(Maybe Int), + flagGoldenStart :: !(Maybe Bool), + flagGoldenReset :: !(Maybe Bool), + flagColour :: !(Maybe Bool), + flagFilter :: !(Maybe Text), + flagFailFast :: !(Maybe Bool), + flagIterations :: !(Maybe Iterations) + } + deriving (Show, Eq, Generic) + +-- | The 'optparse-applicative' parser for the 'Flags'. +parseFlags :: OptParse.Parser Flags +parseFlags = + Flags + <$> optional + ( strOption + ( mconcat + [ long "config-file", + help "Path to an altenative config file", + metavar "FILEPATH" + ] + ) + ) + <*> optional + ( option + auto + ( mconcat + [ long "seed", + help "Seed for random generation of test cases" + ] + ) + ) + <*> optional + ( flag + True + False + ( mconcat + [ long "no-randomise-execution-order", + help "Randomise the execution order of the tests in the test suite" + ] + ) + ) + <*> optional + ( ( ( \case + 1 -> Synchronous + i -> Asynchronous i + ) + <$> option auto (mconcat [short 'j', long "jobs", help "How parallel to execute the tests"]) + ) + <|> flag ByCapabilities Synchronous (mconcat [long "synchronous", help "execute tests synchronously"]) + ) + <*> optional + ( option + auto + ( mconcat + [ long "max-success", + long "qc-max-success", + help "Number of quickcheck examples to run" + ] + ) + ) + <*> optional + ( option + auto + ( mconcat + [ long "max-size", + long "qc-max-size", + help "Maximum size parameter to pass to generators" + ] + ) + ) + <*> optional + ( option + auto + ( mconcat + [ long "max-discard", + long "qc-max-discard", + help "Maximum number of discarded tests per successful test before giving up" + ] + ) + ) + <*> optional + ( option + auto + ( mconcat + [ long "max-shrinks", + long "qc-max-shrinks", + help "Maximum number of shrinks of a failing test input" + ] + ) + ) + <*> optional + ( flag + True + False + ( mconcat + [ long "no-golden-start", + help "Whether to write golden tests if they do not exist yet" + ] + ) + ) + <*> optional + ( flag + False + True + ( mconcat + [ long "golden-reset", + help "Whether to overwrite golden tests instead of having them fail" + ] + ) + ) + <*> optional + ( flag' True (mconcat [long "colour", long "color", help "Always use colour in output"]) + <|> flag' False (mconcat [long "no-colour", long "no-color", help "Never use colour in output"]) + ) + <*> optional + ( strOption + ( mconcat + [ long "filter", + long "match", + help "Filter to select which parts of the test tree to run" + ] + ) + ) + <*> optional + ( switch + ( mconcat + [ long "fail-fast", + help "Whether to stop upon the first test failure" + ] + ) + ) + <*> optional + ( ( ( \case + 0 -> Continuous + 1 -> OneIteration + i -> Iterations i + ) + <$> option + auto + ( mconcat + [ long "iterations", + help "How many iterations to use to look diagnose flakiness" + ] + ) + ) + <|> flag + OneIteration + Continuous + ( mconcat + [ long "continuous", + help "Run the test suite over and over again until it fails, to diagnose flakiness" + ] + ) + ) diff --git a/src/Test/Syd/Output.hs b/src/Test/Syd/Output.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Output.hs @@ -0,0 +1,488 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Syd.Output where + +import Control.Monad.Reader +import Data.Algorithm.Diff +import Data.ByteString (ByteString) +import qualified Data.ByteString as SB +import qualified Data.ByteString.Char8 as SB8 +import Data.List +import Data.List.Split (splitWhen) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Stack +import Rainbow +import Rainbow.Types (Chunk (..)) +import Safe +import Test.QuickCheck.IO () +import Test.Syd.Run +import Test.Syd.SpecDef +import Test.Syd.SpecForest +import Text.Printf + +printOutputSpecForest :: Maybe Bool -> Timed ResultForest -> IO () +printOutputSpecForest mColour results = do + byteStringMaker <- case mColour of + Just False -> pure toByteStringsColors0 + Just True -> pure toByteStringsColors256 + Nothing -> liftIO byteStringMakerFromEnvironment + let bytestrings = outputSpecForestByteString byteStringMaker results + forM_ bytestrings $ \bs -> do + mapM_ SB.putStr bs + SB8.putStrLn "" + +outputSpecForestByteString :: (Chunk -> [ByteString] -> [ByteString]) -> Timed ResultForest -> [[ByteString]] +outputSpecForestByteString byteStringMaker results = map (chunksToByteStrings byteStringMaker) (outputResultReport results) + +outputResultReport :: Timed ResultForest -> [[Chunk]] +outputResultReport trf@(Timed rf _) = + concat + [ outputTestsHeader, + outputSpecForest 0 (resultForestWidth rf) rf, + [ [chunk ""], + [chunk ""] + ], + outputFailuresWithHeading rf, + [[chunk ""]], + outputStats (computeTestSuiteStats <$> trf), + [[chunk ""]] + ] + +outputFailuresHeader :: [[Chunk]] +outputFailuresHeader = outputHeader "Failures:" + +outputFailuresWithHeading :: ResultForest -> [[Chunk]] +outputFailuresWithHeading rf = + if any testFailed (flattenSpecForest rf) + then + concat + [ outputFailuresHeader, + outputFailures rf + ] + else [] + +outputStats :: Timed TestSuiteStats -> [[Chunk]] +outputStats (Timed TestSuiteStats {..} timing) = + let totalTimeSeconds :: Double + totalTimeSeconds = fromIntegral timing / 1_000_000_000 + in map (padding :) $ + concat + [ [ [ chunk "Passed: ", + fore green $ chunk (T.pack (show testSuiteStatSuccesses)) + ], + [ chunk "Failed: ", + ( if testSuiteStatFailures > 0 + then fore red + else fore green + ) + $ chunk (T.pack (show testSuiteStatFailures)) + ] + ], + [ [ chunk "Pending: ", + fore magenta $ chunk (T.pack (show testSuiteStatPending)) + ] + | testSuiteStatPending > 0 + ], + [ let longestTimeSeconds :: Double + longestTimeSeconds = fromIntegral longest / 1_000_000_000 + longestTimePercentage :: Double + longestTimePercentage = 100 * longestTimeSeconds / totalTimeSeconds + in concat + [ [ chunk "Longest test took", + fore yellow $ chunk $ T.pack (printf "%13.2f seconds" longestTimeSeconds) + ], + [ chunk $ T.pack (printf ", which is %.2f%% of total runtime" longestTimePercentage) + | longestTimePercentage > 50 + ] + ] + | longest <- maybeToList testSuiteStatLongestTime + ], + [ [ chunk "Test suite took ", + fore yellow $ chunk $ T.pack (printf "%13.2f seconds" totalTimeSeconds) + ] + ] + ] + +outputTestsHeader :: [[Chunk]] +outputTestsHeader = outputHeader "Tests:" + +outputHeader :: Text -> [[Chunk]] +outputHeader t = + [ [fore blue $ chunk t], + [chunk ""] + ] + +outputSpecForest :: Int -> Int -> ResultForest -> [[Chunk]] +outputSpecForest level treeWidth = concatMap (outputSpecTree level treeWidth) + +outputSpecTree :: Int -> Int -> ResultTree -> [[Chunk]] +outputSpecTree level treeWidth = \case + SpecifyNode t td -> outputSpecifyLines level treeWidth t td + PendingNode t mr -> outputPendingLines t mr + DescribeNode t sf -> outputDescribeLine t : map (padding :) (outputSpecForest (level + 1) treeWidth sf) + SubForestNode sf -> outputSpecForest level treeWidth sf + +outputDescribeLine :: Text -> [Chunk] +outputDescribeLine t = [fore yellow $ chunk t] + +outputSpecifyLines :: Int -> Int -> Text -> TDef (Timed TestRunResult) -> [[Chunk]] +outputSpecifyLines level treeWidth specifyText (TDef (Timed TestRunResult {..} executionTime) _) = + let t = fromIntegral executionTime / 1_000_000 :: Double -- milliseconds + executionTimeText = T.pack (printf "%10.2f ms" t) + withTimingColour = + if + | t < 10 -> fore green + | t < 100 -> fore yellow + | t < 1000 -> fore orange + | t < 10000 -> fore red + | otherwise -> fore darkRed + + withStatusColour = fore (statusColour testRunResultStatus) + pad = (chunk (T.pack (replicate paddingSize ' ')) :) + in filter + (not . null) + $ concat + [ [ [ withStatusColour $ chunk (statusCheckMark testRunResultStatus), + withStatusColour $ chunk specifyText, + spacingChunk level specifyText executionTimeText treeWidth, + withTimingColour $ chunk executionTimeText + ] + ], + [ pad + [chunk (T.pack (printf "passed for all of %d inputs" w))] + | testRunResultStatus == TestPassed, + w <- maybeToList testRunResultNumTests + ], + map pad $ labelsChunks testRunResultLabels, + map pad $ classesChunks testRunResultClasses, + map pad $ tablesChunks testRunResultTables, + [pad $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase] + ] + +labelsChunks :: Maybe (Map [String] Int) -> [[Chunk]] +labelsChunks Nothing = [] +labelsChunks (Just labels) + | M.size labels <= 1 = [] + | otherwise = + [chunk "labels"] : + map + ( pad + . ( \(ss, i) -> + [ chunk + ( T.pack + ( printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) (commaList (map show ss)) + ) + ) + ] + ) + ) + (M.toList labels) + where + pad = (chunk (T.pack (replicate paddingSize ' ')) :) + total = sum $ map snd $ M.toList labels + +classesChunks :: Maybe (Map String Int) -> [[Chunk]] +classesChunks Nothing = [] +classesChunks (Just classes) + | M.null classes = [] + | otherwise = + [chunk "classes"] : + map + ( pad + . ( \(s, i) -> + [ chunk + ( T.pack + ( printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s + ) + ) + ] + ) + ) + (M.toList classes) + where + pad = (chunk (T.pack (replicate paddingSize ' ')) :) + total = sum $ map snd $ M.toList classes + +tablesChunks :: Maybe (Map String (Map String Int)) -> [[Chunk]] +tablesChunks Nothing = [] +tablesChunks (Just tables) = concatMap (uncurry goTable) $ M.toList tables + where + goTable :: String -> Map String Int -> [[Chunk]] + goTable tableName percentages = + [chunk " "] : + [chunk (T.pack tableName)] : + map + ( pad + . ( \(s, i) -> + [ chunk + ( T.pack + ( printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s + ) + ) + ] + ) + ) + (M.toList percentages) + where + pad = (chunk (T.pack (replicate paddingSize ' ')) :) + total = sum $ map snd $ M.toList percentages + +outputPendingLines :: Text -> Maybe Text -> [[Chunk]] +outputPendingLines specifyText mReason = + filter + (not . null) + [ [fore magenta $ chunk specifyText], + case mReason of + Nothing -> [] + Just reason -> [padding, chunk reason] + ] + +outputFailureLabels :: Maybe (Map [String] Int) -> [[Chunk]] +outputFailureLabels Nothing = [] +outputFailureLabels (Just labels) + | labels == M.singleton [] 1 = [] + | otherwise = [["Labels: ", chunk (T.pack (commaList (map show (concat $ M.keys labels))))]] + +commaList :: [String] -> String +commaList [] = [] +commaList [s] = s +commaList (s1 : rest) = s1 ++ ", " ++ commaList rest + +outputFailureClasses :: Maybe (Map String Int) -> [[Chunk]] +outputFailureClasses Nothing = [] +outputFailureClasses (Just classes) + | M.null classes = [] + | otherwise = [["Class: ", chunk (T.pack (commaList (M.keys classes)))]] + +outputGoldenCase :: GoldenCase -> [Chunk] +outputGoldenCase = \case + GoldenNotFound -> [fore red $ chunk "Golden output not found"] + GoldenStarted -> [fore cyan $ chunk "Golden output created"] + GoldenReset -> [fore cyan $ chunk "Golden output reset"] + +-- The chunk for spacing between the description and the timing +-- +-- initial padding | checkmark | description | THIS CHUNK | execution time +spacingChunk :: Int -> Text -> Text -> Int -> Chunk +spacingChunk level descriptionText executionTimeText treeWidth = chunk $ T.pack $ replicate paddingWidth ' ' + where + paddingWidth = + let preferredMaxWidth = 80 + checkmarkWidth = 2 + minimumSpacing = 1 + actualDescriptionWidth = T.length descriptionText + actualTimingWidth = T.length executionTimeText + totalNecessaryWidth = treeWidth + checkmarkWidth + minimumSpacing + actualTimingWidth -- All timings are the same width + actualMaxWidth = max totalNecessaryWidth preferredMaxWidth + in actualMaxWidth - paddingSize * level - actualTimingWidth - actualDescriptionWidth + +testFailed :: (a, TDef (Timed TestRunResult)) -> Bool +testFailed = (== TestFailed) . testRunResultStatus . timedValue . testDefVal . snd + +outputFailures :: ResultForest -> [[Chunk]] +outputFailures rf = + let failures = filter testFailed $ flattenSpecForest rf + nbDigitsInFailureCount :: Int + nbDigitsInFailureCount = floor (logBase 10 (genericLength failures) :: Double) + padFailureDetails = (chunk (T.pack (replicate (nbDigitsInFailureCount + 4) ' ')) :) + in map (padding :) $ + filter (not . null) $ + concat $ + indexed failures $ \w (ts, TDef (Timed TestRunResult {..} _) cs) -> + concat + [ [ [ fore cyan $ + chunk $ + T.pack $ + replicate 2 ' ' + ++ case headMay $ getCallStack cs of + Nothing -> "Unknown location" + Just (_, SrcLoc {..}) -> + concat + [ srcLocFile, + ":", + show srcLocStartLine + ] + ], + map + (fore (statusColour testRunResultStatus)) + [ chunk $ statusCheckMark testRunResultStatus, + chunk $ T.pack (printf ("%" ++ show nbDigitsInFailureCount ++ "d ") w), + chunk $ T.intercalate "." ts + ] + ], + map (padFailureDetails . (: []) . chunk . T.pack) $ + case (testRunResultNumTests, testRunResultNumShrinks) of + (Nothing, _) -> [] + (Just numTests, Nothing) -> [printf "Failled after %d tests" numTests] + (Just numTests, Just 0) -> [printf "Failled after %d tests" numTests] + (Just numTests, Just numShrinks) -> [printf "Failed after %d tests and %d shrinks" numTests numShrinks], + map (padFailureDetails . (\c -> [chunk "Generated: ", c]) . fore yellow . chunk . T.pack) testRunResultFailingInputs, + map padFailureDetails $ outputFailureLabels testRunResultLabels, + map padFailureDetails $ outputFailureClasses testRunResultClasses, + map padFailureDetails $ + case testRunResultException of + Nothing -> [] + Just (Left s) -> stringChunks s + Just (Right a) -> outputAssertion a, + [padFailureDetails $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase], + concat [map padFailureDetails $ stringChunks ei | ei <- maybeToList testRunResultExtraInfo], + [[chunk ""]] + ] + +outputAssertion :: Assertion -> [[Chunk]] +outputAssertion = \case + NotEqualButShouldHaveBeenEqual actual expected -> outputEqualityAssertionFailed actual expected + EqualButShouldNotHaveBeenEqual actual notExpected -> outputNotEqualAssertionFailed actual notExpected + PredicateFailedButShouldHaveSucceeded actual mName -> outputPredicateSuccessAssertionFailed actual mName + PredicateSucceededButShouldHaveFailed actual mName -> outputPredicateFailAssertionFailed actual mName + ExpectationFailed s -> stringChunks s + Context a' context -> outputAssertion a' ++ stringChunks context + +outputEqualityAssertionFailed :: String -> String -> [[Chunk]] +outputEqualityAssertionFailed actual expected = + let diff = getDiff actual expected -- TODO use 'getGroupedDiff' instead, but then we need to fix the 'splitWhen' below + splitLines = splitWhen ((== "\n") . _yarn) + chunksLinesWithHeader :: Chunk -> [[Chunk]] -> [[Chunk]] + chunksLinesWithHeader header = \case + [cs] -> [header : cs] + cs -> [header] : cs + actualChunks :: [[Chunk]] + actualChunks = chunksLinesWithHeader (fore blue "Actual: ") $ + splitLines $ + flip mapMaybe diff $ \case + First a -> Just $ fore red $ chunk (T.singleton a) + Second _ -> Nothing + Both a _ -> Just $ chunk (T.singleton a) + expectedChunks :: [[Chunk]] + expectedChunks = chunksLinesWithHeader (fore blue "Expected: ") $ + splitLines $ + flip mapMaybe diff $ \case + First _ -> Nothing + Second a -> Just $ fore green $ chunk (T.singleton a) + Both a _ -> Just $ chunk (T.singleton a) + inlineDiffChunks :: [[Chunk]] + inlineDiffChunks = + if length (lines actual) == 1 && length (lines expected) == 1 + then [] + else chunksLinesWithHeader (fore blue "Inline diff: ") $ + splitLines $ + flip map diff $ \case + First a -> fore red $ chunk (T.singleton a) + Second a -> fore green $ chunk (T.singleton a) + Both a _ -> chunk (T.singleton a) + in concat + [ [[chunk "Expected these values to be equal:"]], + actualChunks, + expectedChunks, + inlineDiffChunks + ] + +outputNotEqualAssertionFailed :: String -> String -> [[Chunk]] +outputNotEqualAssertionFailed actual notExpected = + if actual == notExpected -- String equality + then + [ [chunk "Did not expect equality of the values but both were:"], + [chunk (T.pack actual)] + ] + else + [ [chunk "These two values were considered equal but should not have been equal:"], + [fore blue "Actual : ", chunk (T.pack actual)], + [fore blue "Not Expected: ", chunk (T.pack notExpected)] + ] + +outputPredicateSuccessAssertionFailed :: String -> Maybe String -> [[Chunk]] +outputPredicateSuccessAssertionFailed actual mName = + concat + [ [ [chunk "Predicate failed, but should have succeeded, on this value:"], + [chunk (T.pack actual)] + ], + concat $ [[chunk "Predicate: "]] : [stringChunks name | name <- maybeToList mName] + ] + +outputPredicateFailAssertionFailed :: String -> Maybe String -> [[Chunk]] +outputPredicateFailAssertionFailed actual mName = + concat + [ [ [chunk "Predicate succeeded, but should have failed, on this value:"], + [chunk (T.pack actual)] + ], + concat $ [[chunk "Predicate: "]] : [stringChunks name | name <- maybeToList mName] + ] + +mContextChunks :: Maybe String -> [[Chunk]] +mContextChunks = maybe [] stringChunks + +stringChunks :: String -> [[Chunk]] +stringChunks s = + let ls = lines s + in map ((: []) . chunk . T.pack) ls + +indexed :: [a] -> (Word -> a -> b) -> [b] +indexed ls func = zipWith func [1 ..] ls + +outputFailure :: TestRunResult -> Maybe [[Chunk]] +outputFailure TestRunResult {..} = case testRunResultStatus of + TestPassed -> Nothing + TestFailed -> Just [[chunk "Failure"]] + +statusColour :: TestStatus -> Radiant +statusColour = \case + TestPassed -> green + TestFailed -> red + +statusCheckMark :: TestStatus -> Text +statusCheckMark = \case + TestPassed -> "\10003 " + TestFailed -> "\10007 " + +resultForestWidth :: SpecForest a -> Int +resultForestWidth = goF 0 + where + goF :: Int -> SpecForest a -> Int + goF level = maximum . map (goT level) + goT :: Int -> SpecTree a -> Int + goT level = \case + SpecifyNode t _ -> T.length t + level * paddingSize + PendingNode t _ -> T.length t + level * paddingSize + DescribeNode _ sdf -> goF (succ level) sdf + SubForestNode sdf -> goF level sdf + +specForestWidth :: SpecDefForest a b c -> Int +specForestWidth = goF 0 + where + goF :: Int -> SpecDefForest a b c -> Int + goF level = \case + [] -> 0 + ts -> maximum $ map (goT level) ts + goT :: Int -> SpecDefTree a b c -> Int + goT level = \case + DefSpecifyNode t _ _ -> T.length t + level * paddingSize + DefPendingNode t _ -> T.length t + level * paddingSize + DefDescribeNode _ sdf -> goF (succ level) sdf + DefWrapNode _ sdf -> goF level sdf + DefBeforeAllNode _ sdf -> goF level sdf + DefAroundAllNode _ sdf -> goF level sdf + DefAroundAllWithNode _ sdf -> goF level sdf + DefAfterAllNode _ sdf -> goF level sdf + DefParallelismNode _ sdf -> goF level sdf + DefRandomisationNode _ sdf -> goF level sdf + +padding :: Chunk +padding = chunk $ T.replicate paddingSize " " + +paddingSize :: Int +paddingSize = 2 + +orange :: Radiant +orange = color256 166 + +darkRed :: Radiant +darkRed = color256 160 diff --git a/src/Test/Syd/Run.hs b/src/Test/Syd/Run.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Run.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module defines the 'IsTest' class and the different instances for it. +module Test.Syd.Run where + +import Control.Concurrent +import Control.Exception +import Control.Monad.IO.Class +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as M +import Data.Typeable +import Data.Word +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Generics (Generic) +import Test.QuickCheck +import Test.QuickCheck.Gen +import Test.QuickCheck.IO () +import Test.QuickCheck.Property hiding (Result (..)) +import qualified Test.QuickCheck.Property as QCP +import Test.QuickCheck.Random +import Text.Printf + +class IsTest e where + type Arg1 e + type Arg2 e + runTest :: + e -> + TestRunSettings -> + ((Arg1 e -> Arg2 e -> IO ()) -> IO ()) -> + IO TestRunResult + +instance IsTest Bool where + type Arg1 Bool = () -- The argument from 'aroundAll' + type Arg2 Bool = () -- The argument from 'around' + runTest func = runTest (\() () -> func) + +instance IsTest (arg -> Bool) where + type Arg1 (arg -> Bool) = () + type Arg2 (arg -> Bool) = arg + runTest func = runTest (\() arg -> func arg) + +instance IsTest (outerArgs -> innerArg -> Bool) where + type Arg1 (outerArgs -> innerArg -> Bool) = outerArgs + type Arg2 (outerArgs -> innerArg -> Bool) = innerArg + runTest = runPureTestWithArg + +runPureTestWithArg :: + (outerArgs -> innerArg -> Bool) -> + TestRunSettings -> + ((outerArgs -> innerArg -> IO ()) -> IO ()) -> + IO TestRunResult +runPureTestWithArg computeBool TestRunSettings {..} wrapper = do + let testRunResultNumTests = Nothing + resultBool <- + applyWrapper2 wrapper $ + \outerArgs innerArg -> evaluate (computeBool outerArgs innerArg) + let (testRunResultStatus, testRunResultException) = case resultBool of + Left ex -> (TestFailed, Just ex) + Right bool -> (if bool then TestPassed else TestFailed, Nothing) + let testRunResultNumShrinks = Nothing + let testRunResultGoldenCase = Nothing + let testRunResultFailingInputs = [] + let testRunResultExtraInfo = Nothing + let testRunResultLabels = Nothing + let testRunResultClasses = Nothing + let testRunResultTables = Nothing + pure TestRunResult {..} + +applyWrapper2 :: + forall r outerArgs innerArg. + ((outerArgs -> innerArg -> IO ()) -> IO ()) -> + (outerArgs -> innerArg -> IO r) -> + IO (Either (Either String Assertion) r) +applyWrapper2 wrapper func = do + var <- liftIO newEmptyMVar + r <- (`catches` exceptionHandlers) $ + fmap Right $ + wrapper $ \outerArgs innerArg -> do + res <- (Right <$> (func outerArgs innerArg >>= evaluate)) `catches` exceptionHandlers + liftIO $ putMVar var res + case r of + Right () -> liftIO $ readMVar var + Left e -> pure (Left e :: Either (Either String Assertion) r) + +instance IsTest (IO ()) where + type Arg1 (IO ()) = () + type Arg2 (IO ()) = () + runTest func = runTest (\() () -> func) + +instance IsTest (arg -> IO ()) where + type Arg1 (arg -> IO ()) = () + type Arg2 (arg -> IO ()) = arg + runTest func = runTest (\() -> func) + +instance IsTest (outerArgs -> innerArg -> IO ()) where + type Arg1 (outerArgs -> innerArg -> IO ()) = outerArgs + type Arg2 (outerArgs -> innerArg -> IO ()) = innerArg + runTest = runIOTestWithArg + +runIOTestWithArg :: + (outerArgs -> innerArg -> IO ()) -> + TestRunSettings -> + ((outerArgs -> innerArg -> IO ()) -> IO ()) -> + IO TestRunResult +runIOTestWithArg func TestRunSettings {..} wrapper = do + let testRunResultNumTests = Nothing + result <- liftIO $ + applyWrapper2 wrapper $ + \outerArgs innerArg -> + func outerArgs innerArg >>= evaluate + let (testRunResultStatus, testRunResultException) = case result of + Left ex -> (TestFailed, Just ex) + Right () -> (TestPassed, Nothing) + let testRunResultNumShrinks = Nothing + let testRunResultGoldenCase = Nothing + let testRunResultFailingInputs = [] + let testRunResultExtraInfo = Nothing + let testRunResultLabels = Nothing + let testRunResultClasses = Nothing + let testRunResultTables = Nothing + pure TestRunResult {..} + +instance IsTest Property where + type Arg1 Property = () + type Arg2 Property = () + runTest func = runTest (\() () -> func) + +instance IsTest (arg -> Property) where + type Arg1 (arg -> Property) = () + type Arg2 (arg -> Property) = arg + runTest func = runTest (\() -> func) + +instance IsTest (outerArgs -> innerArg -> Property) where + type Arg1 (outerArgs -> innerArg -> Property) = outerArgs + type Arg2 (outerArgs -> innerArg -> Property) = innerArg + runTest = runPropertyTestWithArg + +runPropertyTestWithArg :: + (outerArgs -> innerArg -> Property) -> + TestRunSettings -> + ((outerArgs -> innerArg -> IO ()) -> IO ()) -> + IO TestRunResult +runPropertyTestWithArg p TestRunSettings {..} wrapper = do + let qcargs = + stdArgs + { replay = Just (mkQCGen testRunSettingSeed, 0), + chatty = False, + maxSuccess = testRunSettingMaxSuccess, + maxDiscardRatio = testRunSettingMaxDiscardRatio, + maxSize = testRunSettingMaxSize, + maxShrinks = testRunSettingMaxShrinks + } + qcr <- quickCheckWithResult qcargs (aroundProperty wrapper p) + let testRunResultGoldenCase = Nothing + let testRunResultNumTests = Just $ fromIntegral $ numTests qcr + case qcr of + Success {} -> do + let testRunResultStatus = TestPassed + let testRunResultException = Nothing + let testRunResultNumShrinks = Nothing + let testRunResultFailingInputs = [] + let testRunResultExtraInfo = Nothing + let testRunResultLabels = Just $ labels qcr + let testRunResultClasses = Just $ classes qcr + let testRunResultTables = Just $ tables qcr + pure TestRunResult {..} + GaveUp {} -> do + let testRunResultStatus = TestFailed + let testRunResultException = Nothing + let testRunResultNumShrinks = Nothing + let testRunResultFailingInputs = [] + let testRunResultExtraInfo = Just $ printf "Gave up, %d discarded tests" (numDiscarded qcr) + let testRunResultLabels = Just $ labels qcr + let testRunResultClasses = Just $ classes qcr + let testRunResultTables = Just $ tables qcr + pure TestRunResult {..} + Failure {} -> do + let testRunResultStatus = TestFailed + let testRunResultException = do + se <- theException qcr + pure $ case fromException se of + Just a -> Right a + Nothing -> Left $ displayException se + let testRunResultNumShrinks = Just $ fromIntegral $ numShrinks qcr + let testRunResultFailingInputs = failingTestCase qcr + let testRunResultExtraInfo = Nothing + let testRunResultLabels = Just $ M.singleton (failingLabels qcr) 1 + let testRunResultClasses = Just $ M.fromSet (const 1) (failingClasses qcr) + let testRunResultTables = Nothing + pure TestRunResult {..} + NoExpectedFailure {} -> do + let testRunResultStatus = TestFailed + let testRunResultException = Nothing + let testRunResultNumShrinks = Nothing + let testRunResultFailingInputs = [] + let testRunResultLabels = Just $ labels qcr + let testRunResultClasses = Just $ classes qcr + let testRunResultTables = Just $ tables qcr + let testRunResultExtraInfo = Just $ printf "Expected the property to fail but it didn't." + pure TestRunResult {..} + +aroundProperty :: ((a -> b -> IO ()) -> IO ()) -> (a -> b -> Property) -> Property +aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a b -> (unGen . unProperty $ p a b) r n + +aroundProp :: ((a -> b -> IO ()) -> IO ()) -> (a -> b -> Prop) -> Prop +aroundProp action p = MkProp $ aroundRose action (\a b -> unProp $ p a b) + +aroundRose :: ((a -> b -> IO ()) -> IO ()) -> (a -> b -> Rose QCP.Result) -> Rose QCP.Result +aroundRose action r = ioRose $ do + ref <- newIORef (return QCP.succeeded) + action $ \a b -> reduceRose (r a b) >>= writeIORef ref + readIORef ref + +data GoldenTest a = GoldenTest + { goldenTestRead :: IO (Maybe a), + goldenTestProduce :: IO a, + goldenTestWrite :: a -> IO (), + goldenTestCompare :: a -> a -> Maybe Assertion + } + +instance IsTest (GoldenTest a) where + type Arg1 (GoldenTest a) = () + type Arg2 (GoldenTest a) = () + runTest gt = runTest (\() () -> gt) + +instance IsTest (arg -> GoldenTest a) where + type Arg1 (arg -> GoldenTest a) = () + type Arg2 (arg -> GoldenTest a) = arg + runTest gt = runTest (\() -> gt) + +instance IsTest (outerArgs -> innerArg -> GoldenTest a) where + type Arg1 (outerArgs -> innerArg -> GoldenTest a) = outerArgs + type Arg2 (outerArgs -> innerArg -> GoldenTest a) = innerArg + runTest func = runTest (\outerArgs innerArg -> pure (func outerArgs innerArg) :: IO (GoldenTest a)) + +instance IsTest (IO (GoldenTest a)) where + type Arg1 (IO (GoldenTest a)) = () + type Arg2 (IO (GoldenTest a)) = () + runTest func = runTest (\() () -> func) + +instance IsTest (arg -> IO (GoldenTest a)) where + type Arg1 (arg -> IO (GoldenTest a)) = () + type Arg2 (arg -> IO (GoldenTest a)) = arg + runTest func = runTest (\() -> func) + +instance IsTest (outerArgs -> innerArg -> IO (GoldenTest a)) where + type Arg1 (outerArgs -> innerArg -> IO (GoldenTest a)) = outerArgs + type Arg2 (outerArgs -> innerArg -> IO (GoldenTest a)) = innerArg + runTest = runGoldenTestWithArg + +runGoldenTestWithArg :: + (outerArgs -> innerArg -> IO (GoldenTest a)) -> + TestRunSettings -> + ((outerArgs -> innerArg -> IO ()) -> IO ()) -> + IO TestRunResult +runGoldenTestWithArg createGolden TestRunSettings {..} wrapper = do + errOrTrip <- applyWrapper2 wrapper $ \outerArgs innerArgs -> do + GoldenTest {..} <- createGolden outerArgs innerArgs + mGolden <- goldenTestRead + case mGolden of + Nothing -> + if testRunSettingGoldenStart + then do + actual <- goldenTestProduce + goldenTestWrite actual + pure (TestPassed, Just GoldenStarted, Nothing) + else pure (TestFailed, Just GoldenNotFound, Nothing) + Just golden -> do + actual <- goldenTestProduce + case goldenTestCompare actual golden of + Nothing -> pure (TestPassed, Nothing, Nothing) + Just assertion -> + if testRunSettingGoldenReset + then do + goldenTestWrite actual + pure (TestPassed, Just GoldenReset, Nothing) + else pure (TestFailed, Nothing, Just $ Right assertion) + let (testRunResultStatus, testRunResultGoldenCase, testRunResultException) = case errOrTrip of + Left e -> (TestFailed, Nothing, Just e) + Right trip -> trip + let testRunResultNumTests = Nothing + let testRunResultNumShrinks = Nothing + let testRunResultFailingInputs = [] + let testRunResultExtraInfo = Nothing + let testRunResultLabels = Nothing + let testRunResultClasses = Nothing + let testRunResultTables = Nothing + pure TestRunResult {..} + +exceptionHandlers :: [Handler (Either (Either String Assertion) a)] +exceptionHandlers = + [ -- Re-throw AsyncException, otherwise execution will not terminate on SIGINT (ctrl-c). + Handler (\e -> throw (e :: AsyncException)), + -- Catch assertions first because we know what to do with them. + Handler $ \(a :: Assertion) -> pure (Left $ Right a), + -- Catch all the rest as a string + Handler (\e -> return $ Left (Left (displayException (e :: SomeException)))) + ] + +type Test = IO () + +data TestRunSettings = TestRunSettings + { testRunSettingSeed :: Int, + testRunSettingMaxSuccess :: Int, + testRunSettingMaxSize :: Int, + testRunSettingMaxDiscardRatio :: Int, + testRunSettingMaxShrinks :: Int, + testRunSettingGoldenStart :: Bool, + testRunSettingGoldenReset :: Bool + } + deriving (Show, Generic) + +defaultTestRunSettings :: TestRunSettings +defaultTestRunSettings = + TestRunSettings + { testRunSettingSeed = 42, -- This is set by default because we want reproducability by default. + testRunSettingMaxSuccess = maxSuccess stdArgs, + testRunSettingMaxSize = maxSize stdArgs, + testRunSettingMaxDiscardRatio = maxDiscardRatio stdArgs, + testRunSettingMaxShrinks = 100, -- This is different from what quickcheck does so that test suites are more likely to finish + testRunSettingGoldenStart = True, + testRunSettingGoldenReset = False + } + +data TestRunResult = TestRunResult + { testRunResultStatus :: !TestStatus, + testRunResultException :: !(Maybe (Either String Assertion)), + testRunResultNumTests :: !(Maybe Word), + testRunResultNumShrinks :: !(Maybe Word), + testRunResultFailingInputs :: [String], + testRunResultLabels :: !(Maybe (Map [String] Int)), + testRunResultClasses :: !(Maybe (Map String Int)), + testRunResultTables :: !(Maybe (Map String (Map String Int))), + testRunResultGoldenCase :: !(Maybe GoldenCase), + testRunResultExtraInfo :: !(Maybe String) + } + deriving (Show, Eq, Generic) + +data TestStatus = TestPassed | TestFailed + deriving (Show, Eq, Generic) + +data Assertion + = NotEqualButShouldHaveBeenEqual String String + | EqualButShouldNotHaveBeenEqual String String + | PredicateSucceededButShouldHaveFailed + String -- Value + (Maybe String) -- Name of the predicate + | PredicateFailedButShouldHaveSucceeded + String -- Value + (Maybe String) -- Name of the predicate + | ExpectationFailed String + | Context Assertion String + deriving (Show, Eq, Typeable, Generic) + +instance Exception Assertion + +data GoldenCase + = GoldenNotFound + | GoldenStarted + | GoldenReset + deriving (Show, Eq, Typeable, Generic) + +-- | Time an action and return the result as well as how long it took in seconds. +-- +-- This function does not use the 'timeit' package because that package uses CPU time instead of system time. +-- That means that any waiting, like with 'threadDelay' would not be counted. +-- +-- Note that this does not evaluate the result, on purpose. +timeItT :: MonadIO m => m a -> m (Timed a) +timeItT func = do + begin <- liftIO getMonotonicTimeNSec + r <- func + end <- liftIO getMonotonicTimeNSec + pure $ Timed r (end - begin) + +data Timed a = Timed + { timedValue :: !a, + -- | In nanoseconds + timedTime :: !Word64 + } + deriving (Show, Eq, Generic, Functor) diff --git a/src/Test/Syd/Runner.hs b/src/Test/Syd/Runner.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Runner.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module defines how to run a test suite +module Test.Syd.Runner + ( module Test.Syd.Runner, + module Test.Syd.Runner.Asynchronous, + module Test.Syd.Runner.Synchronous, + ) +where + +import Control.Concurrent (getNumCapabilities) +import System.Environment +import System.Mem (performGC) +import Test.Syd.Def +import Test.Syd.OptParse +import Test.Syd.Output +import Test.Syd.Run +import Test.Syd.Runner.Asynchronous +import Test.Syd.Runner.Synchronous +import Test.Syd.SpecDef +import Text.Printf + +sydTestResult :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest) +sydTestResult sets spec = do + let totalIterations = case settingIterations sets of + OneIteration -> Just 1 + Iterations i -> Just i + Continuous -> Nothing + case totalIterations of + Just 1 -> sydTestOnce sets spec + _ -> sydTestIterations totalIterations sets spec + +sydTestOnce :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest) +sydTestOnce sets spec = do + specForest <- execTestDefM sets spec + withArgs [] $ case settingThreads sets of + Synchronous -> runSpecForestInterleavedWithOutputSynchronously (settingColour sets) (settingFailFast sets) specForest + ByCapabilities -> do + i <- getNumCapabilities + runSpecForestInterleavedWithOutputAsynchronously (settingColour sets) (settingFailFast sets) i specForest + Asynchronous i -> + runSpecForestInterleavedWithOutputAsynchronously (settingColour sets) (settingFailFast sets) i specForest + +sydTestIterations :: Maybe Int -> Settings -> TestDefM '[] () r -> IO (Timed ResultForest) +sydTestIterations totalIterations sets spec = + withArgs [] $ do + nbCapabilities <- getNumCapabilities + + let runOnce sets_ = do + specForest <- execTestDefM sets_ spec + r <- timeItT $ case settingThreads sets_ of + Synchronous -> runSpecForestSynchronously (settingFailFast sets_) specForest + ByCapabilities -> runSpecForestAsynchronously (settingFailFast sets_) nbCapabilities specForest + Asynchronous i -> runSpecForestAsynchronously (settingFailFast sets_) i specForest + performGC -- Just to be sure that nothing dangerous is lurking around in memory anywhere + pure r + + let go iteration = do + let newSeed = settingSeed sets + iteration + putStrLn $ printf "Running iteration: %4d with seed %4d" iteration newSeed + rf <- runOnce $ sets {settingSeed = newSeed} + if shouldExitFail (timedValue rf) + then pure rf + else case totalIterations of + Nothing -> go $ succ iteration + Just i + | iteration >= i -> pure rf + | otherwise -> go $ succ iteration + + rf <- go 0 + printOutputSpecForest (settingColour sets) rf + pure rf diff --git a/src/Test/Syd/Runner/Asynchronous.hs b/src/Test/Syd/Runner/Asynchronous.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Runner/Asynchronous.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module defines how to run a test suite +module Test.Syd.Runner.Asynchronous where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception +import Control.Monad.Reader +import qualified Data.ByteString as SB +import qualified Data.ByteString.Char8 as SB8 +import Data.IORef +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Text as T +import Rainbow +import Test.QuickCheck.IO () +import Test.Syd.HList +import Test.Syd.Output +import Test.Syd.Run +import Test.Syd.SpecDef +import Test.Syd.SpecForest + +runSpecForestAsynchronously :: Bool -> Int -> TestForest '[] () -> IO ResultForest +runSpecForestAsynchronously failFast nbThreads testForest = do + handleForest <- makeHandleForest testForest + failFastVar <- newEmptyMVar + let runRunner = runner failFast nbThreads failFastVar handleForest + runPrinter = liftIO $ waiter failFastVar handleForest + ((), resultForest) <- concurrently runRunner runPrinter + pure resultForest + +runSpecForestInterleavedWithOutputAsynchronously :: Maybe Bool -> Bool -> Int -> TestForest '[] () -> IO (Timed ResultForest) +runSpecForestInterleavedWithOutputAsynchronously mColour failFast nbThreads testForest = do + handleForest <- makeHandleForest testForest + failFastVar <- newEmptyMVar + let runRunner = runner failFast nbThreads failFastVar handleForest + runPrinter = liftIO $ printer mColour failFastVar handleForest + ((), resultForest) <- concurrently runRunner runPrinter + pure resultForest + +type HandleForest a b = SpecDefForest a b (MVar (Timed TestRunResult)) + +type HandleTree a b = SpecDefTree a b (MVar (Timed TestRunResult)) + +makeHandleForest :: TestForest a b -> IO (HandleForest a b) +makeHandleForest = traverse $ + traverse $ \() -> + newEmptyMVar + +runner :: Bool -> Int -> MVar () -> HandleForest '[] () -> IO () +runner failFast nbThreads failFastVar handleForest = do + sem <- liftIO $ newQSemN nbThreads + jobs <- newIORef (S.empty :: Set (Async ())) + -- This is used to make sure that the 'after' part of the resources actually happens after the tests are done, not just when they are started. + let waitForCurrentlyRunning :: IO () + waitForCurrentlyRunning = do + as <- readIORef jobs + mapM_ wait as + writeIORef jobs S.empty + let goForest :: Parallelism -> HList a -> HandleForest a () -> IO () + goForest p a = mapM_ (goTree p a) + goTree :: Parallelism -> HList a -> HandleTree a () -> IO () + goTree p a = \case + DefSpecifyNode _ td var -> do + mDone <- tryReadMVar failFastVar + case mDone of + Nothing -> do + let runNow = timeItT $ testDefVal td (\f -> f a ()) + -- Wait before spawning a thread so that we don't spawn too many threads + let quantity = case p of + -- When the test wants to be executed sequentially, we take n locks because we must make sure that + -- 1. no more other tests are still running. + -- 2. no other tests are started during execution. + Sequential -> nbThreads + Parallel -> 1 + liftIO $ waitQSemN sem quantity + let job :: IO () + job = do + result <- runNow + putMVar var result + when (failFast && testRunResultStatus (timedValue result) == TestFailed) $ do + putMVar failFastVar () + as <- readIORef jobs + mapM_ cancel as + liftIO $ signalQSemN sem quantity + jobAsync <- async job + modifyIORef jobs (S.insert jobAsync) + link jobAsync + Just () -> pure () + DefPendingNode _ _ -> pure () + DefDescribeNode _ sdf -> goForest p a sdf + DefWrapNode func sdf -> func (goForest p a sdf >> waitForCurrentlyRunning) + DefBeforeAllNode func sdf -> do + b <- func + goForest p (HCons b a) sdf + DefAroundAllNode func sdf -> + func (\b -> goForest p (HCons b a) sdf >> waitForCurrentlyRunning) + DefAroundAllWithNode func sdf -> + let HCons x _ = a + in func (\b -> goForest p (HCons b a) sdf >> waitForCurrentlyRunning) x + DefAfterAllNode func sdf -> goForest p a sdf `finally` (waitForCurrentlyRunning >> func a) + DefParallelismNode p' sdf -> goForest p' a sdf + DefRandomisationNode _ sdf -> goForest p a sdf + goForest Parallel HNil handleForest + +printer :: Maybe Bool -> MVar () -> HandleForest '[] () -> IO (Timed ResultForest) +printer mColour failFastVar handleForest = do + byteStringMaker <- case mColour of + Just False -> pure toByteStringsColors0 + Just True -> pure toByteStringsColors256 + Nothing -> liftIO byteStringMakerFromEnvironment + let outputLine :: [Chunk] -> IO () + outputLine lineChunks = do + let bss = chunksToByteStrings byteStringMaker lineChunks + mapM_ SB.putStr bss + SB8.putStrLn "" + treeWidth :: Int + treeWidth = specForestWidth handleForest + + let pad :: Int -> [Chunk] -> [Chunk] + pad level = (chunk (T.pack (replicate (paddingSize * level) ' ')) :) + + let goForest :: Int -> HandleForest a b -> IO (Maybe ResultForest) + goForest level hts = do + rts <- catMaybes <$> mapM (goTree level) hts + pure $ if null rts then Nothing else Just rts + + goTree :: Int -> HandleTree a b -> IO (Maybe ResultTree) + goTree level = \case + DefSpecifyNode t td var -> do + failFastOrResult <- race (readMVar failFastVar) (takeMVar var) + case failFastOrResult of + Left () -> pure Nothing + Right result -> do + let td' = td {testDefVal = result} + mapM_ (outputLine . pad level) $ outputSpecifyLines level treeWidth t td' + pure $ Just $ SpecifyNode t td' + DefPendingNode t mr -> do + mapM_ (outputLine . pad level) $ outputPendingLines t mr + pure $ Just $ PendingNode t mr + DefDescribeNode t sf -> do + mDone <- tryReadMVar failFastVar + case mDone of + Nothing -> do + outputLine $ pad level $ outputDescribeLine t + fmap (DescribeNode t) <$> goForest (succ level) sf + Just () -> pure Nothing + DefWrapNode _ sdf -> fmap SubForestNode <$> goForest level sdf + DefBeforeAllNode _ sdf -> fmap SubForestNode <$> goForest level sdf + DefAroundAllNode _ sdf -> fmap SubForestNode <$> goForest level sdf + DefAroundAllWithNode _ sdf -> fmap SubForestNode <$> goForest level sdf + DefAfterAllNode _ sdf -> fmap SubForestNode <$> goForest level sdf + DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest level sdf + DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest level sdf + mapM_ outputLine outputTestsHeader + resultForest <- timeItT $ fromMaybe [] <$> goForest 0 handleForest + outputLine [chunk " "] + mapM_ outputLine $ outputFailuresWithHeading (timedValue resultForest) + outputLine [chunk " "] + mapM_ outputLine $ outputStats (computeTestSuiteStats <$> resultForest) + outputLine [chunk " "] + pure resultForest + +waiter :: MVar () -> HandleForest '[] () -> IO ResultForest +waiter failFastVar handleForest = do + let goForest :: Int -> HandleForest a b -> IO (Maybe ResultForest) + goForest level hts = do + rts <- catMaybes <$> mapM (goTree level) hts + pure $ if null rts then Nothing else Just rts + + goTree :: Int -> HandleTree a b -> IO (Maybe ResultTree) + goTree level = \case + DefSpecifyNode t td var -> do + failFastOrResult <- race (readMVar failFastVar) (takeMVar var) + case failFastOrResult of + Left () -> pure Nothing + Right result -> do + let td' = td {testDefVal = result} + pure $ Just $ SpecifyNode t td' + DefPendingNode t mr -> pure $ Just $ PendingNode t mr + DefDescribeNode t sf -> do + fmap (DescribeNode t) <$> goForest (succ level) sf + DefWrapNode _ sdf -> fmap SubForestNode <$> goForest level sdf + DefBeforeAllNode _ sdf -> fmap SubForestNode <$> goForest level sdf + DefAroundAllNode _ sdf -> fmap SubForestNode <$> goForest level sdf + DefAroundAllWithNode _ sdf -> fmap SubForestNode <$> goForest level sdf + DefAfterAllNode _ sdf -> fmap SubForestNode <$> goForest level sdf + DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest level sdf + DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest level sdf + fromMaybe [] <$> goForest 0 handleForest diff --git a/src/Test/Syd/Runner/Synchronous.hs b/src/Test/Syd/Runner/Synchronous.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Runner/Synchronous.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module defines how to run a test suite +module Test.Syd.Runner.Synchronous where + +import Control.Exception +import Control.Monad.IO.Class +import qualified Data.ByteString as SB +import qualified Data.ByteString.Char8 as SB8 +import qualified Data.Text as T +import Rainbow +import Test.Syd.HList +import Test.Syd.Output +import Test.Syd.Run +import Test.Syd.Runner.Wrappers +import Test.Syd.SpecDef +import Test.Syd.SpecForest + +runSpecForestSynchronously :: Bool -> TestForest '[] () -> IO ResultForest +runSpecForestSynchronously failFast = fmap extractNext . goForest HNil + where + goForest :: HList a -> TestForest a () -> IO (Next ResultForest) + goForest _ [] = pure (Continue []) + goForest l (tt : rest) = do + nrt <- goTree l tt + case nrt of + Continue rt -> do + nf <- goForest l rest + pure $ (rt :) <$> nf + Stop rt -> pure $ Stop [rt] + goTree :: forall a. HList a -> TestTree a () -> IO (Next ResultTree) + goTree l = \case + DefSpecifyNode t td () -> do + let runFunc = testDefVal td (\f -> f l ()) + result <- timeItT runFunc + let td' = td {testDefVal = result} + let r = failFastNext failFast td' + pure $ SpecifyNode t <$> r + DefPendingNode t mr -> pure $ Continue $ PendingNode t mr + DefDescribeNode t sdf -> fmap (DescribeNode t) <$> goForest l sdf + DefWrapNode func sdf -> fmap SubForestNode <$> applySimpleWrapper'' func (goForest l sdf) + DefBeforeAllNode func sdf -> do + fmap SubForestNode + <$> ( do + b <- func + goForest (HCons b l) sdf + ) + DefAroundAllNode func sdf -> + fmap SubForestNode <$> applySimpleWrapper' func (\b -> goForest (HCons b l) sdf) + DefAroundAllWithNode func sdf -> + let HCons x _ = l + in fmap SubForestNode <$> applySimpleWrapper func (\b -> goForest (HCons b l) sdf) x + DefAfterAllNode func sdf -> fmap SubForestNode <$> (goForest l sdf `finally` func l) + DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest l sdf -- Ignore, it's synchronous anyway + DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest l sdf + +runSpecForestInterleavedWithOutputSynchronously :: Maybe Bool -> Bool -> TestForest '[] () -> IO (Timed ResultForest) +runSpecForestInterleavedWithOutputSynchronously mColour failFast testForest = do + byteStringMaker <- case mColour of + Just False -> pure toByteStringsColors0 + Just True -> pure toByteStringsColors256 + Nothing -> liftIO byteStringMakerFromEnvironment + let outputLine :: [Chunk] -> IO () + outputLine lineChunks = do + let bss = chunksToByteStrings byteStringMaker lineChunks + liftIO $ do + mapM_ SB.putStr bss + SB8.putStrLn "" + treeWidth :: Int + treeWidth = specForestWidth testForest + let pad :: Int -> [Chunk] -> [Chunk] + pad level = (chunk (T.pack (replicate (paddingSize * level) ' ')) :) + goForest :: Int -> HList a -> TestForest a () -> IO (Next ResultForest) + goForest _ _ [] = pure (Continue []) + goForest level l (tt : rest) = do + nrt <- goTree level l tt + case nrt of + Continue rt -> do + nf <- goForest level l rest + pure $ (rt :) <$> nf + Stop rt -> pure $ Stop [rt] + goTree :: Int -> HList a -> TestTree a () -> IO (Next ResultTree) + goTree level a = \case + DefSpecifyNode t td () -> do + let runFunc = testDefVal td (\f -> f a ()) + result <- timeItT runFunc + let td' = td {testDefVal = result} + mapM_ (outputLine . pad level) $ outputSpecifyLines level treeWidth t td' + let r = failFastNext failFast td' + pure $ SpecifyNode t <$> r + DefPendingNode t mr -> do + mapM_ (outputLine . pad level) $ outputPendingLines t mr + pure $ Continue $ PendingNode t mr + DefDescribeNode t sf -> do + outputLine $ pad level $ outputDescribeLine t + fmap (DescribeNode t) <$> goForest (succ level) a sf + DefWrapNode func sdf -> fmap SubForestNode <$> applySimpleWrapper'' func (goForest level a sdf) + DefBeforeAllNode func sdf -> + fmap SubForestNode + <$> ( do + b <- func + goForest level (HCons b a) sdf + ) + DefAroundAllNode func sdf -> + fmap SubForestNode <$> applySimpleWrapper' func (\b -> goForest level (HCons b a) sdf) + DefAroundAllWithNode func sdf -> + let HCons x _ = a + in fmap SubForestNode <$> applySimpleWrapper func (\b -> goForest level (HCons b a) sdf) x + DefAfterAllNode func sdf -> fmap SubForestNode <$> (goForest level a sdf `finally` func a) + DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest level a sdf -- Ignore, it's synchronous anyway + DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest level a sdf + mapM_ outputLine outputTestsHeader + resultForest <- timeItT $ extractNext <$> goForest 0 HNil testForest + outputLine [chunk " "] + mapM_ outputLine $ outputFailuresWithHeading (timedValue resultForest) + outputLine [chunk " "] + mapM_ outputLine $ outputStats (computeTestSuiteStats <$> resultForest) + outputLine [chunk " "] + + pure resultForest diff --git a/src/Test/Syd/Runner/Wrappers.hs b/src/Test/Syd/Runner/Wrappers.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Runner/Wrappers.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Syd.Runner.Wrappers where + +import Control.Concurrent +import Control.Monad.IO.Class +import Test.Syd.Run +import Test.Syd.SpecDef + +data Next a = Continue a | Stop a + deriving (Functor) + +extractNext :: Next a -> a +extractNext (Continue a) = a +extractNext (Stop a) = a + +failFastNext :: Bool -> TDef (Timed TestRunResult) -> Next (TDef (Timed TestRunResult)) +failFastNext b td@(TDef (Timed trr _) _) = + if b && testRunResultStatus trr == TestFailed + then Stop td + else Continue td + +applySimpleWrapper :: + MonadIO m => + ((a -> m ()) -> (b -> m ())) -> + (a -> m r) -> + (b -> m r) +applySimpleWrapper takeTakeA takeA b = do + var <- liftIO newEmptyMVar + takeTakeA + ( \a -> do + r <- takeA a + liftIO $ putMVar var r + ) + b + liftIO $ readMVar var + +applySimpleWrapper' :: + MonadIO m => + ((a -> m ()) -> m ()) -> + (a -> m r) -> + m r +applySimpleWrapper' takeTakeA takeA = do + var <- liftIO newEmptyMVar + takeTakeA + ( \a -> do + r <- takeA a + liftIO $ putMVar var r + ) + + liftIO $ readMVar var + +applySimpleWrapper'' :: + MonadIO m => + (m () -> m ()) -> + m r -> + m r +applySimpleWrapper'' wrapper produceResult = do + var <- liftIO newEmptyMVar + wrapper $ do + r <- produceResult + liftIO $ putMVar var r + + liftIO $ readMVar var + +applySimpleWrapper2 :: + MonadIO m => + ((a -> b -> m ()) -> (c -> d -> m ())) -> + (a -> b -> m r) -> + (c -> d -> m r) +applySimpleWrapper2 takeTakeAB takeAB c d = do + var <- liftIO newEmptyMVar + takeTakeAB + ( \a b -> do + r <- takeAB a b + liftIO $ putMVar var r + ) + c + d + liftIO $ readMVar var diff --git a/src/Test/Syd/SpecDef.hs b/src/Test/Syd/SpecDef.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/SpecDef.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module defines all the functions you will use to define your test suite. +module Test.Syd.SpecDef where + +import Data.Kind +import Data.Text (Text) +import Data.Word +import GHC.Stack +import Test.QuickCheck.IO () +import Test.Syd.HList +import Test.Syd.Run +import Test.Syd.SpecForest + +data TDef v = TDef {testDefVal :: v, testDefCallStack :: CallStack} + deriving (Functor, Foldable, Traversable) + +type TestForest a c = SpecDefForest a c () + +type TestTree a c = SpecDefTree a c () + +type SpecDefForest (a :: [Type]) c e = [SpecDefTree a c e] + +data SpecDefTree (a :: [Type]) c e where -- a: input from 'aroundAll', c: input from 'around', e: extra + DefSpecifyNode :: + Text -> + TDef (((HList a -> c -> IO ()) -> IO ()) -> IO TestRunResult) -> + e -> + SpecDefTree a c e -- A test with its description + DefPendingNode :: Text -> Maybe Text -> SpecDefTree a c e + DefDescribeNode :: Text -> SpecDefForest a c e -> SpecDefTree a c e -- A description + DefWrapNode :: (IO () -> IO ()) -> SpecDefForest a c e -> SpecDefTree a c e + DefBeforeAllNode :: IO a -> SpecDefForest (a ': l) c e -> SpecDefTree l c e + DefAroundAllNode :: + ((a -> IO ()) -> IO ()) -> + SpecDefForest (a ': l) c e -> + SpecDefTree l c e + DefAroundAllWithNode :: + ((b -> IO ()) -> (a -> IO ())) -> + SpecDefForest (b ': a ': l) c e -> + SpecDefTree (a ': l) c e + DefAfterAllNode :: (HList a -> IO ()) -> SpecDefForest a c e -> SpecDefTree a c e + DefParallelismNode :: Parallelism -> SpecDefForest a c e -> SpecDefTree a c e + DefRandomisationNode :: ExecutionOrderRandomisation -> SpecDefForest a c e -> SpecDefTree a c e + +instance Functor (SpecDefTree a c) where + fmap :: forall e f. (e -> f) -> SpecDefTree a c e -> SpecDefTree a c f + fmap f = + let goF :: forall x y. SpecDefForest x y e -> SpecDefForest x y f + goF = map (fmap f) + in \case + DefDescribeNode t sdf -> DefDescribeNode t $ goF sdf + DefPendingNode t mr -> DefPendingNode t mr + DefSpecifyNode t td e -> DefSpecifyNode t td (f e) + DefWrapNode func sdf -> DefWrapNode func $ goF sdf + DefBeforeAllNode func sdf -> DefBeforeAllNode func $ goF sdf + DefAroundAllNode func sdf -> DefAroundAllNode func $ goF sdf + DefAroundAllWithNode func sdf -> DefAroundAllWithNode func $ goF sdf + DefAfterAllNode func sdf -> DefAfterAllNode func $ goF sdf + DefParallelismNode p sdf -> DefParallelismNode p $ goF sdf + DefRandomisationNode p sdf -> DefRandomisationNode p $ goF sdf + +instance Foldable (SpecDefTree a c) where + foldMap :: forall e m. Monoid m => (e -> m) -> SpecDefTree a c e -> m + foldMap f = + let goF :: forall x y. SpecDefForest x y e -> m + goF = foldMap (foldMap f) + in \case + DefDescribeNode _ sdf -> goF sdf + DefPendingNode _ _ -> mempty + DefSpecifyNode _ _ e -> f e + DefWrapNode _ sdf -> goF sdf + DefBeforeAllNode _ sdf -> goF sdf + DefAroundAllNode _ sdf -> goF sdf + DefAroundAllWithNode _ sdf -> goF sdf + DefAfterAllNode _ sdf -> goF sdf + DefParallelismNode _ sdf -> goF sdf + DefRandomisationNode _ sdf -> goF sdf + +instance Traversable (SpecDefTree a c) where + traverse :: forall u w f. Applicative f => (u -> f w) -> SpecDefTree a c u -> f (SpecDefTree a c w) + traverse f = + let goF :: forall x y. SpecDefForest x y u -> f (SpecDefForest x y w) + goF = traverse (traverse f) + in \case + DefDescribeNode t sdf -> DefDescribeNode t <$> goF sdf + DefPendingNode t mr -> pure $ DefPendingNode t mr + DefSpecifyNode t td e -> DefSpecifyNode t td <$> f e + DefWrapNode func sdf -> DefWrapNode func <$> goF sdf + DefBeforeAllNode func sdf -> DefBeforeAllNode func <$> goF sdf + DefAroundAllNode func sdf -> DefAroundAllNode func <$> goF sdf + DefAroundAllWithNode func sdf -> DefAroundAllWithNode func <$> goF sdf + DefAfterAllNode func sdf -> DefAfterAllNode func <$> goF sdf + DefParallelismNode p sdf -> DefParallelismNode p <$> goF sdf + DefRandomisationNode p sdf -> DefRandomisationNode p <$> goF sdf + +data Parallelism = Parallel | Sequential + +data ExecutionOrderRandomisation = RandomiseExecutionOrder | DoNotRandomiseExecutionOrder + +type ResultForest = SpecForest (TDef (Timed TestRunResult)) + +type ResultTree = SpecTree (TDef (Timed TestRunResult)) + +computeTestSuiteStats :: ResultForest -> TestSuiteStats +computeTestSuiteStats = goF + where + goF :: ResultForest -> TestSuiteStats + goF = foldMap goT + goT :: ResultTree -> TestSuiteStats + goT = \case + SpecifyNode _ (TDef (Timed TestRunResult {..} t) _) -> + TestSuiteStats + { testSuiteStatSuccesses = case testRunResultStatus of + TestPassed -> 1 + TestFailed -> 0, + testSuiteStatFailures = case testRunResultStatus of + TestPassed -> 0 + TestFailed -> 1, + testSuiteStatPending = 0, + testSuiteStatLongestTime = Just t + } + PendingNode _ _ -> + TestSuiteStats + { testSuiteStatSuccesses = 0, + testSuiteStatFailures = 0, + testSuiteStatPending = 1, + testSuiteStatLongestTime = Nothing + } + DescribeNode _ sf -> goF sf + SubForestNode sf -> goF sf + +data TestSuiteStats = TestSuiteStats + { testSuiteStatSuccesses :: !Word, + testSuiteStatFailures :: !Word, + testSuiteStatPending :: !Word, + testSuiteStatLongestTime :: !(Maybe Word64) + } + deriving (Show, Eq) + +instance Semigroup TestSuiteStats where + (<>) tss1 tss2 = + TestSuiteStats + { testSuiteStatSuccesses = testSuiteStatSuccesses tss1 + testSuiteStatSuccesses tss2, + testSuiteStatFailures = testSuiteStatFailures tss1 + testSuiteStatFailures tss2, + testSuiteStatPending = testSuiteStatPending tss1 + testSuiteStatPending tss2, + testSuiteStatLongestTime = case (testSuiteStatLongestTime tss1, testSuiteStatLongestTime tss2) of + (Nothing, Nothing) -> Nothing + (Just t1, Nothing) -> Just t1 + (Nothing, Just t2) -> Just t2 + (Just t1, Just t2) -> Just (max t1 t2) + } + +instance Monoid TestSuiteStats where + mappend = (<>) + mempty = + TestSuiteStats + { testSuiteStatSuccesses = 0, + testSuiteStatFailures = 0, + testSuiteStatPending = 0, + testSuiteStatLongestTime = Nothing + } + +shouldExitFail :: ResultForest -> Bool +shouldExitFail = any (any ((== TestFailed) . testRunResultStatus . timedValue . testDefVal)) diff --git a/src/Test/Syd/SpecForest.hs b/src/Test/Syd/SpecForest.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/SpecForest.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +module Test.Syd.SpecForest where + +import Data.Text (Text) +import Test.QuickCheck.IO () + +type SpecForest a = [SpecTree a] + +data SpecTree a + = SpecifyNode Text a -- A test with its description + | PendingNode Text (Maybe Text) + | DescribeNode Text (SpecForest a) -- A description + | SubForestNode (SpecForest a) -- A test with its description + deriving (Functor) + +instance Foldable SpecTree where + foldMap f = \case + SpecifyNode _ a -> f a + PendingNode _ _ -> mempty + DescribeNode _ sts -> foldMap (foldMap f) sts + SubForestNode sts -> foldMap (foldMap f) sts + +instance Traversable SpecTree where + traverse func = \case + SpecifyNode s a -> SpecifyNode s <$> func a + PendingNode t mr -> pure $ PendingNode t mr + DescribeNode s sf -> DescribeNode s <$> traverse (traverse func) sf + SubForestNode sf -> SubForestNode <$> traverse (traverse func) sf + +flattenSpecForest :: SpecForest a -> [([Text], a)] +flattenSpecForest = concatMap flattenSpecTree + +flattenSpecTree :: SpecTree a -> [([Text], a)] +flattenSpecTree = \case + SpecifyNode t a -> [([t], a)] + PendingNode _ _ -> [] + DescribeNode t sf -> map (\(ts, a) -> (t : ts, a)) $ flattenSpecForest sf + SubForestNode sf -> flattenSpecForest sf diff --git a/sydtest.cabal b/sydtest.cabal new file mode 100644 --- /dev/null +++ b/sydtest.cabal @@ -0,0 +1,123 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.2. +-- +-- see: https://github.com/sol/hpack + +name: sydtest +version: 0.0.0.0 +synopsis: An advanced modern testing framework for Haskell with good defaults and advanced testing features. +description: An advanced modern testing framework for Haskell with good defaults and advanced testing features. Sydtest aims to make the common easy and the hard possible. See https://github.com/NorfairKing/sydtest#readme for more information. +category: Testing +homepage: https://github.com/NorfairKing/sydtest#readme +bug-reports: https://github.com/NorfairKing/sydtest/issues +author: Tom Sydney Kerckhove +maintainer: syd@cs-syd.eu +copyright: Copyright (c) 2020 Tom Sydney Kerckhove +license: OtherLicense +license-file: LICENSE +build-type: Simple + +source-repository head + type: git + location: https://github.com/NorfairKing/sydtest + +library + exposed-modules: + Test.Syd + Test.Syd.Def + Test.Syd.Def.Around + Test.Syd.Def.AroundAll + Test.Syd.Def.Env + Test.Syd.Def.Golden + Test.Syd.Def.SetupFunc + Test.Syd.Def.Specify + Test.Syd.Def.TestDefM + Test.Syd.Expectation + Test.Syd.HList + Test.Syd.Modify + Test.Syd.OptParse + Test.Syd.Output + Test.Syd.Run + Test.Syd.Runner + Test.Syd.Runner.Asynchronous + Test.Syd.Runner.Synchronous + Test.Syd.Runner.Wrappers + Test.Syd.SpecDef + Test.Syd.SpecForest + other-modules: + Paths_sydtest + hs-source-dirs: + src + build-depends: + Diff + , MonadRandom + , QuickCheck + , async + , base >=4.7 && <5 + , bytestring + , containers + , dlist + , envparse + , mtl + , optparse-applicative + , path + , path-io + , pretty-show + , quickcheck-io + , rainbow + , random-shuffle + , safe + , split + , text + , yaml + , yamlparse-applicative + default-language: Haskell2010 + +test-suite sydtest-output-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_sydtest + hs-source-dirs: + output-test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , base >=4.7 && <5 + , bytestring + , path + , path-io + , rainbow + , sydtest + , text + default-language: Haskell2010 + +test-suite sydtest-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Syd.AroundAllSpec + Test.Syd.AroundCombinationSpec + Test.Syd.AroundSpec + Test.Syd.FootgunSpec + Test.Syd.GoldenSpec + Test.Syd.Specify.AllOuterSpec + Test.Syd.SpecifySpec + Test.Syd.TimingSpec + Paths_sydtest + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + sydtest-discover:sydtest-discover + build-depends: + QuickCheck + , base >=4.7 && <5 + , bytestring + , path + , path-io + , rainbow + , stm + , sydtest + default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/test/Test/Syd/AroundAllSpec.hs b/test/Test/Syd/AroundAllSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/AroundAllSpec.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Syd.AroundAllSpec (spec) where + +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Test.Syd + +spec :: Spec +spec = sequential $ do + describe "beforeAll" $ do + var <- liftIO $ newTVarIO (0 :: Int) + let readAndIncrement :: IO Int + readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1) + beforeAll readAndIncrement $ do + let t :: Int -> IO () + t i = i `shouldBe` 1 + itWithOuter "reads 1" t + itWithOuter "reads 1" t + + describe "beforeAll_" $ do + var <- liftIO $ newTVarIO (0 :: Int) + let increment :: IO () + increment = atomically $ modifyTVar var (+ 1) + beforeAll_ increment $ do + let t :: IO () + t = do + i <- readTVarIO var + i `shouldBe` 1 + it "reads 1" t + it "reads 1" t + + describe "beforeAllWith" $ do + var <- liftIO $ newTVarIO (0 :: Int) + let readAndIncrement :: IO Int + readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1) + let increment :: IO () + increment = atomically $ modifyTVar var (+ 1) + let incrementBeforeAndAfterWith :: Int -> IO Int + incrementBeforeAndAfterWith j = do + i <- readAndIncrement + increment + pure (i + j) + beforeAll readAndIncrement $ do + beforeAllWith incrementBeforeAndAfterWith $ do + let t :: Int -> IO () + t i = i `shouldBe` 3 + itWithOuter "reads 3" t + itWithOuter "reads 3" t + + describe "afterAll" $ do + var <- liftIO $ newTVarIO (0 :: Int) + let readAndIncrement :: IO Int + readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1) + addExtra :: Int -> IO () + addExtra i = atomically $ modifyTVar var (+ i) + beforeAll readAndIncrement $ + afterAll addExtra $ do + let t :: Int -> IO () + t i = i `shouldBe` 1 + itWithOuter "reads 1" t + itWithOuter "reads 1" t + + describe "afterAll'" $ do + var <- liftIO $ newTVarIO (0 :: Int) + let readAndIncrement :: IO Int + readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1) + addExtra :: HList '[Int] -> IO () + addExtra (HCons i HNil) = atomically $ modifyTVar var (+ i) + beforeAll readAndIncrement $ + afterAll' addExtra $ do + let t :: Int -> IO () + t i = i `shouldBe` 1 + itWithOuter "reads 1" t + itWithOuter "reads 1" t + + describe "afterAll_" $ do + var <- liftIO $ newTVarIO (0 :: Int) + let increment :: IO () + increment = atomically $ modifyTVar var (+ 1) + afterAll_ increment $ do + let t :: IO () + t = do + i <- readTVarIO var + i `shouldBe` 0 + it "reads 0" t + it "reads 0" t + + describe "aroundAll" $ do + var <- liftIO $ newTVarIO (0 :: Int) + let readAndIncrement :: IO Int + readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1) + let increment :: IO () + increment = atomically $ modifyTVar var (+ 1) + let incrementBeforeAndAfter :: (Int -> IO ()) -> IO () + incrementBeforeAndAfter func = do + i <- readAndIncrement + func i + increment + aroundAll incrementBeforeAndAfter $ do + let t :: Int -> IO () + t i = i `shouldBe` 1 + itWithOuter "reads 1" t + itWithOuter "reads 1" t + + describe "aroundAll_" $ do + var <- liftIO $ newTVarIO (0 :: Int) + let increment :: IO () + increment = atomically $ modifyTVar var (+ 1) + let incrementBeforeAndAfter :: IO () -> IO () + incrementBeforeAndAfter func = do + increment + func + increment + aroundAll_ incrementBeforeAndAfter $ do + let t :: IO () + t = do + i <- readTVarIO var + i `shouldBe` 1 + it "reads 1" t + it "reads 1" t + + describe "aroundAllWith" $ do + var <- liftIO $ newTVarIO (0 :: Int) + let readAndIncrement :: IO Int + readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1) + let increment :: IO () + increment = atomically $ modifyTVar var (+ 1) + let incrementBeforeAndAfter :: (Int -> IO ()) -> IO () + incrementBeforeAndAfter func = do + i <- readAndIncrement + func i + increment + let incrementBeforeAndAfterWith :: (Int -> IO ()) -> Int -> IO () + incrementBeforeAndAfterWith func j = do + i <- readAndIncrement + func (i + j) + increment + aroundAll incrementBeforeAndAfter $ + aroundAllWith incrementBeforeAndAfterWith $ do + let t :: Int -> IO () + t i = i `shouldBe` 3 + itWithOuter "reads correctly" t + itWithOuter "reads correctly" t diff --git a/test/Test/Syd/AroundCombinationSpec.hs b/test/Test/Syd/AroundCombinationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/AroundCombinationSpec.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Syd.AroundCombinationSpec (spec) where + +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Test.Syd + +spec :: Spec +spec = sequential $ + doNotRandomiseExecutionOrder $ do + describe "aroundAll + aroundAllWith + around + aroundWith'" $ do + var <- liftIO $ newTVarIO (0 :: Int) + let readAndIncrement :: IO Int + readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1) + let increment :: IO () + increment = atomically $ modifyTVar var (+ 1) + let incrementAround :: (Int -> IO ()) -> IO () + incrementAround func = do + i <- readAndIncrement + func i + increment + let incrementAroundWith :: (Int -> IO ()) -> Int -> IO () + incrementAroundWith func j = do + i <- readAndIncrement + func (i + j) + increment + let incrementAroundWith2 :: (Int -> Int -> IO ()) -> Int -> Int -> IO () + incrementAroundWith2 func j k = do + i <- readAndIncrement + func (i + j) k + increment + aroundAll incrementAround $ + aroundAllWith incrementAroundWith $ + around incrementAround $ + aroundWith' incrementAroundWith2 $ do + itWithBoth "reads correctly" $ + \i k -> + (i, k) `shouldBe` (3, 3) + itWithBoth "reads correctly" $ + \i k -> + (i, k) `shouldBe` (3, 7) diff --git a/test/Test/Syd/AroundSpec.hs b/test/Test/Syd/AroundSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/AroundSpec.hs @@ -0,0 +1,131 @@ +module Test.Syd.AroundSpec (spec) where + +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Test.Syd + +spec :: Spec +spec = sequential $ + doNotRandomiseExecutionOrder $ do + describe "before" $ do + var <- liftIO $ newTVarIO (1 :: Int) + let readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1) + before readAndIncrement $ do + it "reads 2" $ \i -> + i `shouldBe` 2 + it "reads 4" $ \i -> + i `shouldBe` 3 + it "reads 6" $ \i -> + i `shouldBe` 4 + + describe "before_" $ do + var <- liftIO $ newTVarIO (1 :: Int) + let increment = atomically $ modifyTVar var succ + before_ increment $ do + it "reads 2" $ do + i <- readTVarIO var + i `shouldBe` 2 + it "reads 4" $ do + i <- readTVarIO var + i `shouldBe` 3 + it "reads 6" $ do + i <- readTVarIO var + i `shouldBe` 4 + + describe "after" $ do + var <- liftIO $ newTVarIO (0 :: Int) + let increment = atomically $ modifyTVar var succ + after (\() -> increment) $ do + it "reads 0" $ do + i <- readTVarIO var + i `shouldBe` 0 + it "reads 2" $ do + i <- readTVarIO var + i `shouldBe` 1 + it "reads 4" $ do + i <- readTVarIO var + i `shouldBe` 2 + + describe "after_" $ do + var <- liftIO $ newTVarIO (0 :: Int) + let increment = atomically $ modifyTVar var succ + after_ increment $ do + it "reads 0" $ do + i <- readTVarIO var + i `shouldBe` 0 + it "reads 2" $ do + i <- readTVarIO var + i `shouldBe` 1 + it "reads 4" $ do + i <- readTVarIO var + i `shouldBe` 2 + + describe "around" $ do + var <- liftIO $ newTVarIO (1 :: Int) + let increment = atomically $ modifyTVar var succ + readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1) + aroundFunc :: (Int -> IO ()) -> IO () + aroundFunc intFunc = do + i <- readAndIncrement + intFunc i + increment + around aroundFunc $ do + it "reads 2" $ \i -> + i `shouldBe` 2 + it "reads 4" $ \i -> + i `shouldBe` 4 + it "reads 6" $ \i -> + i `shouldBe` 6 + + describe "around_" $ do + var <- liftIO $ newTVarIO (1 :: Int) + let increment = atomically $ modifyTVar var succ + aroundFunc_ :: IO () -> IO () + aroundFunc_ func = do + increment + func + increment + around_ aroundFunc_ $ do + it "reads 2" $ do + i <- readTVarIO var + i `shouldBe` 2 + it "reads 4" $ do + i <- readTVarIO var + i `shouldBe` 4 + it "reads 6" $ do + i <- readTVarIO var + i `shouldBe` 6 + + describe "aroundWith" $ do + var <- liftIO $ newTVarIO (1 :: Int) + let increment = atomically $ modifyTVar var succ + readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1) + aroundWithFunc :: (Int -> IO ()) -> () -> IO () + aroundWithFunc intFunc () = do + i <- readAndIncrement + intFunc i + increment + aroundWith aroundWithFunc $ do + it "reads 2" $ \i -> + i `shouldBe` 2 + it "reads 4" $ \i -> + i `shouldBe` 4 + it "reads 6" $ \i -> + i `shouldBe` 6 + + describe "aroundWith'" $ do + var <- liftIO $ newTVarIO (1 :: Int) + let increment = atomically $ modifyTVar var succ + readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1) + aroundWithFunc :: (() -> Int -> IO ()) -> () -> () -> IO () + aroundWithFunc intFunc () () = do + i <- readAndIncrement + intFunc () i + increment + aroundWith' aroundWithFunc $ do + it "reads 2" $ \i -> + i `shouldBe` 2 + it "reads 4" $ \i -> + i `shouldBe` 4 + it "reads 6" $ \i -> + i `shouldBe` 6 diff --git a/test/Test/Syd/FootgunSpec.hs b/test/Test/Syd/FootgunSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/FootgunSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Syd.FootgunSpec (spec) where + +import Test.Syd + +spec :: Spec +spec = do + aroundTwice + aroundDon't + aroundAllTwice + aroundAllDon't + +aroundDon't :: Spec +aroundDon't = do + -- -- This causes sydtest-test: thread blocked indefinitely in an MVar operation + -- let don'tDo :: IO () -> IO () + -- don'tDo _ = pure () + -- around_ don'tDo $ do + -- it "should pass" True + pure () + +aroundTwice :: Spec +aroundTwice = do + -- -- This causes sydtest-test: thread blocked indefinitely in an MVar operation + -- let doTwice :: IO () -> IO () + -- doTwice f = f >> f + -- around_ doTwice $ do + -- it "should pass" True + pure () + +aroundAllDon't :: Spec +aroundAllDon't = do + -- -- This causes sydtest-test: thread blocked indefinitely in an MVar operation + -- let don'tDo :: IO () -> IO () + -- don'tDo _ = pure () + -- aroundAll_ don'tDo $ do + -- it "should pass" True + pure () + +aroundAllTwice :: Spec +aroundAllTwice = do + -- -- This 'just works' but takes longer. + -- let doTwice :: IO () -> IO () + -- doTwice f = f >> f + -- aroundAll_ doTwice $ do + -- it "should pass" True + pure () diff --git a/test/Test/Syd/GoldenSpec.hs b/test/Test/Syd/GoldenSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/GoldenSpec.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Syd.GoldenSpec (spec) where + +import qualified Data.ByteString as SB +import qualified Data.ByteString.Char8 as SB8 +import Rainbow +import Test.Syd +import Test.Syd.OptParse + +spec :: Spec +spec = do + describe "outputResultForest" $ do + it "outputs the same as last time" $ do + pureGoldenByteStringFile + "test_resources/output.golden" + (SB8.intercalate "\n" $ map SB.concat $ outputSpecForestByteString toByteStringsColors256 (Timed [] 0)) + describe "defaultSettings" $ do + it "is the same thing as last time" $ goldenPrettyShowInstance "test_resources/defaultSettings-show.golden" defaultSettings diff --git a/test/Test/Syd/Specify/AllOuterSpec.hs b/test/Test/Syd/Specify/AllOuterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Specify/AllOuterSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.Specify.AllOuterSpec (spec) where + +import Test.QuickCheck +import Test.Syd + +spec :: Spec +spec = sequential $ do + describe "boolean" $ do + beforeAll (pure (1 :: Int)) $ + beforeAll (pure (2 :: Int)) $ + itWithAll "boolean function (all)" $ + \(HCons i (HCons j HNil) :: HList '[Int, Int]) () -> even i && odd j + + describe "IO action" $ do + beforeAll (pure (1 :: Int)) $ do + beforeAll (pure (2 :: Int)) $ + itWithAll "IO action function (all)" $ + \(HCons i (HCons j HNil) :: HList '[Int, Int]) () -> (i, j) `shouldBe` (2, 1) + + describe "property test" $ do + beforeAll (pure (1 :: Int)) $ do + beforeAll (pure (2 :: Int)) $ + itWithAll "property test function (all)" $ + \(HCons i (HCons j HNil) :: HList '[Int, Int]) () -> + property $ \k -> i * j * k `shouldBe` 1 * 2 * k diff --git a/test/Test/Syd/SpecifySpec.hs b/test/Test/Syd/SpecifySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/SpecifySpec.hs @@ -0,0 +1,38 @@ +module Test.Syd.SpecifySpec (spec) where + +import Test.QuickCheck +import Test.Syd + +spec :: Spec +spec = sequential $ do + describe "boolean" $ do + it "boolean" True + before (pure (2 :: Int)) $ + it "boolean function (inner)" $ \i -> even i + beforeAll (pure (2 :: Int)) $ do + itWithOuter "boolean function (one outer)" $ \i -> even i + itWithBoth "boolean function (both inner and outer)" $ \i () -> even i + + describe "IO action" $ do + it "IO action" True + before (pure (2 :: Int)) $ + it "IO action function (inner)" $ \i -> i `shouldBe` 2 + beforeAll (pure (1 :: Int)) $ do + itWithOuter "IO action function (one outer)" $ \i -> i `shouldBe` 1 + itWithBoth "IO action function (both inner and outer)" $ \i () -> i `shouldBe` 1 + + describe "property test" $ do + it "property test" $ property $ \j -> j `shouldBe` (j :: Int) + before (pure (2 :: Int)) $ + it "property test function (inner)" $ \i -> + property $ \j -> + i * j `shouldBe` 2 * (j :: Int) + beforeAll (pure (1 :: Int)) $ do + itWithOuter "property test function (one outer)" $ \i -> property $ \j -> + i * j `shouldBe` 1 * j + itWithBoth "property test function (both inner and outer)" $ \i () -> property $ \j -> + i * j `shouldBe` 1 * j + + describe "pending tests" $ do + pending "this is a pending test" + pendingWith "this is another pending test" "with this reason" diff --git a/test/Test/Syd/TimingSpec.hs b/test/Test/Syd/TimingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/TimingSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Syd.TimingSpec (spec) where + +import Control.Concurrent +import System.IO.Unsafe +import Test.QuickCheck +import Test.Syd + +spec :: Spec +spec = doNotRandomiseExecutionOrder $ do + it "takes at least 10 milliseconds (pure)" $ + unsafePerformIO take10ms `seq` True + it "takes at least 10 milliseconds (IO)" $ do + threadDelay 10_000 + it "takes at least 10 milliseconds (property) " $ + property $ \() -> do + threadDelay 100 + it "takes at least 100 milliseconds (pure)" $ + unsafePerformIO take100ms `seq` True + it "takes at least 100 milliseconds (IO)" $ do + threadDelay 100_000 + it "takes at least 100 milliseconds (property) " $ + property $ \() -> do + threadDelay 1_000 + +{-# NOINLINE take10ms #-} +take10ms :: IO () +take10ms = threadDelay 10_000 + +{-# NOINLINE take100ms #-} +take100ms :: IO () +take100ms = threadDelay 100_000