diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015, Michael Walker + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test/Tasty/DejaFu.hs b/Test/Tasty/DejaFu.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/DejaFu.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +-- | This module allows using Deja Fu predicates with Tasty to test +-- the behaviour of concurrent systems. +module Test.Tasty.DejaFu + ( -- * Testing + testAuto + , testDejafu + , testDejafus + , testAutoIO + , testDejafuIO + , testDejafusIO + + -- * Testing under Alternative Memory Models + , MemType(..) + , testAuto' + , testAutoIO' + , testDejafu' + , testDejafus' + , testDejafuIO' + , testDejafusIO' + ) where + +import Data.Typeable (Typeable) +import Test.DejaFu +import Test.DejaFu.Deterministic (ConcST, ConcIO, Trace, showFail, showTrace) +import Test.DejaFu.SCT (sctBound, sctBoundIO) +import Test.Tasty (TestName, TestTree, testGroup) +import Test.Tasty.Providers (IsTest(..), singleTest, testPassed, testFailed) + +-------------------------------------------------------------------------------- +-- Automated testing + +-- | Automatically test a computation. In particular, look for +-- deadlocks, uncaught exceptions, and multiple return values. +-- +-- 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'. +testAuto :: (Eq a, Show a) + => (forall t. ConcST t a) + -- ^ The computation to test + -> TestTree +testAuto = testAuto' defaultMemType + +-- | Variant of 'testAuto' which tests a computation under a given +-- memory model. +testAuto' :: (Eq a, Show a) + => MemType + -- ^ The memory model to use for non-synchronised @CRef@ operations. + -> (forall t. ConcST t a) + -- ^ The computation to test + -> TestTree +testAuto' memtype conc = testDejafus' memtype defaultBounds conc autocheckCases + +-- | Variant of 'testAuto' for computations which do 'IO'. +testAutoIO :: (Eq a, Show a) => ConcIO a -> TestTree +testAutoIO = testAutoIO' defaultMemType + +-- | Variant of 'testAuto'' for computations which do 'IO'. +testAutoIO' :: (Eq a, Show a) => MemType -> ConcIO a -> TestTree +testAutoIO' memtype concio = testDejafusIO' memtype defaultBounds concio autocheckCases + +-- | Predicates for the various autocheck functions. +autocheckCases :: Eq a => [(TestName, Predicate a)] +autocheckCases = + [("Never Deadlocks", representative deadlocksNever) + , ("No Exceptions", representative exceptionsNever) + , ("Consistent Result", alwaysSame) + ] + +-------------------------------------------------------------------------------- +-- Manual testing + +-- | Check that a predicate holds. +testDejafu :: Show a + => (forall t. ConcST t a) + -- ^ The computation to test + -> TestName + -- ^ The name of the test. + -> Predicate a + -- ^ The predicate to check + -> TestTree +testDejafu = testDejafu' defaultMemType defaultBounds + +-- | Variant of 'testDejafu' which takes a memory model and +-- pre-emption bound. +testDejafu' :: Show a + => MemType + -- ^ The memory model to use for non-synchronised @CRef@ operations. + -> Bounds + -- ^ The schedule bounds. + -> (forall t. ConcST t a) + -- ^ The computation to test + -> TestName + -- ^ The name of the test. + -> Predicate a + -- ^ The predicate to check + -> TestTree +testDejafu' memtype cb conc name p = testDejafus' memtype cb conc [(name, p)] + +-- | 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. +testDejafus :: Show a + => (forall t. ConcST t a) + -- ^ The computation to test + -> [(TestName, Predicate a)] + -- ^ The list of predicates (with names) to check + -> TestTree +testDejafus = testDejafus' defaultMemType defaultBounds + +-- | Variant of 'testDejafus' which takes a memory model and pre-emption +-- bound. +testDejafus' :: Show a + => MemType + -- ^ The memory model to use for non-synchronised @CRef@ operations. + -> Bounds + -- ^ The schedule bounds. + -> (forall t. ConcST t a) + -- ^ The computation to test + -> [(TestName, Predicate a)] + -- ^ The list of predicates (with names) to check + -> TestTree +testDejafus' = test + +-- | Variant of 'testDejafu' for computations which do 'IO'. +testDejafuIO :: Show a => ConcIO a -> TestName -> Predicate a -> TestTree +testDejafuIO = testDejafuIO' defaultMemType defaultBounds + +-- | Variant of 'testDejafu'' for computations which do 'IO'. +testDejafuIO' :: Show a => MemType -> Bounds -> ConcIO a -> TestName -> Predicate a -> TestTree +testDejafuIO' memtype cb concio name p = testDejafusIO' memtype cb concio [(name, p)] + +-- | Variant of 'testDejafus' for computations which do 'IO'. +testDejafusIO :: Show a => ConcIO a -> [(TestName, Predicate a)] -> TestTree +testDejafusIO = testDejafusIO' defaultMemType defaultBounds + +-- | Variant of 'dejafus'' for computations which do 'IO'. +testDejafusIO' :: Show a => MemType -> Bounds -> ConcIO a -> [(TestName, Predicate a)] -> TestTree +testDejafusIO' = testio + +-------------------------------------------------------------------------------- +-- Tasty integration + +data ConcTest where + ConcTest :: Show a => [(Either Failure a, Trace)] -> Predicate a -> ConcTest + deriving Typeable + +data ConcIOTest where + ConcIOTest :: Show a => IO [(Either Failure a, Trace)] -> Predicate a -> ConcIOTest + deriving Typeable + +instance IsTest ConcTest where + testOptions = return [] + + run _ (ConcTest traces p) _ = + let err = showErr $ p traces + in return $ if null err then testPassed "" else testFailed err + +instance IsTest ConcIOTest where + testOptions = return [] + + run _ (ConcIOTest iotraces p) _ = do + traces <- iotraces + let err = showErr $ p traces + return $ if null err then testPassed "" else testFailed err + +-- | Produce a Tasty 'TestTree' from a Deja Fu test. +test :: Show a => MemType -> Bounds -> (forall t. ConcST t a) -> [(TestName, Predicate a)] -> TestTree +test memtype cb conc tests = case map toTest tests of + [t] -> t + ts -> testGroup "Deja Fu Tests" ts + + where + toTest (name, p) = singleTest name $ ConcTest traces p + + traces = sctBound memtype cb conc + +-- | Produce a Tasty 'Test' from an IO-using Deja Fu test. +testio :: Show a => MemType -> Bounds -> ConcIO a -> [(TestName, Predicate a)] -> TestTree +testio memtype cb concio tests = case map toTest tests of + [t] -> t + ts -> testGroup "Deja Fu Tests" ts + + where + toTest (name, p) = singleTest name $ ConcIOTest traces p + + -- As with HUnit, constructing a test is side-effect free, so + -- sharing of traces can't happen here. + traces = sctBoundIO memtype cb concio + +-- | Convert a test result into an error message on failure (empty +-- string on success). +showErr :: Show a => Result a -> String +showErr res + | _pass res = "" + | otherwise = "Failed after " ++ show (_casesChecked res) ++ " cases:\n" ++ msg ++ unlines failures ++ rest where + + msg = if null (_failureMsg res) then "" else _failureMsg res ++ "\n" + + failures = map (\(r, t) -> "\t" ++ either showFail show r ++ " " ++ showTrace t) . take 5 $ _failures res + + 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) + diff --git a/tasty-dejafu.cabal b/tasty-dejafu.cabal new file mode 100644 --- /dev/null +++ b/tasty-dejafu.cabal @@ -0,0 +1,41 @@ +-- Initial tasty-dejafu.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: tasty-dejafu +version: 0.2.0.0 +synopsis: Deja Fu support for the Tasty test framework. + +description: + Integration between the + library for concurrency testing and + . This lets you + easily incorporate concurrency testing into your existing test + suites. + . + See the for more + details. + +homepage: https://github.com/barrucadu/dejafu +license: MIT +license-file: LICENSE +author: Michael Walker +maintainer: mike@barrucadu.co.uk +-- copyright: +category: Testing +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/barrucadu/dejafu.git + +library + exposed-modules: Test.Tasty.DejaFu + -- other-modules: + -- other-extensions: + build-depends: base >=4.5 && <5 + , dejafu == 0.2.* + , tasty + -- hs-source-dirs: + default-language: Haskell2010