@@ -1,6 +1,56 @@
11module Regression.T3 (test3) where
22
3+import Control.Ether.Abbr
4+import Control.Monad.Ether
5+
6+import qualified Control.Monad.Reader as T
7+import qualified Control.Monad.State as T
8+
39import Test.Tasty
10+import Test.Tasty.QuickCheck
11+
12+ethereal "RTag" "rTag"
13+ethereal "STag" "sTag"
14+
15+testMTL :: (T.MonadReader Int m, T.MonadState Int m) => m Int
16+testMTL = do
17+ b <- T.get
18+ a <- T.ask
19+ T.put (a + b)
20+ return (a * b)
21+
22+testEther
23+ :: Ether '[STag --> Int, STag <-> Int, RTag --> Int] m
24+ => m (Int, Int, Int)
25+testEther = local rTag (*2) $ do
26+ a_mul_b <- tagAttach sTag testMTL
27+ a_add_b <- get sTag
28+ modify sTag negate
29+ c <- ask rTag
30+ return (a_mul_b, a_add_b, c)
31+
32+runner1 s r
33+ = flip (runReader rTag) (negate r)
34+ . flip (runReaderT sTag) r
35+ . flip (runStateT sTag) s
36+runner2 s r
37+ = flip (runReader rTag) (negate r)
38+ . flip (runStateT sTag) s
39+ . flip (runReaderT sTag) r
440
541test3 :: TestTree
6−test3 = testGroup "T3:" []
42+test3 = testGroup "T3: Tag attachement"
43+ [ testProperty "runner1 works"
44+ $ \s r -> property
45+ $ (==)
46+ (runner1 s r testEther)
47+ ((s * r, s + r, negate r * 2), negate (s + r))
48+ , testProperty "runner2 works"
49+ $ \s r -> property
50+ $ (==)
51+ (runner2 s r testEther)
52+ ((s * r, s + r, negate r * 2), negate (s + r))
53+ , testProperty "runner1 == runner2"
54+ $ \s r -> property
55+ $ runner1 s r testEther == runner2 s r testEther
56+ ]