@@ -1,6 +1,66 @@
11module Regression.T6 (test6) where
22
3+import Control.Monad
4+import Control.Ether.Abbr
5+
6+import qualified Control.Monad.Ether.Implicit as I
7+import qualified Control.Ether.Implicit.Abbr as I
8+
39import Test.Tasty
10+import Test.Tasty.QuickCheck
11+
12+data DivideByZero = DivideByZero
13+ deriving (Show)
14+
15+data NegativeLog a = NegativeLog a
16+ deriving (Show)
17+
18+testEther
19+ :: (Floating a, Ord a)
20+ => Ether '[I.E DivideByZero, I.E (NegativeLog a)] m
21+ => a -> a -> m a
22+testEther a b = do
23+ when (b == 0) (I.throw DivideByZero)
24+ let d = a / b
25+ when (d < 0) (I.throw (NegativeLog d))
26+ return (log d)
27+
28+-- Copied verbatim from "Data.Function" to support @base < 4.8@.
29+(&) :: a -> (a -> b) -> b
30+x & f = f x
31+
32+handleNegativeLog (NegativeLog (x :: Double)) = "nl: " ++ show x
33+handleDivideByZero DivideByZero = "dz"
34+
35+runner1 :: Double -> Double -> String
36+runner1 a b = do
37+ (show <$> testEther a b)
38+ & I.handleT handleNegativeLog
39+ & I.handle handleDivideByZero
40+
41+runner2 :: Double -> Double -> String
42+runner2 a b = do
43+ (show <$> testEther a b)
44+ & I.handleT handleDivideByZero
45+ & I.handle handleNegativeLog
46+
47+logDiv :: Double -> Double -> String
48+logDiv a b
49+ | b == 0 = "dz"
50+ | d < 0 = "nl: " ++ show d
51+ | otherwise = show (log d)
52+ where
53+ d = a / b
454
555test6 :: TestTree
6−test6 = testGroup "T6:" []
56+test6 = testGroup "T6: Checked exceptions"
57+ [ testProperty "runner₁ works"
58+ $ \a b -> property
59+ $ runner1 a b == logDiv a b
60+ , testProperty "runner₂ works"
61+ $ \a b -> property
62+ $ runner2 a b == logDiv a b
63+ , testProperty "runner₁ == runner₂"
64+ $ \a b -> property
65+ $ runner1 a b == runner2 a b
66+ ]