test-framework-smallcheck 0.1.1 → 0.2

raw patch · 2 files changed

+58/−26 lines, 2 filesdep +transformersdep ~smallcheck

Dependencies added: transformers

Dependency ranges changed: smallcheck

Files

• Test/Framework/Providers/SmallCheck.hs +53/−22
• test-framework-smallcheck.cabal +5/−4

@@ -7,21 +7,30 @@ -- -- This module allows to use SmallCheck properties in test-framework. ---------------------------------------------------------------------{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,+             TypeOperators #-} module Test.Framework.Providers.SmallCheck     ( testProperty     , withDepth     ) where  import Test.Framework.Providers.API-import qualified Test.SmallCheck.Property as SC+import qualified Test.SmallCheck as SC+import qualified Test.SmallCheck.Drivers as SC+import Test.SmallCheck.Drivers import Data.Maybe import Data.List import Data.Monoid+import Data.IORef+import qualified Control.Monad.IO.Class as T+import System.Timeout+import Control.Concurrent.Chan+import Control.Applicative  -- | Create a 'Test' for a SmallCheck 'SC.Testable' property-testProperty :: SC.Testable a => TestName -> a -> Test-testProperty name prop = Test name $ SC.property prop+-- testProperty :: TestName -> (forall m . T.MonadIO m => SC.Testable m a) -> Test+testProperty :: SC.Testable IO a => TestName -> a -> Test+testProperty name prop = Test name $ (SC.test prop :: SC.Property IO)  -- | Change the default maximum test depth for a given 'Test'. --@@ -32,32 +41,54 @@ data Result     = Timeout     | Pass-    | Fail [String]+    | Fail SC.PropertyFailure  instance Show Result where     show Timeout  = "Timed out"     show Pass     = "OK"-    show (Fail s) =-        intercalate "\n" $ "Failed with arguments: " : s+    show (Fail s) = ppFailure s  instance TestResultlike Int Result where     testSucceeded Pass = True     testSucceeded _    = False -instance Testlike Int Result SC.Property where-    testTypeName _ = "Properties"+instance Testlike Int Result (SC.Property IO) where+  testTypeName _ = "Properties" -    runTest topts prop = runImprovingIO $ do-        let timeout = unK $ topt_timeout topts-            depth   = unK $ topt_maximum_test_depth topts-        mb_result <- maybeTimeoutImprovingIO timeout $-            runSmallCheck prop depth-        return $ fromMaybe Timeout mb_result+  runTest topts prop = do+    let+      timeoutAmount = unK $ topt_timeout topts+      depth = unK $ topt_maximum_test_depth topts -runSmallCheck :: SC.Property -> SC.Depth -> ImprovingIO Int f Result-runSmallCheck prop depth = foldr go (const $ return Pass) (SC.test prop depth) 1-    where-    go test rest n =-        if SC.resultIsOk (SC.result test)-            then yieldImprovement n >> (rest $! n+1)-            else return $ Fail $ SC.arguments test+    chan <- newChan++    -- Execute the test, writing () to the channel after completion of each+    -- individual test+    let+      action = do+        mb_result <- timeout (fromMaybe (-1) timeoutAmount) $ smallCheckWithHook depth (const $ writeChan chan (Left ())) prop+        writeChan chan $ Right $+          case mb_result of+            Nothing -> Timeout+            Just Nothing -> Pass+            Just (Just x) -> Fail x++    improving <- reifyListToImproving . accumulate <$> getChanContents chan++    return (improving, action)++accumulate :: [Either () a] -> [Either Int a]+accumulate xs =+  (\f -> snd $ mapAccumL f 0 xs) $+  \n e ->+    case e of+      Left {} ->+        let n' = n+1+        in n' `seq` (n', Left n')+      Right x -> (n, Right x)++-- Copy-pasted from test-framework (because it's not exported)+reifyListToImproving :: [Either i f] -> (i :~> f)+reifyListToImproving (Left improvement:rest) = Improving improvement (reifyListToImproving rest)+reifyListToImproving (Right final:_)         = Finished final+reifyListToImproving []                      = error "reifyListToImproving: list finished before a final value arrived"

@@ -1,5 +1,5 @@ Name:                test-framework-smallcheck-Version:             0.1.1+Version:             0.2 Cabal-Version:       >= 1.6 Category:            Testing Synopsis:            SmallCheck support for the test-framework package.@@ -22,12 +22,13 @@ Source-repository this   type:     git   location: git://github.com/feuerbach/smallcheck.git-  tag:      testframework-v0.1+  tag:      testframework-v0.2   subdir:   test-framework-smallcheck  Library         Exposed-Modules:        Test.Framework.Providers.SmallCheck          Build-Depends:          test-framework >= 0.4.2.0 && < 1.0,-                                smallcheck >= 0.6,-                                base >= 4 && < 5+                                smallcheck >= 1.0,+                                base >= 4 && < 5,+                                transformers