1import Test.Tasty 2import Test.Tasty.QuickCheck 3import Test.Tasty.HUnit 4 5import GHC.STRef (STRef) 6import GHC.Arr (Array, listArray, (//)) 7import Control.Monad.ST.Trans 8import Control.Monad.Trans.Class 9import Control.Monad (guard) 10 11props :: TestTree 12props = testGroup "Properties" [ 13 testProperty "runSTT respects return" $ 14 \x -> runSTT (return x) == Just (x :: Int), 15 testProperty "STT respects MonadTrans" $ 16 \m -> runSTT (lift m) == (m :: Maybe Int), 17 testProperty "newSTRef . readSTRef == id" $ 18 \x -> runSTT ((newSTRef x :: STT s Maybe (STRef s Int)) >>= readSTRef) == Just x, 19 testProperty "writeSTRef overwrite" $ 20 \x y -> runSTT (do ref <- newSTRef x 21 writeSTRef ref y 22 readSTRef ref) == Just (y :: Int), 23 testProperty "newSTArray makes correct Arrays" $ 24 \t e -> 0 <= t ==> 25 runSTT (newSTArray (0,t) e >>= freezeSTArray) == 26 Just (listArray (0,t) (repeat e) :: Array Int Int), 27 testProperty "writeSTArray overwrite" $ 28 \t e y -> 0 <= t ==> 29 runSTT (do arr <- newSTArray (0,t) e 30 mapM_ (\i -> writeSTArray arr i y) [0..t] 31 freezeSTArray arr) == 32 Just (listArray (0,t) (repeat y) :: Array Int Int), 33 testProperty "thawSTArray . freezeSTArray == id" $ 34 \l -> let a = listArray (0,length l - 1) l in 35 runSTT (thawSTArray a >>= freezeSTArray) == Just (a :: Array Int Int), 36 testProperty "writeSTArray . thawSTArray == update a" $ 37 \l i e -> let a = listArray (0, length l - 1) l in 38 0 <= i && i < length l ==> 39 runSTT (do stArr <- thawSTArray a 40 writeSTArray stArr i e 41 freezeSTArray stArr) == 42 Just (a // [(i,e)] :: Array Int Int) ] 43 44unitTests :: TestTree 45unitTests = testGroup "Unit Tests" [ 46 testCase "ST Ref" $ runSTT (do ref <- newSTRef 0 47 curNum <- readSTRef ref 48 writeSTRef ref (curNum + 6) 49 nextNum <- readSTRef ref 50 lift (guard (nextNum == 6)) 51 return nextNum) @?= Just 6 ] 52 53main :: IO () 54main = defaultMain (testGroup "All Tests" [props,unitTests]) 55