Skip to content

Commit 3cad91f

Browse files
jasagredojasagredo
committed
QSM
1 parent fc24459 commit 3cad91f

File tree

12 files changed

+1798
-0
lines changed

12 files changed

+1798
-0
lines changed

‎io-sim/io-sim.cabal

Lines changed: 46 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -97,6 +97,27 @@ library
9797
if flag(asserts)
9898
ghc-options: -fno-ignore-asserts
9999

100+
library qsm
101+
import: warnings
102+
hs-source-dirs: qsm
103+
exposed-modules: Test.StateMachine.IOSim.Execute
104+
Test.StateMachine.IOSim.Generate
105+
Test.StateMachine.IOSim.Types
106+
Test.StateMachine.IOSim
107+
108+
reexported-modules: Test.StateMachine.Types.Rank2
109+
110+
build-depends: base,
111+
io-sim,
112+
QuickCheck,
113+
mtl,
114+
containers,
115+
pretty-show,
116+
io-classes,
117+
quickcheck-state-machine:no-vendored-treediff,
118+
default-extensions: ImportQualifiedPost
119+
default-language: Haskell2010
120+
100121
test-suite test
101122
import: test-warnings
102123
type: exitcode-stdio-1.0
@@ -144,3 +165,28 @@ benchmark bench
144165
-Wpartial-fields
145166
-Widentities
146167
-Wredundant-constraints
168+
169+
test-suite qsm-test
170+
import: test-warnings
171+
type: exitcode-stdio-1.0
172+
hs-source-dirs: qsm-test
173+
main-is: Main.hs
174+
175+
other-modules: BasicTest.Template
176+
BasicTest.Correct
177+
BasicTest.NoIncr
178+
BasicTest.Racy
179+
BasicTest.InternalFork
180+
BasicTest.InternalForkAtomic
181+
Exception.Deadlocks
182+
Exception.TryPutMVar
183+
Exception.WithMVar
184+
185+
default-language: Haskell2010
186+
default-extensions: ImportQualifiedPost
187+
build-depends: base,
188+
io-sim:qsm,
189+
io-classes,
190+
QuickCheck,
191+
tasty,
192+
tasty-quickcheck

‎io-sim/qsm-test/BasicTest/Correct.hs

Lines changed: 54 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,54 @@
1+
-- |
2+
3+
module BasicTest.Correct where
4+
5+
import BasicTest.Template
6+
import Control.Concurrent.Class.MonadSTM
7+
import Test.QuickCheck
8+
import Test.StateMachine.IOSim
9+
10+
{-------------------------------------------------------------------------------
11+
SUT
12+
-------------------------------------------------------------------------------}
13+
14+
newtype AtomicCounter m = AtomicCounter (TVar m Int)
15+
16+
newSUT :: MonadLabelledSTM m => m (AtomicCounter m)
17+
newSUT = do
18+
ref <- atomically $ do
19+
tv <- newTVar 0
20+
labelTVar tv "TheCounter"
21+
pure tv
22+
return (AtomicCounter ref)
23+
24+
incr :: MonadSTM m => AtomicCounter m -> m ()
25+
incr (AtomicCounter ref) =
26+
atomically $ do
27+
i <- readTVar ref
28+
writeTVar ref (i + 1)
29+
30+
get :: MonadSTM m => AtomicCounter m -> m Int
31+
get (AtomicCounter ref) = readTVarIO ref
32+
33+
semantics :: MonadSTM m => AtomicCounter m -> Cmd Concrete -> m (Resp Concrete)
34+
semantics sut Incr = do
35+
incr sut *> pure Void
36+
semantics sut Get = do
37+
GetR <$> get sut
38+
39+
transition :: Model r -> Cmd r -> Resp r -> Model r
40+
transition (Model m) Incr _ = Model (m + 1)
41+
transition m Get _ = m
42+
43+
sm :: StateMachine Model Cmd AtomicCounter Resp
44+
sm = StateMachine initModel transition precondition postcondition Nothing
45+
generator shrinker newSUT semantics mock
46+
47+
prop_sequential :: Property
48+
prop_sequential = forAllCommands sm Nothing $ runSequential sm
49+
50+
prop_sequential' :: Property
51+
prop_sequential' = forAllCommands sm Nothing $ runSequentialPOR sm
52+
53+
prop_parallel :: Property
54+
prop_parallel = forAllParallelCommands sm Nothing $ runParallel sm

‎io-sim/qsm-test/BasicTest/InternalFork.hs

Lines changed: 59 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,59 @@
1+
-- |
2+
3+
module BasicTest.InternalFork where
4+
5+
import BasicTest.Template
6+
import Control.Concurrent.Class.MonadSTM
7+
import Control.Monad.Class.MonadAsync
8+
import Test.QuickCheck
9+
import Test.StateMachine.IOSim
10+
11+
{-------------------------------------------------------------------------------
12+
SUT
13+
-------------------------------------------------------------------------------}
14+
15+
newtype AtomicCounter m = AtomicCounter (TVar m Int)
16+
17+
newSUT :: MonadLabelledSTM m => m (AtomicCounter m)
18+
newSUT = do
19+
ref <- atomically $ do
20+
tv <- newTVar 0
21+
labelTVar tv "TheCounter"
22+
pure tv
23+
return (AtomicCounter ref)
24+
25+
incr :: MonadAsync m => AtomicCounter m -> m ()
26+
incr (AtomicCounter ref) = do
27+
t1 <- async f
28+
t2 <- async f
29+
wait t1 >> wait t2
30+
where f = do
31+
i <- readTVarIO ref
32+
atomically $ writeTVar ref (i + 1)
33+
34+
get :: (MonadSTM m) => AtomicCounter m -> m Int
35+
get (AtomicCounter ref) = readTVarIO ref
36+
37+
semantics :: MonadAsync m => AtomicCounter m -> Cmd Concrete -> m (Resp Concrete)
38+
semantics sut Incr = do
39+
incr sut *> pure Void
40+
semantics sut Get = do
41+
GetR <$> get sut
42+
43+
transition :: Model r -> Cmd r -> Resp r -> Model r
44+
-- each increment will increment by 2
45+
transition (Model m) Incr _ = Model (m + 2)
46+
transition m Get _ = m
47+
48+
sm :: StateMachine Model Cmd AtomicCounter Resp
49+
sm = StateMachine initModel transition precondition postcondition Nothing
50+
generator shrinker newSUT semantics mock
51+
52+
prop_sequential :: Property
53+
prop_sequential = forAllCommands sm Nothing $ runSequential sm
54+
55+
prop_sequential' :: Property
56+
prop_sequential' = forAllCommands sm Nothing $ runSequentialPOR sm
57+
58+
prop_parallel :: Property
59+
prop_parallel = forAllParallelCommands sm Nothing $ runParallel sm

‎io-sim/qsm-test/BasicTest/InternalForkAtomic.hs

Lines changed: 59 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,59 @@
1+
-- |
2+
3+
module BasicTest.InternalForkAtomic where
4+
5+
import BasicTest.Template
6+
import Control.Concurrent.Class.MonadSTM
7+
import Control.Monad.Class.MonadAsync
8+
import Test.QuickCheck
9+
import Test.StateMachine.IOSim
10+
11+
{-------------------------------------------------------------------------------
12+
SUT
13+
-------------------------------------------------------------------------------}
14+
15+
newtype AtomicCounter m = AtomicCounter (TVar m Int)
16+
17+
newSUT :: MonadLabelledSTM m => m (AtomicCounter m)
18+
newSUT = do
19+
ref <- atomically $ do
20+
tv <- newTVar 0
21+
labelTVar tv "TheCounter"
22+
pure tv
23+
return (AtomicCounter ref)
24+
25+
incr :: MonadAsync m => AtomicCounter m -> m ()
26+
incr (AtomicCounter ref) = do
27+
t1 <- async f
28+
t2 <- async f
29+
wait t1 >> wait t2
30+
where f = atomically $ do
31+
i <- readTVar ref
32+
writeTVar ref (i + 1)
33+
34+
get :: (MonadSTM m) => AtomicCounter m -> m Int
35+
get (AtomicCounter ref) = readTVarIO ref
36+
37+
semantics :: MonadAsync m => AtomicCounter m -> Cmd Concrete -> m (Resp Concrete)
38+
semantics sut Incr = do
39+
incr sut *> pure Void
40+
semantics sut Get = do
41+
GetR <$> get sut
42+
43+
transition :: Model r -> Cmd r -> Resp r -> Model r
44+
-- each increment will increment by 2
45+
transition (Model m) Incr _ = Model (m + 2)
46+
transition m Get _ = m
47+
48+
sm :: StateMachine Model Cmd AtomicCounter Resp
49+
sm = StateMachine initModel transition precondition postcondition Nothing
50+
generator shrinker newSUT semantics mock
51+
52+
prop_sequential :: Property
53+
prop_sequential = forAllCommands sm Nothing $ runSequential sm
54+
55+
prop_sequential' :: Property
56+
prop_sequential' = forAllCommands sm Nothing $ runSequentialPOR sm
57+
58+
prop_parallel :: Property
59+
prop_parallel = forAllParallelCommands sm Nothing $ runParallel sm

‎io-sim/qsm-test/BasicTest/NoIncr.hs

Lines changed: 49 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,49 @@
1+
-- |
2+
3+
module BasicTest.NoIncr where
4+
5+
import BasicTest.Template
6+
import Control.Concurrent.Class.MonadSTM
7+
import Test.QuickCheck
8+
import Test.StateMachine.IOSim
9+
10+
{-------------------------------------------------------------------------------
11+
SUT
12+
-------------------------------------------------------------------------------}
13+
14+
newtype AtomicCounter m = AtomicCounter (TVar m Int)
15+
16+
newSUT :: MonadLabelledSTM m => m (AtomicCounter m)
17+
newSUT = do
18+
ref <- atomically $ do
19+
tv <- newTVar 0
20+
labelTVar tv "TheCounter"
21+
pure tv
22+
return (AtomicCounter ref)
23+
24+
incr :: MonadSTM m => AtomicCounter m -> m ()
25+
incr (AtomicCounter ref) =
26+
atomically $ do
27+
i <- readTVar ref
28+
-- Deliberate bug, no increment
29+
writeTVar ref i
30+
31+
get :: MonadSTM m => AtomicCounter m -> m Int
32+
get (AtomicCounter ref) = readTVarIO ref
33+
34+
semantics :: MonadSTM m => AtomicCounter m -> Cmd Concrete -> m (Resp Concrete)
35+
semantics sut Incr = do
36+
incr sut *> pure Void
37+
semantics sut Get = do
38+
GetR <$> get sut
39+
40+
transition :: Model r -> Cmd r -> Resp r -> Model r
41+
transition (Model m) Incr _ = Model (m + 1)
42+
transition m Get _ = m
43+
44+
sm :: StateMachine Model Cmd AtomicCounter Resp
45+
sm = StateMachine initModel transition precondition postcondition Nothing
46+
generator shrinker newSUT semantics mock
47+
48+
prop_sequential :: Property
49+
prop_sequential = forAllCommands sm Nothing $ runSequential sm

‎io-sim/qsm-test/BasicTest/Racy.hs

Lines changed: 53 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,53 @@
1+
-- |
2+
3+
module BasicTest.Racy where
4+
5+
import BasicTest.Template
6+
import Control.Concurrent.Class.MonadSTM
7+
import Test.QuickCheck
8+
import Test.StateMachine.IOSim
9+
10+
{-------------------------------------------------------------------------------
11+
SUT
12+
-------------------------------------------------------------------------------}
13+
14+
newtype AtomicCounter m = AtomicCounter (TVar m Int)
15+
16+
newSUT :: MonadLabelledSTM m => m (AtomicCounter m)
17+
newSUT = do
18+
ref <- atomically $ do
19+
tv <- newTVar 0
20+
labelTVar tv "TheCounter"
21+
pure tv
22+
return (AtomicCounter ref)
23+
24+
incr :: MonadSTM m => AtomicCounter m -> m ()
25+
incr (AtomicCounter ref) = do
26+
i <- readTVarIO ref
27+
atomically $ writeTVar ref (i + 1)
28+
29+
get :: MonadSTM m => AtomicCounter m -> m Int
30+
get (AtomicCounter ref) = readTVarIO ref
31+
32+
semantics :: MonadSTM m => AtomicCounter m -> Cmd Concrete -> m (Resp Concrete)
33+
semantics sut Incr = do
34+
incr sut *> pure Void
35+
semantics sut Get = do
36+
GetR <$> get sut
37+
38+
transition :: Model r -> Cmd r -> Resp r -> Model r
39+
transition (Model m) Incr _ = Model (m + 1)
40+
transition m Get _ = m
41+
42+
sm :: StateMachine Model Cmd AtomicCounter Resp
43+
sm = StateMachine initModel transition precondition postcondition Nothing
44+
generator shrinker newSUT semantics mock
45+
46+
prop_sequential :: Property
47+
prop_sequential = forAllCommands sm Nothing $ runSequential sm
48+
49+
prop_sequential' :: Property
50+
prop_sequential' = forAllCommands sm Nothing $ runSequentialPOR sm
51+
52+
prop_parallel :: Property
53+
prop_parallel = forAllParallelCommands sm Nothing $ runParallel sm

0 commit comments

Comments
 (0)