packages feed

sydtest (empty) → 0.0.0.0

raw patch · 33 files changed

+4408/−0 lines, 33 filesdep +Diffdep +MonadRandomdep +QuickCheck

Dependencies added: Diff, MonadRandom, QuickCheck, async, base, bytestring, containers, dlist, envparse, mtl, optparse-applicative, path, path-io, pretty-show, quickcheck-io, rainbow, random-shuffle, safe, split, stm, sydtest, text, yaml, yamlparse-applicative

Files

+ LICENSE view
@@ -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.+
+ output-test/Spec.hs view
@@ -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
+ src/Test/Syd.hs view
@@ -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
+ src/Test/Syd/Def.hs view
@@ -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
+ src/Test/Syd/Def/Around.hs view
@@ -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')
+ src/Test/Syd/Def/AroundAll.hs view
@@ -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')
+ src/Test/Syd/Def/Env.hs view
@@ -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
+ src/Test/Syd/Def/Golden.hs view
@@ -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
+ src/Test/Syd/Def/SetupFunc.hs view
@@ -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
+ src/Test/Syd/Def/Specify.hs view
@@ -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))]
+ src/Test/Syd/Def/TestDefM.hs view
@@ -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
+ src/Test/Syd/Expectation.hs view
@@ -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
+ src/Test/Syd/HList.hs view
@@ -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
+ src/Test/Syd/Modify.hs view
@@ -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)
+ src/Test/Syd/OptParse.hs view
@@ -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"+                ]+            )+      )
+ src/Test/Syd/Output.hs view
@@ -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
+ src/Test/Syd/Run.hs view
@@ -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)
+ src/Test/Syd/Runner.hs view
@@ -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
+ src/Test/Syd/Runner/Asynchronous.hs view
@@ -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
+ src/Test/Syd/Runner/Synchronous.hs view
@@ -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
+ src/Test/Syd/Runner/Wrappers.hs view
@@ -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
+ src/Test/Syd/SpecDef.hs view
@@ -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))
+ src/Test/Syd/SpecForest.hs view
@@ -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
+ sydtest.cabal view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}
+ test/Test/Syd/AroundAllSpec.hs view
@@ -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
+ test/Test/Syd/AroundCombinationSpec.hs view
@@ -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)
+ test/Test/Syd/AroundSpec.hs view
@@ -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
+ test/Test/Syd/FootgunSpec.hs view
@@ -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 ()
+ test/Test/Syd/GoldenSpec.hs view
@@ -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
+ test/Test/Syd/Specify/AllOuterSpec.hs view
@@ -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
+ test/Test/Syd/SpecifySpec.hs view
@@ -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"
+ test/Test/Syd/TimingSpec.hs view
@@ -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