sydtest 0.1.0.0 → 0.2.0.0

raw patch · 18 files changed

+440/−169 lines, 18 filesdep +filepathdep +safe-coloured-text-terminfoPVP ok

version bump matches the API change (PVP)

Dependencies added: filepath, safe-coloured-text-terminfo

API changes (from Hackage documentation)

Files

• output-test/Spec.hs +2/−0
• src/Test/Syd.hs +30/−11
• src/Test/Syd/Def.hs +2/−0
• src/Test/Syd/Def/Around.hs +21/−3
• src/Test/Syd/Def/Golden.hs +69/−1
• src/Test/Syd/Def/Scenario.hs +47/−0
• src/Test/Syd/Def/SetupFunc.hs +59/−103
• src/Test/Syd/Def/Specify.hs +9/−1
• src/Test/Syd/Def/TestDefM.hs +1/−1
• src/Test/Syd/Expectation.hs +3/−0
• src/Test/Syd/Output.hs +40/−22
• src/Test/Syd/Path.hs +39/−0
• src/Test/Syd/Run.hs +47/−15
• src/Test/Syd/Runner.hs +1/−0
• src/Test/Syd/SpecDef.hs +18/−11
• sydtest.cabal +8/−1
• test/Test/Syd/PathSpec.hs +28/−0
• test/Test/Syd/ScenarioSpec.hs +16/−0

@@ -18,6 +18,7 @@ import Test.Syd import Test.Syd.OptParse import Text.Colour+import Text.Colour.Capabilities.FromEnv  data DangerousRecord = Cons1 {field :: String} | Cons2 @@ -210,6 +211,7 @@             True `shouldBe` False   modifyMaxSize (`div` 10) $     describe "Property" $ do+      describe "0 tests run" $ modifyMaxSuccess (const 0) $ it "shows a red '0 tests' when no tests are run" $ property $ \b -> b `shouldBe` False       describe "generated values" $         it "shows many generated values too" $           property $ \i ->

@@ -49,6 +49,7 @@     specifyWithOuter,     specifyWithBoth,     specifyWithAll,+    prop,      -- ** Commented-out tests     xdescribe,@@ -70,15 +71,25 @@     withTestEnv,      -- ** Golden tests-    pureGoldenByteStringFile,-    goldenByteStringFile,     pureGoldenTextFile,     goldenTextFile,+    pureGoldenByteStringFile,+    goldenByteStringFile,+    pureGoldenLazyByteStringFile,+    goldenLazyByteStringFile,+    pureGoldenByteStringBuilderFile,+    goldenByteStringBuilderFile,     pureGoldenStringFile,     goldenStringFile,     goldenShowInstance,     goldenPrettyShowInstance,+    goldenContext,+    GoldenTest (..), +    -- ** Scenario tests+    scenarioDir,+    scenarioDirRecur,+     -- ** Expectations     shouldBe,     shouldNotBe,@@ -136,19 +147,19 @@      -- **** Setup functions +    -- ***** Creating setup functions+    SetupFunc (..),+     -- ***** Using setup functions++    -- ****** Around     setupAround,     setupAroundWith,     setupAroundWith', -    -- ***** Creating setup functions-    SetupFunc (..),-    makeSimpleSetupFunc,-    useSimpleSetupFunc,-    connectSetupFunc,-    composeSetupFunc,-    wrapSetupFunc,-    unwrapSetupFunc,+    -- ****** AroundAll+    setupAroundAll,+    setupAroundAllWith,      -- *** Declaring different test settings     modifyMaxSuccess,@@ -232,17 +243,25 @@ import Test.Syd.SpecForest import Text.Show.Pretty (ppShow) --- | Evaluate a test suite definition and then run it, with default 'Settings'+-- | Evaluate a test suite definition and then run it.+--+-- This function perform option-parsing to construct the 'Settings' and then call 'sydTestWith'. sydTest :: Spec -> IO () sydTest spec = do   sets <- getSettings   sydTestWith sets spec  -- | Evaluate a test suite definition and then run it, with given 'Settings'+--+-- This function performs no option-parsing. sydTestWith :: Settings -> Spec -> IO () sydTestWith sets spec = do   resultForest <- sydTestResult sets spec   when (shouldExitFail (timedValue resultForest)) (exitWith (ExitFailure 1)) +-- | Run a test suite during test suite definition.+--+-- This function only exists for backward compatibility.+-- You can also just use 'liftIO' instead. runIO :: IO e -> TestDefM a b e runIO = liftIO

@@ -7,6 +7,7 @@     module Test.Syd.Def.AroundAll,     module Test.Syd.Def.SetupFunc,     module Test.Syd.Def.Golden,+    module Test.Syd.Def.Scenario,     module Test.Syd.Def.TestDefM,   ) where@@ -15,6 +16,7 @@ import Test.Syd.Def.AroundAll import Test.Syd.Def.Env import Test.Syd.Def.Golden+import Test.Syd.Def.Scenario import Test.Syd.Def.SetupFunc import Test.Syd.Def.Specify import Test.Syd.Def.TestDefM

@@ -19,13 +19,13 @@ import Test.Syd.Run import Test.Syd.SpecDef --- | Run a custom action before every spec item, to set up an inner resource 'c'.+-- | Run a custom action before every spec item, to set up an inner resource 'inner'. before ::   -- | The function to run before every test, to produce the inner resource   IO inner ->   TestDefM outers inner result ->   TestDefM outers () result-before action = around (action >>=)+before action = beforeWith $ \() -> action  -- | Run a custom action before every spec item without setting up any inner resources. before_ ::@@ -33,7 +33,25 @@   IO () ->   TestDefM outers inner result ->   TestDefM outers inner result-before_ action = around_ (action >>)+before_ action = beforeWith $ \inner -> do+  action+  pure inner++-- | Run a custom action before every spec item, to set up an inner resource 'newInner' using the previously set up resource 'oldInner'+beforeWith ::+  forall outers oldInner newInner result.+  (oldInner -> IO newInner) ->+  TestDefM outers newInner result ->+  TestDefM outers oldInner result+beforeWith action = beforeWith' (\(_ :: HList outers) -> action)++-- | Run a custom action before every spec item, to set up an inner resource 'newInner' using the previously set up resource 'oldInner' and potentially any of the outer resources+beforeWith' ::+  HContains outers outer =>+  (outer -> oldInner -> IO newInner) ->+  TestDefM outers newInner result ->+  TestDefM outers oldInner result+beforeWith' action = aroundWith' $ \func outer inner -> action outer inner >>= func outer  -- | Run a custom action after every spec item, using the inner resource 'c'. after ::

@@ -1,7 +1,13 @@-module Test.Syd.Def.Golden where+module Test.Syd.Def.Golden+  ( module Test.Syd.Def.Golden,+    GoldenTest (..),+  )+where  import Data.ByteString (ByteString) import qualified Data.ByteString as SB+import qualified Data.ByteString.Builder as SBB+import qualified Data.ByteString.Lazy as LB import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -33,6 +39,62 @@           else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp)     } +-- | Test that the given lazy bytestring is the same as what we find in the given golden file.+--+-- Note: This converts the lazy bytestring to a strict bytestring first.+pureGoldenLazyByteStringFile :: FilePath -> LB.ByteString -> GoldenTest LB.ByteString+pureGoldenLazyByteStringFile fp bs = goldenLazyByteStringFile fp (pure bs)++-- | Test that the produced bytestring is the same as what we find in the given golden file.+--+-- Note: This converts the lazy bytestring to a strict bytestring first.+goldenLazyByteStringFile :: FilePath -> IO LB.ByteString -> GoldenTest LB.ByteString+goldenLazyByteStringFile fp produceBS =+  GoldenTest+    { goldenTestRead = do+        resolvedFile <- resolveFile' fp+        forgivingAbsence $ fmap LB.fromStrict $ SB.readFile $ fromAbsFile resolvedFile,+      goldenTestProduce = produceBS,+      goldenTestWrite = \actual -> do+        resolvedFile <- resolveFile' fp+        ensureDir $ parent resolvedFile+        SB.writeFile (fromAbsFile resolvedFile) (LB.toStrict actual),+      goldenTestCompare = \actual expected ->+        let actualBS = LB.toStrict actual+            expectedBS = LB.toStrict expected+         in if actualBS == expectedBS+              then Nothing+              else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS) (goldenContext fp)+    }++-- | Test that the given lazy bytestring is the same as what we find in the given golden file.+--+-- Note: This converts the builder to a strict bytestring first.+pureGoldenByteStringBuilderFile :: FilePath -> SBB.Builder -> GoldenTest SBB.Builder+pureGoldenByteStringBuilderFile fp bs = goldenByteStringBuilderFile fp (pure bs)++-- | Test that the produced bytestring is the same as what we find in the given golden file.+--+-- Note: This converts the builder to a strict bytestring first.+goldenByteStringBuilderFile :: FilePath -> IO SBB.Builder -> GoldenTest SBB.Builder+goldenByteStringBuilderFile fp produceBS =+  GoldenTest+    { goldenTestRead = do+        resolvedFile <- resolveFile' fp+        forgivingAbsence $ fmap SBB.byteString $ SB.readFile $ fromAbsFile resolvedFile,+      goldenTestProduce = produceBS,+      goldenTestWrite = \actual -> do+        resolvedFile <- resolveFile' fp+        ensureDir $ parent resolvedFile+        SB.writeFile (fromAbsFile resolvedFile) (LB.toStrict (SBB.toLazyByteString actual)),+      goldenTestCompare = \actual expected ->+        let actualBS = LB.toStrict (SBB.toLazyByteString actual)+            expectedBS = LB.toStrict (SBB.toLazyByteString expected)+         in if actualBS == expectedBS+              then Nothing+              else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS) (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)@@ -85,5 +147,11 @@ goldenPrettyShowInstance :: Show a => FilePath -> a -> GoldenTest String goldenPrettyShowInstance fp a = pureGoldenStringFile fp (ppShow a) +-- | The golden test context for adding context to a golden test assertion:+--+-- > goldenTestCompare = \actual expected ->+-- >   if actual == expected+-- >     then Nothing+-- >     else Just $ Context (stringsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp) goldenContext :: FilePath -> String goldenContext fp = "The golden results are in: " <> fp

@@ -0,0 +1,47 @@+module Test.Syd.Def.Scenario (scenarioDir, scenarioDirRecur) where++import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import Path+import Path.IO+import qualified System.FilePath as FP+import Test.Syd.Def.Specify+import Test.Syd.Def.TestDefM++-- | Define a test for each file in the given directory.+--+-- Example:+--+-- >   scenarioDir "test_resources/even" $ \fp ->+-- >     it "contains an even number" $ do+-- >       s <- readFile fp+-- >       n <- readIO s+-- >       (n :: Int) `shouldSatisfy` even+scenarioDir :: FilePath -> (FilePath -> TestDefM outers inner ()) -> TestDefM outers inner ()+scenarioDir = scenarioDirHelper listDirRel++-- | Define a test for each file in the given directory, recursively.+--+-- Example:+--+-- >   scenarioDirRecur "test_resources/odd" $ \fp ->+-- >     it "contains an odd number" $ do+-- >       s <- readFile fp+-- >       n <- readIO s+-- >       (n :: Int) `shouldSatisfy` odd+scenarioDirRecur :: FilePath -> (FilePath -> TestDefM outers inner ()) -> TestDefM outers inner ()+scenarioDirRecur = scenarioDirHelper listDirRecurRel++scenarioDirHelper ::+  (Path Abs Dir -> IO ([Path Rel Dir], [Path Rel File])) ->+  FilePath ->+  (FilePath -> TestDefM outers inner ()) ->+  TestDefM outers inner ()+scenarioDirHelper lister dp func =+  describe dp $ do+    ad <- liftIO $ resolveDir' dp+    fs <- liftIO $ fmap (fromMaybe []) $ forgivingAbsence $ snd <$> lister ad+    forM_ fs $ \rf -> do+      let fp = dp FP.</> fromRelFile rf+      describe (fromRelFile rf) $ func fp

@@ -1,152 +1,108 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}  -- | The 'SetupFunc' abstraction makes resource provider functions (of type @(a -> IO r) -> IO r@) composable. module Test.Syd.Def.SetupFunc where -import Control.Category as Cat+import Control.Exception import Control.Monad.IO.Class import Test.Syd.Def.Around+import Test.Syd.Def.AroundAll import Test.Syd.Def.TestDefM import Test.Syd.HList --- | A function that can provide an 'new' given an 'old'.+-- * Creating 'SetupFunc's++-- | A function that can provide a 'resource'. ----- You can think of this as a potentially-resource-aware version of 'old -> IO new'.+-- You can think of this as a potentially-resource-aware version of 'IO resource'.+-- In other words, it's like an 'IO resource' that can clean up after itself. -- -- This type has a monad instance, which means you can now compose setup functions using regular do-notation.-newtype SetupFunc old new = SetupFunc-  { unSetupFunc :: forall r. (new -> IO r) -> (old -> IO r)+-- 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)+--+-- Note that these examples already have functions defined for them in sydtest companion libraries.+newtype SetupFunc resource = SetupFunc+  { unSetupFunc :: forall r. (resource -> IO r) -> IO r   } -instance Functor (SetupFunc old) where-  fmap f (SetupFunc provideA) = SetupFunc $ \takeB c ->+instance Functor SetupFunc where+  fmap f (SetupFunc provideA) = SetupFunc $ \takeB ->     let takeA = \a -> takeB $ f a-     in provideA takeA c+     in provideA takeA -instance Applicative (SetupFunc old) where-  pure a = SetupFunc $ \aFunc _ -> aFunc a-  (SetupFunc provideF) <*> (SetupFunc provideA) = SetupFunc $ \takeB c ->+instance Applicative SetupFunc where+  pure a = SetupFunc $ \aFunc -> aFunc a+  (SetupFunc provideF) <*> (SetupFunc provideA) = SetupFunc $ \takeB ->     provideF       ( \f ->           provideA             ( \a ->                 takeB (f a)             )-            c       )-      c -instance Monad (SetupFunc old) where-  (SetupFunc provideA) >>= m = SetupFunc $ \takeB c ->+instance Monad SetupFunc where+  (SetupFunc provideA) >>= m = SetupFunc $ \takeB ->     provideA       ( \a ->           let (SetupFunc provideB) = m a-           in provideB (\b -> takeB b) c+           in provideB (\b -> takeB b)       )-      c -instance MonadIO (SetupFunc old) where-  liftIO ioFunc = SetupFunc $ \takeA _ -> do+instance MonadIO SetupFunc 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 result. (resource -> IO result) -> IO result) ->-  SetupFunc () resource-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 () resource -> (forall result. (resource -> IO result) -> IO result)-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 ::-  (old -> SetupFunc () new) ->-  SetupFunc old new-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 old new -> (old -> SetupFunc () new)-unwrapSetupFunc (SetupFunc provideAWithB) b = SetupFunc $ \takeA () ->-  provideAWithB (\a -> takeA a) b---- | Compose two setup functions.------ This is '(.)' but for 'SetupFunc's-composeSetupFunc ::-  SetupFunc newer newest ->-  SetupFunc old newer ->-  SetupFunc old newest-composeSetupFunc (SetupFunc provideAWithB) (SetupFunc provideBWithC) = SetupFunc $ \takeA c ->-  provideBWithC-    ( \b ->-        provideAWithB-          ( \a -> takeA a-          )-          b-    )-    c+-- | Turn the arguments that you would normally give to 'bracket' into a 'SetupFunc'.+bracketSetupFunc :: IO resource -> (resource -> IO r) -> SetupFunc resource+bracketSetupFunc acquire release = SetupFunc $ \func -> bracket acquire release func --- | Connect two setup functions.------ This is basically 'flip (.)' but for 'SetupFunc's.--- It's exactly 'flip composeSetupFunc'.-connectSetupFunc ::-  SetupFunc old newer ->-  SetupFunc newer newest ->-  SetupFunc old newest-connectSetupFunc = flip composeSetupFunc+-- * Using 'SetupFunc' to define your test suite  -- | Use 'around' with a 'SetupFunc' setupAround ::-  SetupFunc () inner ->+  SetupFunc inner ->   TestDefM outers inner result ->   TestDefM outers () result-setupAround = setupAroundWith+setupAround setupFunc = setupAroundWith $ \() -> setupFunc  -- | Use 'aroundWith' with a 'SetupFunc' setupAroundWith ::-  SetupFunc oldInner newInner ->+  (oldInner -> SetupFunc newInner) ->   TestDefM outers newInner result ->   TestDefM outers oldInner result-setupAroundWith (SetupFunc f) = aroundWith f+setupAroundWith takeOldInner = aroundWith $ \takeNewInner oldInner ->+  let SetupFunc provideNewInner = takeOldInner oldInner+   in provideNewInner $ \newInner -> takeNewInner newInner  -- | Use 'aroundWith'' with a 'SetupFunc' setupAroundWith' ::   HContains outers outer =>-  (outer -> SetupFunc oldInner newInner) ->+  (outer -> oldInner -> SetupFunc newInner) ->   TestDefM outers newInner result ->   TestDefM outers oldInner result-setupAroundWith' setupFuncFunc = aroundWith' $ \takeAC a d ->-  let (SetupFunc provideCWithD) = setupFuncFunc a-   in provideCWithD (\c -> takeAC a c) d+setupAroundWith' f = aroundWith' $ \takeBoth outer oldInner ->+  let SetupFunc provideNewInner = f outer oldInner+   in provideNewInner $ \newInner -> takeBoth outer newInner++-- | Use 'aroundAll' with a 'SetupFunc'+setupAroundAll ::+  SetupFunc outer ->+  TestDefM (outer : outers) inner result ->+  TestDefM outers inner result+setupAroundAll sf = aroundAll $ \func -> unSetupFunc sf func++-- | Use 'aroundAllWith' with a 'SetupFunc'+setupAroundAllWith ::+  (oldOuter -> SetupFunc newOuter) ->+  TestDefM (newOuter ': oldOuter ': outers) inner result ->+  TestDefM (oldOuter ': outers) inner result+setupAroundAllWith sf = aroundAllWith $ \takeNewOuter oldOuter ->+  let SetupFunc provideNewOuter = sf oldOuter+   in provideNewOuter $ \newOuter -> takeNewOuter newOuter

@@ -23,6 +23,7 @@     specifyWithOuter,     specifyWithBoth,     specifyWithAll,+    prop,      -- ** Declaring commented-out tests     xdescribe,@@ -44,6 +45,7 @@ import Control.Monad.RWS.Strict import qualified Data.Text as T import GHC.Stack+import Test.QuickCheck import Test.QuickCheck.IO () import Test.Syd.Def.TestDefM import Test.Syd.HList@@ -482,10 +484,16 @@   TestDefM outers inner () xspecifyWithAll = xitWithAll +-- | Convenience function for backwards compatibility with @hspec@+--+-- > prop s p = it s $ property p+prop :: Testable prop => String -> prop -> Spec+prop s p = it s $ property p+ -- | Declare a test that has not been written yet. pending :: String -> TestDefM outers inner () 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 outers inner ()-pendingWith s reason = tell [DefPendingNode (T.pack s) (Just (T.pack reason))]+pendingWith description reasonWhyItsPending = tell [DefPendingNode (T.pack description) (Just (T.pack reasonWhyItsPending))]

@@ -38,7 +38,7 @@ type SpecM inner result = TestDefM '[] inner result  -- | A synonym for a test suite definition-type TestDef outer inner = TestDefM outer inner ()+type TestDef outers inner = TestDefM outers inner ()  -- | The test definition monad --

@@ -123,6 +123,9 @@ expectationFailure = throwIO . ExpectationFailed  -- | Annotate a given action with a context, for contextual assertions+--+-- This is a completely different function from the function with the same name in hspec.+-- In hspec, context is a synonym for describe, but in sydtest, context is used for contextual failures. context :: String -> IO a -> IO a context s action = (action >>= evaluate) `catch` (\a -> throwIO (Context a s)) 

@@ -12,7 +12,7 @@ import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as SBB import qualified Data.ByteString.Char8 as SB8-import Data.List+import qualified Data.List as L import Data.List.Split (splitWhen) import Data.Map (Map) import qualified Data.Map as M@@ -37,7 +37,7 @@ renderResultReport :: TerminalCapabilities -> Timed ResultForest -> Builder renderResultReport tc rf =   mconcat $-    intersperse (SBB.char7 '\n') $+    L.intersperse (SBB.char7 '\n') $       map (renderChunks tc) (outputResultReport rf)  outputResultReport :: Timed ResultForest -> [[Chunk]]@@ -69,14 +69,16 @@  outputStats :: Timed TestSuiteStats -> [[Chunk]] outputStats (Timed TestSuiteStats {..} timing) =-  let totalTimeSeconds :: Double+  let sumTimeSeconds :: Double+      sumTimeSeconds = fromIntegral testSuiteStatSumTime / 1_000_000_000+      totalTimeSeconds :: Double       totalTimeSeconds = fromIntegral timing / 1_000_000_000    in map (padding :) $         concat-          [ [ [ chunk "Passed:                   ",+          [ [ [ chunk "Passed:                       ",                 fore green $ chunk (T.pack (show testSuiteStatSuccesses))               ],-              [ chunk "Failed:                   ",+              [ chunk "Failed:                       ",                 ( if testSuiteStatFailures > 0                     then fore red                     else fore green@@ -84,26 +86,40 @@                   $ chunk (T.pack (show testSuiteStatFailures))               ]             ],-            [ [ chunk "Pending:                  ",+            [ [ 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+            concat+              [ let longestTimeSeconds :: Double+                    longestTimeSeconds = fromIntegral longestTestTime / 1_000_000_000+                    longestTimePercentage :: Double+                    longestTimePercentage = 100 * longestTimeSeconds / sumTimeSeconds+                    showLongestTestDetails = longestTimePercentage > 50+                 in filter+                      (not . null)+                      [ concat+                          [ [ "Longest test:                 ",+                              fore green $ chunk longestTestName+                            ]+                            | showLongestTestDetails+                          ],+                        concat+                          [ [ chunk "Longest test took:   ",+                              fore yellow $ chunk $ T.pack (printf "%13.2f seconds" longestTimeSeconds)+                            ],+                            [ chunk $ T.pack (printf ", which is %.0f%% of total runtime" longestTimePercentage)+                              | showLongestTestDetails+                            ]+                          ]                       ]-                    ]-              | longest <- maybeToList testSuiteStatLongestTime-            ],-            [ [ chunk "Test suite took  ",+                | (longestTestName, longestTestTime) <- maybeToList testSuiteStatLongestTime+              ],+            [ [ chunk "Sum of test runtimes:",+                fore yellow $ chunk $ T.pack (printf "%13.2f seconds" sumTimeSeconds)+              ],+              [ chunk "Test suite took:     ",                 fore yellow $ chunk $ T.pack (printf "%13.2f seconds" totalTimeSeconds)               ]             ]@@ -156,7 +172,9 @@             ],             [ pad                 [ chunk "passed for all of ",-                  fore green $ chunk (T.pack (printf "%d" w)),+                  case w of+                    0 -> fore red $ chunk "0"+                    _ -> fore green $ chunk (T.pack (printf "%d" w)),                   " inputs."                 ]               | testRunResultStatus == TestPassed,@@ -292,7 +310,7 @@ outputFailures rf =   let failures = filter testFailed $ flattenSpecForest rf       nbDigitsInFailureCount :: Int-      nbDigitsInFailureCount = floor (logBase 10 (genericLength failures) :: Double)+      nbDigitsInFailureCount = floor (logBase 10 (L.genericLength failures) :: Double)       padFailureDetails = (chunk (T.pack (replicate (nbDigitsInFailureCount + 4) ' ')) :)    in map (padding :) $         filter (not . null) $

@@ -0,0 +1,39 @@+module Test.Syd.Path where++import Data.ByteString (ByteString)+import qualified Data.ByteString as SB+import Path+import Path.IO+import System.IO+import Test.Syd.Def.SetupFunc+import Test.Syd.Def.TestDefM++-- | A test suite that has access to a temporary directory+tempDirSpec ::+  -- | Temporary directory name template+  String ->+  TestDefM outers (Path Abs Dir) result ->+  TestDefM outers () result+tempDirSpec template = setupAround $ tempDirSetupFunc template++-- | Setup function for a temporary directory+tempDirSetupFunc ::+  -- | Temporary directory name template+  String ->+  SetupFunc (Path Abs Dir)+tempDirSetupFunc template = SetupFunc $ withSystemTempDir template++tempBinaryFileWithContentsSetupFunc ::+  -- | Temporary directory name template+  String ->+  ByteString ->+  SetupFunc (Path Abs File)+tempBinaryFileWithContentsSetupFunc template contents = SetupFunc $ \func ->+  withSystemTempFile+    template+    ( \af h -> do+        SB.hPut h contents+        hFlush h+        hClose h+        func af+    )

@@ -29,8 +29,13 @@ import Text.Printf  class IsTest e where+  -- | The argument from 'aroundAll'   type Arg1 e++  -- | The argument from 'around'   type Arg2 e++  -- | Running the test, safely   runTest ::     e ->     TestRunSettings ->@@ -38,8 +43,8 @@     IO TestRunResult  instance IsTest Bool where-  type Arg1 Bool = () -- The argument from 'aroundAll'-  type Arg2 Bool = () -- The argument from 'around'+  type Arg1 Bool = ()+  type Arg2 Bool = ()   runTest func = runTest (\() () -> func)  instance IsTest (arg -> Bool) where@@ -57,7 +62,7 @@   TestRunSettings ->   ((outerArgs -> innerArg -> IO ()) -> IO ()) ->   IO TestRunResult-runPureTestWithArg computeBool TestRunSettings {..} wrapper = do+runPureTestWithArg computeBool TestRunSettings {} wrapper = do   let testRunResultNumTests = Nothing   resultBool <-     applyWrapper2 wrapper $@@ -110,7 +115,7 @@   TestRunSettings ->   ((outerArgs -> innerArg -> IO ()) -> IO ()) ->   IO TestRunResult-runIOTestWithArg func TestRunSettings {..} wrapper = do+runIOTestWithArg func TestRunSettings {} wrapper = do   let testRunResultNumTests = Nothing   result <- liftIO $     applyWrapper2 wrapper $@@ -143,21 +148,24 @@   type Arg2 (outerArgs -> innerArg -> Property) = innerArg   runTest = runPropertyTestWithArg +makeQuickCheckArgs :: TestRunSettings -> Args+makeQuickCheckArgs TestRunSettings {..} =+  stdArgs+    { replay = Just (mkQCGen testRunSettingSeed, 0),+      chatty = False,+      maxSuccess = testRunSettingMaxSuccess,+      maxDiscardRatio = testRunSettingMaxDiscardRatio,+      maxSize = testRunSettingMaxSize,+      maxShrinks = testRunSettingMaxShrinks+    }+ 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-          }+runPropertyTestWithArg p trs wrapper = do+  let qcargs = makeQuickCheckArgs trs   qcr <- quickCheckWithResult qcargs (aroundProperty wrapper p)   let testRunResultGoldenCase = Nothing   let testRunResultNumTests = Just $ fromIntegral $ numTests qcr@@ -219,10 +227,29 @@   action $ \a b -> reduceRose (r a b) >>= writeIORef ref   readIORef ref +-- | A golden test for output of type @a@.+--+-- The purpose of a golden test is to ensure that the output of a certain+-- process does not change even over time.+--+-- Golden tests can also be used to show how the output of a certain process+-- changes over time and force code reviewers to review the diff that they see+-- in the PR.+--+-- This works by saving a 'golden' output in the repository somewhere,+-- committing it, and then compare that golden output to the output that is+-- currently being produced. You can use `--golden-reset` to have sydtest+-- update the golden output by writing the current output. data GoldenTest a = GoldenTest-  { goldenTestRead :: IO (Maybe a),+  { -- | Read the golden test output, 'Nothing' if there is no golden output yet.+    goldenTestRead :: IO (Maybe a),+    -- | Produce the current output     goldenTestProduce :: IO a,+    -- | Write golden output     goldenTestWrite :: a -> IO (),+    -- | Compare golden output with current output+    --+    -- The first argument is the current output, the second is the golden output     goldenTestCompare :: a -> a -> Maybe Assertion   } @@ -347,6 +374,11 @@ data TestStatus = TestPassed | TestFailed   deriving (Show, Eq, Generic) +-- | A special exception that sydtest knows about and can display nicely in the error output+--+-- This is exported outwards so that you can define golden tests for custom types.+--+-- You will probably not want to use this directly in everyday tests, use `shouldBe` or a similar function instead. data Assertion   = NotEqualButShouldHaveBeenEqual String String   | EqualButShouldNotHaveBeenEqual String String

@@ -26,6 +26,7 @@ import Test.Syd.Runner.Synchronous import Test.Syd.SpecDef import Text.Colour+import Text.Colour.Capabilities.FromEnv import Text.Printf  sydTestResult :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest)

@@ -7,6 +7,7 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -17,6 +18,7 @@  import Data.Kind import Data.Text (Text)+import qualified Data.Text as T import Data.Word import GHC.Stack import Test.QuickCheck.IO ()@@ -164,13 +166,13 @@ type ResultTree = SpecTree (TDef (Timed TestRunResult))  computeTestSuiteStats :: ResultForest -> TestSuiteStats-computeTestSuiteStats = goF+computeTestSuiteStats = goF []   where-    goF :: ResultForest -> TestSuiteStats-    goF = foldMap goT-    goT :: ResultTree -> TestSuiteStats-    goT = \case-      SpecifyNode _ (TDef (Timed TestRunResult {..} t) _) ->+    goF :: [Text] -> ResultForest -> TestSuiteStats+    goF ts = foldMap (goT ts)+    goT :: [Text] -> ResultTree -> TestSuiteStats+    goT ts = \case+      SpecifyNode tn (TDef (Timed TestRunResult {..} t) _) ->         TestSuiteStats           { testSuiteStatSuccesses = case testRunResultStatus of               TestPassed -> 1@@ -179,23 +181,26 @@               TestPassed -> 0               TestFailed -> 1,             testSuiteStatPending = 0,-            testSuiteStatLongestTime = Just t+            testSuiteStatSumTime = t,+            testSuiteStatLongestTime = Just (T.intercalate "." (ts ++ [tn]), t)           }       PendingNode _ _ ->         TestSuiteStats           { testSuiteStatSuccesses = 0,             testSuiteStatFailures = 0,             testSuiteStatPending = 1,+            testSuiteStatSumTime = 0,             testSuiteStatLongestTime = Nothing           }-      DescribeNode _ sf -> goF sf-      SubForestNode sf -> goF sf+      DescribeNode t sf -> goF (t : ts) sf+      SubForestNode sf -> goF ts sf  data TestSuiteStats = TestSuiteStats   { testSuiteStatSuccesses :: !Word,     testSuiteStatFailures :: !Word,     testSuiteStatPending :: !Word,-    testSuiteStatLongestTime :: !(Maybe Word64)+    testSuiteStatSumTime :: !Word64,+    testSuiteStatLongestTime :: !(Maybe (Text, Word64))   }   deriving (Show, Eq) @@ -205,11 +210,12 @@       { testSuiteStatSuccesses = testSuiteStatSuccesses tss1 + testSuiteStatSuccesses tss2,         testSuiteStatFailures = testSuiteStatFailures tss1 + testSuiteStatFailures tss2,         testSuiteStatPending = testSuiteStatPending tss1 + testSuiteStatPending tss2,+        testSuiteStatSumTime = testSuiteStatSumTime tss1 + testSuiteStatSumTime 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)+          (Just (tn1, t1), Just (tn2, t2)) -> Just $ if t1 >= t2 then (tn1, t1) else (tn2, t2)       }  instance Monoid TestSuiteStats where@@ -219,6 +225,7 @@       { testSuiteStatSuccesses = 0,         testSuiteStatFailures = 0,         testSuiteStatPending = 0,+        testSuiteStatSumTime = 0,         testSuiteStatLongestTime = Nothing       } 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           sydtest-version:        0.1.0.0+version:        0.2.0.0 synopsis:       A modern testing framework for Haskell with good defaults and advanced testing features. description:    A 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@@ -30,6 +30,7 @@       Test.Syd.Def.AroundAll       Test.Syd.Def.Env       Test.Syd.Def.Golden+      Test.Syd.Def.Scenario       Test.Syd.Def.SetupFunc       Test.Syd.Def.Specify       Test.Syd.Def.TestDefM@@ -38,6 +39,7 @@       Test.Syd.Modify       Test.Syd.OptParse       Test.Syd.Output+      Test.Syd.Path       Test.Syd.Run       Test.Syd.Runner       Test.Syd.Runner.Asynchronous@@ -59,6 +61,7 @@     , containers     , dlist     , envparse+    , filepath     , mtl     , optparse-applicative     , path@@ -68,6 +71,7 @@     , random-shuffle     , safe     , safe-coloured-text+    , safe-coloured-text-terminfo     , split     , text     , yaml@@ -89,6 +93,7 @@     , path     , path-io     , safe-coloured-text+    , safe-coloured-text-terminfo     , sydtest     , text   default-language: Haskell2010@@ -102,6 +107,8 @@       Test.Syd.AroundSpec       Test.Syd.FootgunSpec       Test.Syd.GoldenSpec+      Test.Syd.PathSpec+      Test.Syd.ScenarioSpec       Test.Syd.Specify.AllOuterSpec       Test.Syd.SpecifySpec       Test.Syd.TimingSpec

@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.PathSpec (spec) where++import qualified Data.ByteString as SB+import Path+import Path.IO+import Test.Syd+import Test.Syd.Path++spec :: Spec+spec = do+  describe "tempDirSpec" $+    tempDirSpec "sydtest-path" $ do+      it "can write a file to a temporary dir and read it" $ \tdir -> do+        tempFile <- resolveFile tdir "tempfile.dat"+        SB.writeFile (fromAbsFile tempFile) "hello"+        contents <- SB.readFile (fromAbsFile tempFile)+        contents `shouldBe` "hello"+      describe "clean state" $+        doNotRandomiseExecutionOrder $ do+          it "can write a file to a temporary dir" $ \tdir -> do+            tempFile <- resolveFile tdir "tempfile.dat"+            SB.writeFile (fromAbsFile tempFile) "hello"+          it "cannot read a file that hasn't been written" $ \tdir -> do+            tempFile <- resolveFile tdir "tempfile.dat"+            contents <- forgivingAbsence $ SB.readFile (fromAbsFile tempFile)+            contents `shouldBe` Nothing

@@ -0,0 +1,16 @@+module Test.Syd.ScenarioSpec (spec) where++import Test.Syd++spec :: Spec+spec = do+  scenarioDir "test_resources/even" $ \rf ->+    it "contains an even number" $ do+      s <- readFile rf+      n <- readIO s+      (n :: Int) `shouldSatisfy` even+  scenarioDirRecur "test_resources/odd" $ \rf ->+    it "contains an odd number" $ do+      s <- readFile rf+      n <- readIO s+      (n :: Int) `shouldSatisfy` odd