git.iko.soy/typeable/ether
on master help sign in
Test-suite update (T8)
c9a138cIndex Int
test/Regression.hs−48
compare with master
unifiedsplit
@@ -1,13 +1,5 @@
1module Main where
1module Main where
2
2
3−import Control.Monad
4−
5−import Control.Monad.Ether
6−import Control.Ether.Abbr
7−
8−import qualified Control.Monad.Reader as T
9−import qualified Control.Monad.State as T
10−
11import Test.Tasty
3import Test.Tasty
12
4
13import Regression.T1
5import Regression.T1
@@ -19,9 +11,6 @@ import Regression.T6
19import Regression.T7
11import Regression.T7
20import Regression.T8
12import Regression.T8
21
13
22−ethereal "Foo" "foo"
23−ethereal "Bar" "bar"
24−
25main :: IO ()
14main :: IO ()
26main = defaultMain suite
15main = defaultMain suite
27
16
@@ -36,40 +25,3 @@ suite = testGroup "Ether"
36 , test7
25 , test7
37 , test8
26 , test8
38 ]
27 ]
39−
40−wrapState_f :: T.MonadState Int m => m String
41−wrapState_f = liftM show T.get
42−
43−wrapState_g :: T.MonadState Bool m => m String
44−wrapState_g = liftM show T.get
45−
46−wrapState_useboth :: Ether '[Foo <-> Int, Bar <-> Bool] m => m String
47−wrapState_useboth = do
48− a <- tagAttach foo wrapState_f
49− b <- tagAttach bar wrapState_g
50− return (a ++ b)
51−
52−wrapStateCore :: Int -> Bool -> String
53−wrapStateCore int bool = evalState foo (evalStateT bar wrapState_useboth bool) int
54−
55−wrapStateBad1_g :: MonadState Foo Int m => m ()
56−wrapStateBad1_g = modify foo (*100)
57−
58−wrapStateBad1_useboth :: MonadState Foo Int m => m String
59−wrapStateBad1_useboth = do
60− wrapStateBad1_g
61− tagAttach foo wrapState_f
62−
63−wrapStateBad1 :: Int -> String
64−wrapStateBad1 = evalState foo wrapStateBad1_useboth
65−
66−wrapStateBad2 :: (T.MonadState Int m , MonadState Foo Int m) => m Int
67−wrapStateBad2 = do
68− modify foo (*100)
69− T.get
70−
71−wrapStateBad2Core :: Int -> Int
72−wrapStateBad2Core = evalState foo (tagAttach foo wrapStateBad2)
73−
74−wrapReaderCore :: Int -> Int
75−wrapReaderCore = runReader foo (tagAttach foo (liftM2 (+) T.ask (ask foo)))
test/Regression/T8.hs+47−1
@@ -1,6 +1,52 @@
1module Regression.T8 (test8) where
1module Regression.T8 (test8) where
2
2
3+import Control.Ether.Abbr
4+import Control.Monad.Ether
5+
6+import qualified Control.Monad.State as T
7+
3import Test.Tasty
8import Test.Tasty
9+import Test.Tasty.QuickCheck
10+
11+ethereal "Foo" "foo"
12+ethereal "Bar" "bar"
13+
14+testMTL1 :: T.MonadState Int m => m ()
15+testMTL1 = T.modify negate
16+
17+testMTL2 :: T.MonadState Bool m => m ()
18+testMTL2 = T.modify not
19+
20+testEther
21+ :: Ether '[Foo <-> Int, Bar <-> Bool] m
22+ => m String
23+testEther = do
24+ tagAttach foo testMTL1
25+ tagAttach bar testMTL2
26+ a <- gets foo show
27+ b <- gets bar show
28+ return (a ++ b)
29+
30+model :: Int -> Bool -> String
31+model a b = show (negate a) ++ show (not b)
32+
33+runner1 a b
34+ = flip (evalState foo) a
35+ . flip (evalStateT bar) b
36+
37+runner2 a b
38+ = flip (evalState bar) b
39+ . flip (evalStateT foo) a
4
40
5test8 :: TestTree
41test8 :: TestTree
6−test8 = testGroup "T8:" []
42+test8 = testGroup "T8: Multiple tag attachements"
43+ [ testProperty "runner₁ works"
44+ $ \a b -> property
45+ $ runner1 a b testEther == model a b
46+ , testProperty "runner₂ works"
47+ $ \a b -> property
48+ $ runner2 a b testEther == model a b
49+ , testProperty "runner₁ == runner₂"
50+ $ \a b -> property
51+ $ runner1 a b testEther == runner2 a b testEther
52+ ]