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