test-framework-sandbox 0.0.2.4 → 0.0.2.5

raw patch · 3 files changed

+93/−2 lines, 3 filesdep +HUnitdep +test-framework-sandboxdep +test-sandbox-hunitdep ~test-sandboxPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: HUnit, test-framework-sandbox, test-sandbox-hunit

Dependency ranges changed: test-sandbox

API changes (from Hackage documentation)

Files

• src/Test/Framework/Providers/Sandbox.hs +31/−0
• test-framework-sandbox.cabal +13/−2
• test/test.hs +49/−0

@@ -21,6 +21,7 @@   , sandboxTestGroup   , sandboxTestGroup'   , yieldProgress+  , withRetry   ) where  import Control.Exception.Lifted@@ -34,6 +35,7 @@  import Test.Framework import Test.Framework.Providers.API (Test (..))+import Data.Typeable  import Test.Sandbox import Test.Sandbox.Internals hiding (putOptions)@@ -107,6 +109,35 @@   unless (null pl) $ liftIO $ putStr " / "   _ <- setVariable prettyPrintVariable (p : pl)   liftIO $ putStrColor Dull Blue p >> hFlush stdout++class SandboxRetry a where+  withRetry :: Int -> Sandbox a -> Sandbox a++instance SandboxRetry Test where+  withRetry num action =+    if num <= 1+      then action+      else do+        res <- action+        if isPassed res+          then return res+          else withRetry (num - 1) action++isPassed :: Test -> Bool+isPassed test =+  case test of+    (Test _ res') ->+      case cast res' of+        (Just (SandboxTest Passed)) -> True+        _ -> False+    (TestGroup _ tests) -> and $ map isPassed tests+    _ -> error "withRetry does not support this test-type."++instance SandboxRetry () where+  withRetry num action =+    if num <= 1+      then action+      else action `catchError` (\_ -> withRetry (num - 1) action)  ---------------------------------------------------------------------- -- Docs

@@ -1,5 +1,5 @@ Name:           test-framework-sandbox-Version:        0.0.2.4+Version:        0.0.2.5 Cabal-Version:  >= 1.14 Category:       Testing Synopsis:       test-sandbox support for the test-framework package@@ -29,7 +29,7 @@ Source-Repository this     Type:       git     Location:   https://github.com/gree/haskell-test-sandbox-    Tag:        test-framework-sandbox_0.0.2.4+    Tag:        test-framework-sandbox_0.0.2.5  Library     Exposed-modules:    Test.Framework.Providers.Sandbox@@ -44,3 +44,14 @@     Default-Language:   Haskell2010      ghc-options:       -Wall++Test-Suite test+  Ghc-Options:     -threaded+  Type:            exitcode-stdio-1.0+  Build-Depends:   base >=4 && <5+                 , HUnit+                 , test-framework >= 0.8.0.3+                 , test-framework-sandbox == 0.0.2.*+                 , test-sandbox == 0.0.1.*+                 , test-sandbox-hunit == 0.0.1.*+  Main-Is:         test/test.hs

@@ -0,0 +1,49 @@+import Test.Framework.Providers.Sandbox (sandboxTests, sandboxTest, sandboxTestGroup, yieldProgress, withRetry)+import Test.Sandbox+import Test.Framework+import Test.Sandbox.HUnit (assertEqual)+import Data.IORef++main :: IO ()+main = defaultMain [ allCases ]+      ++retryTest1 :: Sandbox Test+retryTest1 = sandboxTestGroup "retryTest(inside of testGroup)" [+  sandboxTest "retry" $ do+    val <- liftIO $ newIORef 0+    withRetry 10 $ do+      val' <- liftIO $ readIORef val+      liftIO $ writeIORef val (val'+1)+      assertEqual "retry 10(single)" 9 val'+    withRetry 2 $ do+      withRetry 3 $ do+        val' <- liftIO $ readIORef val+        liftIO $ writeIORef val (val'+1)+        assertEqual "retry 6(double loop)" 15 val'+  ]+              ++retryTest2 :: Sandbox Test+retryTest2 = do+  val <- liftIO $ newIORef 0+  val2 <- liftIO $ newIORef 0+  withRetry 10 $+    sandboxTestGroup "retryTest(outside of testGroup)" [+      sandboxTest "retry" $ do+        val' <- liftIO $ readIORef val+        liftIO $ writeIORef val (val'+1)+        assertEqual "retry 10(single)" 9 val'+    , sandboxTest "retry2" $ do+        val2' <- liftIO $ readIORef val2+        liftIO $ writeIORef val2 (val2'+1)+        assertEqual "retry 10(single)" 9 val2'+    ]+              ++allCases :: Test+allCases = sandboxTests "framework-test" [+       retryTest1+     , retryTest2+   ]+