2016-04-29 01:00:33 +03:00
|
|
|
{-# LANGUAGE CPP #-}
|
2017-06-07 16:02:40 +03:00
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
2016-04-29 01:00:33 +03:00
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
2015-10-08 14:05:59 +03:00
|
|
|
{-# LANGUAGE RankNTypes #-}
|
2016-04-29 01:00:33 +03:00
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
2015-10-08 14:05:59 +03:00
|
|
|
|
2017-10-21 09:19:47 +03:00
|
|
|
#if MIN_TOOL_VERSION_ghc(8,0,0)
|
2016-05-26 15:54:13 +03:00
|
|
|
-- Impredicative polymorphism checks got stronger in GHC 8, breaking
|
|
|
|
-- the use of 'unsafeCoerce' below.
|
|
|
|
{-# LANGUAGE ImpredicativeTypes #-}
|
|
|
|
#endif
|
|
|
|
|
2016-08-26 13:16:59 +03:00
|
|
|
-- |
|
|
|
|
-- Module : Test.HUnit.DejaFu
|
2017-02-20 06:02:33 +03:00
|
|
|
-- Copyright : (c) 2017 Michael Walker
|
2016-08-26 13:16:59 +03:00
|
|
|
-- License : MIT
|
|
|
|
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
|
|
|
|
-- Stability : stable
|
2017-06-07 16:02:40 +03:00
|
|
|
-- Portability : CPP, FlexibleContexts, FlexibleInstances, ImpredicativeTypes, RankNTypes, ScopedTypeVariables, TypeSynonymInstances
|
2016-08-26 13:16:59 +03:00
|
|
|
--
|
|
|
|
-- This module allows using Deja Fu predicates with HUnit to test the
|
|
|
|
-- behaviour of concurrent systems.
|
2015-10-08 14:05:59 +03:00
|
|
|
module Test.HUnit.DejaFu
|
2016-04-29 01:00:33 +03:00
|
|
|
( -- * Unit testing
|
|
|
|
|
|
|
|
-- | This is supported by the 'Assertable' and 'Testable'
|
|
|
|
-- instances for 'ConcST' and 'ConcIO'. These instances try all
|
|
|
|
-- executions, reporting as failures the cases which throw an
|
|
|
|
-- 'HUnitFailure' exception.
|
|
|
|
--
|
|
|
|
-- @instance Testable (ConcST t ())@
|
|
|
|
-- @instance Assertable (ConcST t ())@
|
|
|
|
-- @instance Testable (ConcIO ())@
|
|
|
|
-- @instance Assertable (ConcIO ())@
|
|
|
|
--
|
2017-02-20 06:02:33 +03:00
|
|
|
-- These instances use 'defaultWay' and 'defaultMemType'.
|
2016-04-29 01:00:33 +03:00
|
|
|
|
2017-06-07 16:02:40 +03:00
|
|
|
-- * Unit testing
|
2015-10-08 14:05:59 +03:00
|
|
|
testAuto
|
|
|
|
, testDejafu
|
|
|
|
, testDejafus
|
2016-04-29 01:00:33 +03:00
|
|
|
|
2017-02-20 06:02:33 +03:00
|
|
|
, testAutoWay
|
|
|
|
, testDejafuWay
|
|
|
|
, testDejafusWay
|
2016-04-29 01:00:33 +03:00
|
|
|
|
2017-08-10 18:24:48 +03:00
|
|
|
, testDejafuDiscard
|
|
|
|
|
2016-04-29 01:00:33 +03:00
|
|
|
-- ** @IO@
|
2015-10-08 14:05:59 +03:00
|
|
|
, testAutoIO
|
|
|
|
, testDejafuIO
|
|
|
|
, testDejafusIO
|
|
|
|
|
2017-02-20 06:02:33 +03:00
|
|
|
, testAutoWayIO
|
|
|
|
, testDejafuWayIO
|
|
|
|
, testDejafusWayIO
|
2016-04-29 01:00:33 +03:00
|
|
|
|
2017-08-10 18:24:48 +03:00
|
|
|
, testDejafuDiscardIO
|
|
|
|
|
2017-06-07 16:02:40 +03:00
|
|
|
-- ** Re-exports
|
2017-05-27 18:15:51 +03:00
|
|
|
, Way
|
|
|
|
, defaultWay
|
|
|
|
, systematically
|
|
|
|
, randomly
|
2017-05-28 06:02:59 +03:00
|
|
|
, uniformly
|
2017-05-27 18:43:14 +03:00
|
|
|
, swarmy
|
2016-04-29 01:00:33 +03:00
|
|
|
, Bounds(..)
|
2017-05-27 18:15:51 +03:00
|
|
|
, defaultBounds
|
2016-04-29 01:00:33 +03:00
|
|
|
, MemType(..)
|
2017-05-27 18:15:51 +03:00
|
|
|
, defaultMemType
|
2017-08-10 18:24:48 +03:00
|
|
|
, Discard(..)
|
|
|
|
, defaultDiscarder
|
2017-06-07 16:02:40 +03:00
|
|
|
|
|
|
|
-- * Refinement property testing
|
|
|
|
, testProperty
|
|
|
|
|
|
|
|
-- ** Re-exports
|
|
|
|
, R.Sig(..)
|
|
|
|
, R.RefinementProperty
|
|
|
|
, R.Testable(..)
|
|
|
|
, R.Listable(..)
|
|
|
|
, R.expectFailure
|
|
|
|
, R.refines, (R.=>=)
|
|
|
|
, R.strictlyRefines, (R.->-)
|
|
|
|
, R.equivalentTo, (R.===)
|
2015-10-08 14:05:59 +03:00
|
|
|
) where
|
|
|
|
|
2017-06-07 16:02:40 +03:00
|
|
|
import Control.Monad.Catch (try)
|
|
|
|
import Control.Monad.ST (runST)
|
|
|
|
import qualified Data.Foldable as F
|
|
|
|
import Data.List (intercalate, intersperse)
|
2017-06-07 16:08:34 +03:00
|
|
|
import Test.DejaFu hiding (Testable(..))
|
2017-06-07 16:02:40 +03:00
|
|
|
import qualified Test.DejaFu.Conc as Conc
|
|
|
|
import qualified Test.DejaFu.Refinement as R
|
|
|
|
import qualified Test.DejaFu.SCT as SCT
|
|
|
|
import Test.HUnit (Assertable(..), Test(..), Testable(..),
|
|
|
|
assertFailure, assertString)
|
|
|
|
import Test.HUnit.Lang (HUnitFailure(..))
|
2016-06-22 13:20:22 +03:00
|
|
|
|
|
|
|
-- Can't put the necessary forall in the @Assertable Conc.ConcST t@
|
2016-04-29 01:00:33 +03:00
|
|
|
-- instance :(
|
2017-06-07 16:02:40 +03:00
|
|
|
import Unsafe.Coerce (unsafeCoerce)
|
2016-04-29 01:00:33 +03:00
|
|
|
|
2017-08-10 18:24:48 +03:00
|
|
|
runSCTst :: (Either Failure a -> Maybe Discard) -> Way -> MemType -> (forall t. Conc.ConcST t a) -> [(Either Failure a, Conc.Trace)]
|
|
|
|
runSCTst discard way memtype conc = runST (SCT.runSCTDiscard discard way memtype conc)
|
2016-05-12 20:21:01 +03:00
|
|
|
|
2017-08-10 18:24:48 +03:00
|
|
|
runSCTio :: (Either Failure a -> Maybe Discard) -> Way -> MemType -> Conc.ConcIO a -> IO [(Either Failure a, Conc.Trace)]
|
|
|
|
runSCTio = SCT.runSCTDiscard
|
2016-05-12 20:21:01 +03:00
|
|
|
|
2015-10-08 14:05:59 +03:00
|
|
|
--------------------------------------------------------------------------------
|
2017-06-07 16:02:40 +03:00
|
|
|
-- HUnit-style unit testing
|
2016-04-29 01:00:33 +03:00
|
|
|
|
2017-04-08 21:51:09 +03:00
|
|
|
-- | @since 0.3.0.0
|
2016-06-22 13:20:22 +03:00
|
|
|
instance Testable (Conc.ConcST t ()) where
|
2016-04-29 01:00:33 +03:00
|
|
|
test conc = TestCase (assert conc)
|
|
|
|
|
2017-04-08 21:51:09 +03:00
|
|
|
-- | @since 0.3.0.0
|
2016-06-22 13:20:22 +03:00
|
|
|
instance Testable (Conc.ConcIO ()) where
|
2016-04-29 01:00:33 +03:00
|
|
|
test conc = TestCase (assert conc)
|
|
|
|
|
2017-04-08 21:51:09 +03:00
|
|
|
-- | @since 0.3.0.0
|
2016-06-22 13:20:22 +03:00
|
|
|
instance Assertable (Conc.ConcST t ()) where
|
2016-04-29 01:00:33 +03:00
|
|
|
assert conc = do
|
2017-02-20 06:02:33 +03:00
|
|
|
let traces = runSCTst' conc'
|
2016-04-29 01:00:33 +03:00
|
|
|
assertString . showErr $ assertableP traces
|
|
|
|
|
|
|
|
where
|
2016-06-22 13:20:22 +03:00
|
|
|
conc' :: Conc.ConcST t (Either HUnitFailure ())
|
2016-04-29 01:00:33 +03:00
|
|
|
conc' = try conc
|
|
|
|
|
2017-02-20 06:02:33 +03:00
|
|
|
runSCTst' :: Conc.ConcST t (Either HUnitFailure ()) -> [(Either Failure (Either HUnitFailure ()), Conc.Trace)]
|
2017-08-10 18:24:48 +03:00
|
|
|
runSCTst' = unsafeCoerce $ runSCTst (const Nothing) defaultWay defaultMemType
|
2016-04-29 01:00:33 +03:00
|
|
|
|
2017-04-08 21:51:09 +03:00
|
|
|
-- | @since 0.3.0.0
|
2016-06-22 13:20:22 +03:00
|
|
|
instance Assertable (Conc.ConcIO ()) where
|
2016-04-29 01:00:33 +03:00
|
|
|
assert conc = do
|
2017-08-10 18:24:48 +03:00
|
|
|
traces <- runSCTio (const Nothing) defaultWay defaultMemType (try conc)
|
2016-04-29 01:00:33 +03:00
|
|
|
assertString . showErr $ assertableP traces
|
|
|
|
|
|
|
|
assertableP :: Predicate (Either HUnitFailure ())
|
|
|
|
assertableP = alwaysTrue $ \r -> case r of
|
2017-04-08 00:50:30 +03:00
|
|
|
Right (Left HUnitFailure {}) -> False
|
2016-04-29 01:00:33 +03:00
|
|
|
_ -> True
|
|
|
|
|
2017-06-07 16:02:40 +03:00
|
|
|
|
2016-04-29 01:00:33 +03:00
|
|
|
--------------------------------------------------------------------------------
|
2017-06-07 16:02:40 +03:00
|
|
|
-- DejaFu-style unit testing
|
2015-10-08 14:05:59 +03:00
|
|
|
|
|
|
|
-- | Automatically test a computation. In particular, look for
|
|
|
|
-- deadlocks, uncaught exceptions, and multiple return values.
|
2016-06-20 23:45:34 +03:00
|
|
|
--
|
2015-10-08 14:05:59 +03:00
|
|
|
-- This uses the 'Conc' monad for testing, which is an instance of
|
|
|
|
-- 'MonadConc'. If you need to test something which also uses
|
|
|
|
-- 'MonadIO', use 'testAutoIO'.
|
2017-04-08 21:51:09 +03:00
|
|
|
--
|
|
|
|
-- @since 0.2.0.0
|
2015-10-08 14:05:59 +03:00
|
|
|
testAuto :: (Eq a, Show a)
|
2016-06-22 13:20:22 +03:00
|
|
|
=> (forall t. Conc.ConcST t a)
|
2015-10-08 14:05:59 +03:00
|
|
|
-- ^ The computation to test
|
2015-10-08 23:09:48 +03:00
|
|
|
-> Test
|
2017-02-20 06:02:33 +03:00
|
|
|
testAuto = testAutoWay defaultWay defaultMemType
|
2015-10-08 14:05:59 +03:00
|
|
|
|
|
|
|
-- | Variant of 'testAuto' which tests a computation under a given
|
2017-02-20 06:02:33 +03:00
|
|
|
-- execution way and memory model.
|
2017-04-08 21:51:09 +03:00
|
|
|
--
|
2017-04-08 23:15:32 +03:00
|
|
|
-- @since 0.5.0.0
|
2017-02-26 05:51:36 +03:00
|
|
|
testAutoWay :: (Eq a, Show a)
|
|
|
|
=> Way
|
2017-02-20 06:02:33 +03:00
|
|
|
-- ^ How to execute the concurrent program.
|
|
|
|
-> MemType
|
2015-10-08 14:05:59 +03:00
|
|
|
-- ^ The memory model to use for non-synchronised @CRef@ operations.
|
2016-06-22 13:20:22 +03:00
|
|
|
-> (forall t. Conc.ConcST t a)
|
2015-10-08 14:05:59 +03:00
|
|
|
-- ^ The computation to test
|
2015-10-08 23:09:48 +03:00
|
|
|
-> Test
|
2017-02-20 06:02:33 +03:00
|
|
|
testAutoWay way memtype conc =
|
|
|
|
testDejafusWay way memtype conc autocheckCases
|
2015-10-08 14:05:59 +03:00
|
|
|
|
|
|
|
-- | Variant of 'testAuto' for computations which do 'IO'.
|
2017-04-08 21:51:09 +03:00
|
|
|
--
|
|
|
|
-- @since 0.2.0.0
|
2016-06-22 13:20:22 +03:00
|
|
|
testAutoIO :: (Eq a, Show a) => Conc.ConcIO a -> Test
|
2017-02-20 06:02:33 +03:00
|
|
|
testAutoIO = testAutoWayIO defaultWay defaultMemType
|
2015-10-08 14:05:59 +03:00
|
|
|
|
2017-02-20 06:02:33 +03:00
|
|
|
-- | Variant of 'testAutoWay' for computations which do 'IO'.
|
2017-04-08 21:51:09 +03:00
|
|
|
--
|
2017-04-08 23:15:32 +03:00
|
|
|
-- @since 0.5.0.0
|
2017-02-26 05:51:36 +03:00
|
|
|
testAutoWayIO :: (Eq a, Show a)
|
|
|
|
=> Way -> MemType -> Conc.ConcIO a -> Test
|
2017-02-20 06:02:33 +03:00
|
|
|
testAutoWayIO way memtype concio =
|
|
|
|
testDejafusWayIO way memtype concio autocheckCases
|
2015-10-08 14:05:59 +03:00
|
|
|
|
|
|
|
-- | Predicates for the various autocheck functions.
|
2015-10-08 17:15:13 +03:00
|
|
|
autocheckCases :: Eq a => [(String, Predicate a)]
|
|
|
|
autocheckCases =
|
2015-11-12 17:55:54 +03:00
|
|
|
[("Never Deadlocks", representative deadlocksNever)
|
|
|
|
, ("No Exceptions", representative exceptionsNever)
|
2015-10-08 17:15:13 +03:00
|
|
|
, ("Consistent Result", alwaysSame)
|
|
|
|
]
|
2015-10-08 14:05:59 +03:00
|
|
|
|
|
|
|
-- | Check that a predicate holds.
|
2017-04-08 21:51:09 +03:00
|
|
|
--
|
|
|
|
-- @since 0.2.0.0
|
2015-10-25 20:05:40 +03:00
|
|
|
testDejafu :: Show a
|
2016-06-22 13:20:22 +03:00
|
|
|
=> (forall t. Conc.ConcST t a)
|
2015-10-08 14:05:59 +03:00
|
|
|
-- ^ The computation to test
|
2015-10-08 17:15:13 +03:00
|
|
|
-> String
|
|
|
|
-- ^ The name of the test.
|
2015-10-08 14:05:59 +03:00
|
|
|
-> Predicate a
|
|
|
|
-- ^ The predicate to check
|
2015-10-08 23:09:48 +03:00
|
|
|
-> Test
|
2017-02-20 06:02:33 +03:00
|
|
|
testDejafu = testDejafuWay defaultWay defaultMemType
|
|
|
|
|
|
|
|
-- | Variant of 'testDejafu' which takes a way to execute the program
|
|
|
|
-- and a memory model.
|
2017-04-08 21:51:09 +03:00
|
|
|
--
|
2017-04-08 23:15:32 +03:00
|
|
|
-- @since 0.5.0.0
|
2017-02-26 05:51:36 +03:00
|
|
|
testDejafuWay :: Show a
|
|
|
|
=> Way
|
2017-02-20 06:02:33 +03:00
|
|
|
-- ^ How to execute the concurrent program.
|
|
|
|
-> MemType
|
2015-10-08 17:45:05 +03:00
|
|
|
-- ^ The memory model to use for non-synchronised @CRef@ operations.
|
2016-06-22 13:20:22 +03:00
|
|
|
-> (forall t. Conc.ConcST t a)
|
2015-10-08 17:45:05 +03:00
|
|
|
-- ^ The computation to test
|
|
|
|
-> String
|
|
|
|
-- ^ The name of the test.
|
|
|
|
-> Predicate a
|
|
|
|
-- ^ The predicate to check
|
2015-10-08 23:09:48 +03:00
|
|
|
-> Test
|
2017-08-10 18:24:48 +03:00
|
|
|
testDejafuWay = testDejafuDiscard (const Nothing)
|
|
|
|
|
|
|
|
-- | Variant of 'testDejafuWay' which can selectively discard results.
|
|
|
|
--
|
2017-08-10 23:51:11 +03:00
|
|
|
-- @since 0.7.0.0
|
2017-08-10 18:24:48 +03:00
|
|
|
testDejafuDiscard :: Show a
|
|
|
|
=> (Either Failure a -> Maybe Discard)
|
|
|
|
-- ^ Selectively discard results.
|
|
|
|
-> Way
|
|
|
|
-- ^ How to execute the concurrent program.
|
|
|
|
-> MemType
|
|
|
|
-- ^ The memory model to use for non-synchronised @CRef@ operations.
|
|
|
|
-> (forall t. Conc.ConcST t a)
|
|
|
|
-- ^ The computation to test
|
|
|
|
-> String
|
|
|
|
-- ^ The name of the test.
|
|
|
|
-> Predicate a
|
|
|
|
-- ^ The predicate to check
|
|
|
|
-> Test
|
|
|
|
testDejafuDiscard discard way memtype conc name test =
|
|
|
|
testst discard way memtype conc [(name, test)]
|
2015-10-08 14:05:59 +03:00
|
|
|
|
|
|
|
-- | Variant of 'testDejafu' which takes a collection of predicates to
|
|
|
|
-- test. This will share work between the predicates, rather than
|
|
|
|
-- running the concurrent computation many times for each predicate.
|
2017-04-08 21:51:09 +03:00
|
|
|
--
|
|
|
|
-- @since 0.2.0.0
|
2015-10-25 20:05:40 +03:00
|
|
|
testDejafus :: Show a
|
2016-06-22 13:20:22 +03:00
|
|
|
=> (forall t. Conc.ConcST t a)
|
2015-10-08 14:05:59 +03:00
|
|
|
-- ^ The computation to test
|
2015-10-08 17:15:13 +03:00
|
|
|
-> [(String, Predicate a)]
|
|
|
|
-- ^ The list of predicates (with names) to check
|
2015-10-08 23:09:48 +03:00
|
|
|
-> Test
|
2017-02-20 06:02:33 +03:00
|
|
|
testDejafus = testDejafusWay defaultWay defaultMemType
|
|
|
|
|
|
|
|
-- | Variant of 'testDejafus' which takes a way to execute the program
|
|
|
|
-- and a memory model.
|
2017-04-08 21:51:09 +03:00
|
|
|
--
|
2017-04-08 23:15:32 +03:00
|
|
|
-- @since 0.5.0.0
|
2017-02-26 05:51:36 +03:00
|
|
|
testDejafusWay :: Show a
|
|
|
|
=> Way
|
2017-02-20 06:02:33 +03:00
|
|
|
-- ^ How to execute the concurrent program.
|
|
|
|
-> MemType
|
2015-10-08 14:05:59 +03:00
|
|
|
-- ^ The memory model to use for non-synchronised @CRef@ operations.
|
2016-06-22 13:20:22 +03:00
|
|
|
-> (forall t. Conc.ConcST t a)
|
2015-10-08 14:05:59 +03:00
|
|
|
-- ^ The computation to test
|
2015-10-08 17:15:13 +03:00
|
|
|
-> [(String, Predicate a)]
|
|
|
|
-- ^ The list of predicates (with names) to check
|
2015-10-08 23:09:48 +03:00
|
|
|
-> Test
|
2017-08-10 18:24:48 +03:00
|
|
|
testDejafusWay = testst (const Nothing)
|
2015-10-08 14:05:59 +03:00
|
|
|
|
|
|
|
-- | Variant of 'testDejafu' for computations which do 'IO'.
|
2017-04-08 21:51:09 +03:00
|
|
|
--
|
|
|
|
-- @since 0.2.0.0
|
2016-06-22 13:20:22 +03:00
|
|
|
testDejafuIO :: Show a => Conc.ConcIO a -> String -> Predicate a -> Test
|
2017-02-20 06:02:33 +03:00
|
|
|
testDejafuIO = testDejafuWayIO defaultWay defaultMemType
|
2015-10-08 17:45:05 +03:00
|
|
|
|
2017-02-20 06:02:33 +03:00
|
|
|
-- | Variant of 'testDejafuWay' for computations which do 'IO'.
|
2017-04-08 21:51:09 +03:00
|
|
|
--
|
2017-04-08 23:15:32 +03:00
|
|
|
-- @since 0.5.0.0
|
2017-02-26 05:51:36 +03:00
|
|
|
testDejafuWayIO :: Show a
|
|
|
|
=> Way -> MemType -> Conc.ConcIO a -> String -> Predicate a -> Test
|
2017-08-10 18:24:48 +03:00
|
|
|
testDejafuWayIO = testDejafuDiscardIO (const Nothing)
|
|
|
|
|
|
|
|
-- | Variant of 'testDejafuDiscard' for computations which do 'IO'.
|
|
|
|
--
|
2017-08-10 23:51:11 +03:00
|
|
|
-- @since 0.7.0.0
|
2017-08-10 18:24:48 +03:00
|
|
|
testDejafuDiscardIO :: Show a => (Either Failure a -> Maybe Discard) -> Way -> MemType -> Conc.ConcIO a -> String -> Predicate a -> Test
|
|
|
|
testDejafuDiscardIO discard way memtype concio name test =
|
|
|
|
testio discard way memtype concio [(name, test)]
|
2015-10-08 14:05:59 +03:00
|
|
|
|
|
|
|
-- | Variant of 'testDejafus' for computations which do 'IO'.
|
2017-04-08 21:51:09 +03:00
|
|
|
--
|
|
|
|
-- @since 0.2.0.0
|
2016-06-22 13:20:22 +03:00
|
|
|
testDejafusIO :: Show a => Conc.ConcIO a -> [(String, Predicate a)] -> Test
|
2017-02-20 06:02:33 +03:00
|
|
|
testDejafusIO = testDejafusWayIO defaultWay defaultMemType
|
2015-10-08 14:05:59 +03:00
|
|
|
|
2017-02-20 06:02:33 +03:00
|
|
|
-- | Variant of 'dejafusWay' for computations which do 'IO'.
|
2017-04-08 21:51:09 +03:00
|
|
|
--
|
2017-04-08 23:15:32 +03:00
|
|
|
-- @since 0.5.0.0
|
2017-02-26 05:51:36 +03:00
|
|
|
testDejafusWayIO :: Show a
|
|
|
|
=> Way -> MemType -> Conc.ConcIO a -> [(String, Predicate a)] -> Test
|
2017-08-10 18:24:48 +03:00
|
|
|
testDejafusWayIO = testio (const Nothing)
|
2015-10-08 14:05:59 +03:00
|
|
|
|
2017-06-07 16:02:40 +03:00
|
|
|
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
-- Refinement property testing
|
|
|
|
|
|
|
|
-- | Check a refinement property with a variety of seed values and
|
|
|
|
-- variable assignments.
|
|
|
|
--
|
2017-06-07 19:09:01 +03:00
|
|
|
-- @since 0.6.0.0
|
2017-06-07 16:02:40 +03:00
|
|
|
testProperty :: (R.Testable p, R.Listable (R.X p), Eq (R.X p), Show (R.X p), Show (R.O p))
|
|
|
|
=> String
|
|
|
|
-- ^ The name of the test.
|
|
|
|
-> p
|
|
|
|
-- ^ The property to check.
|
|
|
|
-> Test
|
|
|
|
testProperty = testprop
|
|
|
|
|
|
|
|
|
2015-10-08 14:05:59 +03:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- HUnit integration
|
|
|
|
|
2015-10-08 23:15:46 +03:00
|
|
|
-- | Produce a HUnit 'Test' from a Deja Fu test.
|
2017-02-26 05:51:36 +03:00
|
|
|
testst :: Show a
|
2017-08-10 18:24:48 +03:00
|
|
|
=> (Either Failure a -> Maybe Discard)
|
|
|
|
-> Way
|
|
|
|
-> MemType
|
|
|
|
-> (forall t. Conc.ConcST t a)
|
|
|
|
-> [(String, Predicate a)]
|
|
|
|
-> Test
|
|
|
|
testst discard way memtype conc tests = case map toTest tests of
|
2015-10-08 23:15:46 +03:00
|
|
|
[t] -> t
|
|
|
|
ts -> TestList ts
|
|
|
|
|
|
|
|
where
|
|
|
|
toTest (name, p) = TestLabel name . TestCase $
|
|
|
|
assertString . showErr $ p traces
|
|
|
|
|
2017-08-10 18:24:48 +03:00
|
|
|
traces = runSCTst discard way memtype conc
|
2015-10-08 23:15:46 +03:00
|
|
|
|
|
|
|
-- | Produce a HUnit 'Test' from an IO-using Deja Fu test.
|
2017-02-26 05:51:36 +03:00
|
|
|
testio :: Show a
|
2017-08-10 18:24:48 +03:00
|
|
|
=> (Either Failure a -> Maybe Discard)
|
|
|
|
-> Way
|
|
|
|
-> MemType
|
|
|
|
-> Conc.ConcIO a
|
|
|
|
-> [(String, Predicate a)]
|
|
|
|
-> Test
|
|
|
|
testio discard way memtype concio tests = case map toTest tests of
|
2015-10-08 23:15:46 +03:00
|
|
|
[t] -> t
|
|
|
|
ts -> TestList ts
|
|
|
|
|
|
|
|
where
|
|
|
|
toTest (name, p) = TestLabel name . TestCase $ do
|
|
|
|
-- Sharing of traces probably not possible (without something
|
|
|
|
-- really unsafe) here, as 'test' doesn't allow side-effects
|
|
|
|
-- (eg, constructing an 'MVar' to share the traces after one
|
|
|
|
-- test computed them).
|
2017-08-10 18:24:48 +03:00
|
|
|
traces <- runSCTio discard way memtype concio
|
2015-10-08 23:15:46 +03:00
|
|
|
assertString . showErr $ p traces
|
2015-10-08 14:05:59 +03:00
|
|
|
|
2017-06-07 16:02:40 +03:00
|
|
|
-- | Produce a HUnit 'Test' from a Deja Fu refinement property test.
|
|
|
|
testprop :: (R.Testable p, R.Listable (R.X p), Eq (R.X p), Show (R.X p), Show (R.O p))
|
|
|
|
=> String -> p -> Test
|
|
|
|
testprop name p = TestLabel name . TestCase $ do
|
|
|
|
ce <- R.check' p
|
|
|
|
case ce of
|
|
|
|
Just c -> assertFailure . init $ unlines
|
|
|
|
[ "*** Failure: " ++
|
|
|
|
(if null (R.failingArgs c) then "" else unwords (R.failingArgs c) ++ " ") ++
|
|
|
|
"(seed " ++ show (R.failingSeed c) ++ ")"
|
|
|
|
, " left: " ++ show (F.toList $ R.leftResults c)
|
|
|
|
, " right: " ++ show (F.toList $ R.rightResults c)
|
|
|
|
]
|
|
|
|
Nothing -> pure ()
|
|
|
|
|
|
|
|
|
2016-04-29 01:00:33 +03:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- Utilities
|
|
|
|
|
2015-10-08 14:05:59 +03:00
|
|
|
-- | Convert a test result into an error message on failure (empty
|
|
|
|
-- string on success).
|
|
|
|
showErr :: Show a => Result a -> String
|
|
|
|
showErr res
|
|
|
|
| _pass res = ""
|
2015-10-27 18:39:52 +03:00
|
|
|
| otherwise = "Failed after " ++ show (_casesChecked res) ++ " cases:\n" ++ msg ++ unlines failures ++ rest where
|
|
|
|
|
|
|
|
msg = if null (_failureMsg res) then "" else _failureMsg res ++ "\n"
|
2015-10-08 14:05:59 +03:00
|
|
|
|
2016-04-29 01:00:33 +03:00
|
|
|
failures = intersperse "" . map (indent . showres) . take 5 $ _failures res
|
|
|
|
|
2016-06-22 13:20:22 +03:00
|
|
|
showres (r, t) = either Conc.showFail show r ++ " " ++ Conc.showTrace t
|
2015-10-08 14:05:59 +03:00
|
|
|
|
|
|
|
rest = if moreThan (_failures res) 5 then "\n\t..." else ""
|
|
|
|
|
|
|
|
-- | Check if a list has more than some number of elements.
|
|
|
|
moreThan :: [a] -> Int -> Bool
|
|
|
|
moreThan [] n = n < 0
|
|
|
|
moreThan _ 0 = True
|
|
|
|
moreThan (_:xs) n = moreThan xs (n-1)
|
|
|
|
|
2016-02-09 21:37:50 +03:00
|
|
|
-- | Indent every line of a string.
|
|
|
|
indent :: String -> String
|
|
|
|
indent = intercalate "\n" . map ('\t':) . lines
|