21a27c1 · typeable/ether

ether.cabal+4

compare with master

unifiedsplit

@@ -99,6 +99,10 @@ test-suite regression

99 main-is: Regression.hs

100 other-modules: Regression.T1

101 Regression.T2

102+ Regression.T3

103+ Regression.T4

104+ Regression.T5

105+ Regression.T6

102

106

103 type: exitcode-stdio-1.0

107 type: exitcode-stdio-1.0

104 hs-source-dirs: test

108 hs-source-dirs: test

test/Regression.hs+10−20

@@ -18,6 +18,9 @@ import Test.Tasty

18import Regression.T1

19import Regression.T2

20import Regression.T3

21+import Regression.T4

22+import Regression.T5

23+import Regression.T6

21

24

22ethereal "R1" "r1"

25ethereal "R1" "r1"

23ethereal "R2" "r2"

26ethereal "R2" "r2"

@@ -30,26 +33,13 @@ main = defaultMain suite

30

33

31suite :: TestTree

34suite :: TestTree

32suite = testGroup "Ether"

35suite = testGroup "Ether"

33− [ test1

36+ [ test1

34− , test2

37+ , test2

35− , test3

38+ , test3

36− ]

39+ , test4

37−

40+ , test5

38−wrapCore :: (T.MonadReader Int m, T.MonadState Int m) => m Int

41+ , test6

39−wrapCore = do

42+ ]

40− b <- T.get

41− a <- T.ask

42− T.put (a + b)

43− return (a * b)

44−

45−wrapCore' :: Ether '[S1 --> Int, S1 <-> Int, R1 --> Int] m => m Int

46−wrapCore' = do

47− a <- tagAttach s1 wrapCore

48− c <- ask r1

49− return (a + c)

50−

51−wrapCore'' :: Int -> (Int, Int)

52−wrapCore'' a = runReader r1 (runStateT s1 (runReaderT s1 wrapCore' a) a) (-1)

53

43

54nonUniqueTagsCore :: IO ()

44nonUniqueTagsCore :: IO ()

55nonUniqueTagsCore

45nonUniqueTagsCore

test/Regression/T3.hs+51−1

@@ -1,6 +1,56 @@

1module Regression.T3 (test3) where

2

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+

3import Test.Tasty

9import 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

4

40

5test3 :: TestTree

41test3 :: 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+ ]

test/Regression/T4.hsnew file+6

@@ -0,0 +1,6 @@

1+module Regression.T4 (test4) where

2+

3+import Test.Tasty

4+

5+test4 :: TestTree

6+test4 = testGroup "T4:" []

test/Regression/T5.hsnew file+6

@@ -0,0 +1,6 @@

1+module Regression.T5 (test5) where

2+

3+import Test.Tasty

4+

5+test5 :: TestTree

6+test5 = testGroup "T5:" []

test/Regression/T6.hsnew file+6

@@ -0,0 +1,6 @@

1+module Regression.T6 (test6) where

2+

3+import Test.Tasty

4+

5+test6 :: TestTree

6+test6 = testGroup "T6:" []