{-# LANGUAGE TypeFamilies #-}
import Control.Monad (forM_)
import Data.Mutable
import Data.Sequence (Seq)
import Data.Vector (Vector)
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Gen
main :: IO ()
main = hspec spec
data RefAction
= WriteRef Int
| ModifyRef Int
| ModifyRef' Int
| AtomicModifyRef Int
| AtomicModifyRef' Int
deriving Show
instance Arbitrary RefAction where
arbitrary = oneof
[ fmap WriteRef arbitrary
, fmap ModifyRef arbitrary
, fmap ModifyRef' arbitrary
, fmap AtomicModifyRef arbitrary
, fmap AtomicModifyRef' arbitrary
]
data DequeAction
= PushFront Int
| PushBack Int
| PopFront
| PopBack
deriving Show
instance Arbitrary DequeAction where
arbitrary = oneof $ concat
[ replicate 25 $ fmap PushFront arbitrary
, replicate 25 $ fmap PushBack arbitrary
, [return PopFront, return PopBack]
]
manyPushes :: [DequeAction]
manyPushes = concat
[ replicate 50 $ PushBack 0
, replicate 50 PopFront
, replicate 50 $ PushFront 0
, replicate 50 PopBack
]
specialCase :: [DequeAction]
specialCase =
[PushBack 9, PushBack 5,PushBack 11,PushBack 2,PushBack 13,PushBack 10,PushBack 4,PushBack 13,PushBack 7,PushBack 8,PushBack 6,PushBack 4,PushBack 7,PushBack 9,PushBack 10,PushBack 3,PushBack 2,PushBack 12,PushBack 12 ,PushBack 6,PushBack 3,PushBack 5,PushBack 14,PushBack 14,PushBack 11,PushBack 8,PopFront,PopFront,PopFront,PushBack 11,PushBack 3,PopFront,PopFront,PushBack 13,PushBack 12,PopFront,PushBack 10,PushBack 7,PopFront,PopFront,PushBack 13,PushBack 9,PopFront,PushBack 7,PushBack 2,PopFront,PopFront,PushBack 6,PushBack 4,PopFront,PopFront,PopFront,PushBack 9,PushBack 3,PopFront,PushBack 10,PushBack 6,PopFront,PopFront,PopFront,PushBack 12,PushBack 5,PopFront,PushBack 12,PushBack 5,PopFront,PushBack 6,PushBack 4,PopFront,PopFront,PopFront,PushBack 14,PushBack 10,PopFront,PushBack 14,PushBack 10,PopFront,PushBack 11,PushBack 8,PopFront,PushBack 8,PushBack 2,PopFront,PopFront,PopFront,PushBack 13,PushBack 7,PopFront,PushBack 12,PushBack 5,PopFront,PushBack 10,PushBack 8, PopFront,PushBack 7,PushBack 2,PopFront,PopFront,PushBack 9,PushBack 4,PopFront,PopFront,PopFront,PopFront,PopFront,PopFront,PopFront,PopFront,PushBack 4,PushBack 9,PushBack 3,PushBack 10,PushBack 6,PushBack 4,PushBack 13,PushBack 7,PushBack 9,PushBack 3,PopFront]
spec :: Spec
spec = do
describe "Deque" $ do
let runActions forceType actions = do
base <- newColl :: IO (IORef [Int])
tested <- fmap forceType newColl
forM_ (PopFront : PopBack : actions) $ \action -> do
case action of
PushFront i -> do
pushFront base i
pushFront tested i
PushBack i -> do
pushBack base i
pushBack tested i
PopFront -> do
expected <- popFront base
actual <- popFront tested
actual `shouldBe` expected
PopBack -> do
expected <- popBack base
actual <- popBack tested
actual `shouldBe` expected
let drain = do
expected <- popBack base
actual <- popBack tested
actual `shouldBe` expected
case actual of
Just _ -> drain
Nothing -> return $! ()
drain
let test name forceType = describe name $ do
prop "arbitrary actions" $ runActions forceType
it "many pushes" $ runActions forceType manyPushes
it "special case" $ runActions forceType specialCase
test "UDeque" asUDeque
test "SDeque" asSDeque
test "BDeque" asBDeque
test "DLList" asDLList
test "MutVar Seq" (id :: MutVar (PrimState IO) (Seq Int) -> MutVar (PrimState IO) (Seq Int))
test "STRef Vector" (id :: STRef (PrimState IO) (Vector Int) -> STRef (PrimState IO) (Vector Int))
test "BRef Vector" (id :: BRef (PrimState IO) (Vector Int) -> BRef (PrimState IO) (Vector Int))
describe "Ref" $ do
let test name forceType atomic atomic' = prop name $ \start actions -> do
base <- fmap asIORef $ newRef start
tested <- fmap forceType $ newRef start
let check = do
expected <- readRef base
actual <- readRef tested
expected `shouldBe` actual
forM_ (actions :: [RefAction]) $ \action -> case action of
WriteRef i -> do
writeRef base i
writeRef tested i
check
ModifyRef i -> do
modifyRef base (+ i)
modifyRef tested (+ i)
check
ModifyRef' i -> do
modifyRef' base (subtract i)
modifyRef' tested (subtract i)
check
AtomicModifyRef i -> do
let f x = (x + i, ())
atomicModifyRef base f
_ <- atomic tested f
check
AtomicModifyRef' i -> do
atomicModifyRef' base $ \x -> (x - i, ())
_ <- atomic' tested $ \x -> (x - i, ())
check
test "URef" asURef modifyRefHelper modifyRefHelper'
test "PRef" asPRef modifyRefHelper modifyRefHelper'
test "SRef" asSRef modifyRefHelper modifyRefHelper'
test "BRef" asBRef modifyRefHelper modifyRefHelper'
test "STRef" asSTRef modifyRefHelper modifyRefHelper'
test "MutVar" asMutVar atomicModifyRef atomicModifyRef'
modifyRefHelper :: (MCState c ~ PrimState IO, RefElement c ~ Int, MutableRef c)
=> c
-> (Int -> (Int, ()))
-> IO ()
modifyRefHelper ref f = modifyRef ref $ \i ->
let (x, y) = f i
in y `seq` x
modifyRefHelper' :: (MCState c ~ PrimState IO, RefElement c ~ Int, MutableRef c)
=> c
-> (Int -> (Int, ()))
-> IO ()
modifyRefHelper' ref f = modifyRef' ref $ \i ->
let (x, y) = f i
in y `seq` x