Skip to content

Commit b4d3d0a

Browse files
ynishizaynishiza
committed
[TEST] flatten test setup for readability
1 parent 856a905 commit b4d3d0a

3 files changed

Lines changed: 206 additions & 17 deletions

File tree

‎test/Arbitrary.hs‎

Lines changed: 34 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -7,14 +7,16 @@
77
{-# LANGUAGE TypeApplications #-}
88

99
module Arbitrary
10-
(
11-
Bot(..),
12-
BaseMonad(..),
10+
( Bot (..),
11+
BaseMonad (..),
12+
isStrictMonad,
1313
F1 (..),
14+
withBaseMonad,
1415
)
1516
where
1617

1718
import Data.Data
19+
import Data.Tuple
1820
import Data.Functor.Identity (Identity (..))
1921

2022
import Test.ChasingBottoms.IsBottom (isBottom)
@@ -28,16 +30,38 @@ bottom = error "<bottom>"
2830
-- Borrowed from container tests: https://github.com/haskell/containers/
2931
newtype Bot a = Bot a
3032

31-
data BaseMonad = forall m. Monad m => BaseMonad (forall a. m a -> IO a)
33+
data BaseMonad
34+
= forall m. (Typeable m, Monad m) => LazyBaseMonad (forall a. m a -> IO a)
35+
| forall m. (Typeable m, Monad m) => StrictBaseMonad (forall a. m a -> IO a)
3236

33-
identityBaseMonad:: BaseMonad
34-
identityBaseMonad = BaseMonad (return . runIdentity)
37+
-- Use underlying Monad of a BaseMonad.
38+
withBaseMonad :: BaseMonad -> (forall m. (Monad m) => m a) -> IO a
39+
withBaseMonad (LazyBaseMonad v) = v
40+
withBaseMonad (StrictBaseMonad v) = v
3541

36-
ioBaseMonad :: BaseMonad
37-
ioBaseMonad = BaseMonad id
42+
isStrictMonad :: BaseMonad -> Bool
43+
isStrictMonad (LazyBaseMonad _) = False
44+
isStrictMonad (StrictBaseMonad _) = True
45+
46+
getSolo :: Solo a -> a
47+
getSolo (MkSolo x) = x
3848

3949
instance Arbitrary BaseMonad where
40-
arbitrary = elements [identityBaseMonad, ioBaseMonad]
50+
arbitrary =
51+
elements
52+
[ LazyBaseMonad id, -- IO
53+
StrictBaseMonad (return . runIdentity), -- Identity
54+
LazyBaseMonad (return . getSolo), -- Solo
55+
LazyBaseMonad (\f -> return $ f ()) -- constant function () -> a
56+
]
57+
58+
instance Show BaseMonad where
59+
show v = case v of
60+
(StrictBaseMonad m) -> "StrictBaseMonad " <> getName m
61+
(LazyBaseMonad m) -> "LazyBaseMonad " <> getName m
62+
where
63+
getName :: forall m. (Typeable m) => (forall a. m a -> IO a) -> String
64+
getName _ = show $ typeRep (Proxy @m)
4165

4266
instance Show a => Show (Bot a) where
4367
show (Bot x) = if isBottom x then "<bottom>" else show x
@@ -50,7 +74,7 @@ instance Arbitrary a => Arbitrary (Bot a) where
5074
]
5175

5276
-- | Arbitrary function of 1 argument
53-
newtype F1 a b = F1 { unF1::a -> b }
77+
newtype F1 a b = F1 {unF1 :: a -> b}
5478
deriving newtype (Arbitrary)
5579

5680
instance (Typeable a, Typeable b) => Show (F1 a b) where
@@ -59,6 +83,3 @@ instance (Typeable a, Typeable b) => Show (F1 a b) where
5983
where
6084
a = show $ typeRep (Proxy @a)
6185
b = show $ typeRep (Proxy @b)
62-
63-
64-

‎test/Strictness.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
{-# LANGUAGE ExistentialQuantification #-}
2+
{-# LANGUAGE RankNTypes #-}
3+
4+
module Strictness
5+
( bottom,
6+
)
7+
where
8+
9+
bottom :: a
10+
bottom = error "<bottom>"

‎test/WriterStrictness.hs‎

Lines changed: 162 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,20 @@
1+
{-# LANGUAGE FlexibleInstances #-}
12
{-# LANGUAGE PolyKinds #-}
23
{-# LANGUAGE RankNTypes #-}
34
{-# LANGUAGE RecordWildCards #-}
45
{-# LANGUAGE ScopedTypeVariables #-}
56
{-# LANGUAGE TypeApplications #-}
7+
{-# LANGUAGE UndecidableInstances #-}
68

79
module WriterStrictness (test) where
810

11+
import Arbitrary
12+
913
import Control.Applicative
1014
import Control.Arrow (first)
1115
import Control.Exception (ErrorCall (..), SomeException (..),
1216
evaluate)
17+
import Control.Exception.Base (displayException)
1318
import Control.Monad
1419
import Control.Monad.Fix
1520
import Control.Monad.IO.Class
@@ -27,6 +32,7 @@ import Data.Coerce
2732
import Data.Either (fromRight)
2833
import Data.Functor.Contravariant
2934
import Data.Functor.Identity
35+
import Data.List (isPrefixOf)
3036
import Data.Maybe
3137
import Data.Monoid
3238

@@ -38,10 +44,13 @@ import Test.QuickCheck.Monadic (assertExceptionIO, monadicIO, run)
3844
import Test.Tasty
3945
import Test.Tasty.QuickCheck
4046

41-
import Arbitrary
42-
4347
test :: IO ()
44-
test = defaultMain $ testGroup "Writer" strictPairTests
48+
test = defaultMain $ testGroup "Writer"
49+
[
50+
testGroup "Pair (a, w)" strictPairTests2,
51+
testGroup "Log w" strictLogTest,
52+
testGroup "Pair OLD" strictPairTests
53+
]
4554

4655
data WriterBase writer
4756
= WriterBase
@@ -134,6 +143,126 @@ cpsWriterLifts =
134143
{ liftCatch = CPS.liftCatch
135144
}
136145

146+
147+
data WriterProp a = WriterProp
148+
{ lazy :: Prop a,
149+
strict :: Prop a,
150+
cps :: Prop a
151+
}
152+
153+
data Prop a = Prop a | Unsupported
154+
155+
runWriterProps :: Testable a => String -> WriterProp a -> TestTree
156+
runWriterProps name WriterProp {..} =
157+
testGroup name $ catMaybes [
158+
runProp "Lazy" lazy,
159+
runProp "Strict" strict,
160+
runProp "CPS" cps
161+
]
162+
where
163+
runProp propName (Prop a) = Just $ testProperty propName a
164+
runProp _ Unsupported = Nothing
165+
166+
strictPairTests2 :: [TestTree]
167+
strictPairTests2 = [
168+
runWriterProps "execWriter" WriterProp {
169+
lazy = Prop $ \(m :: BaseMonad, Bot (v :: (Int, String))) -> isStrict v $ withBaseMonad m $ Lazy.execWriterT $ Lazy.writer v,
170+
strict = Prop $ \(m :: BaseMonad, Bot (v :: (Int, String))) -> isStrict v $ withBaseMonad m $ Strict.execWriterT $ Strict.writer v,
171+
cps = Prop $ \(m :: BaseMonad, Bot (v :: (Int, String))) -> isStrict v $ withBaseMonad m $ CPS.execWriterT $ CPS.writer v
172+
},
173+
runWriterProps "mapWriter" WriterProp {
174+
lazy = Prop $ \(m :: BaseMonad, Bot (v :: (Int, String))) -> isStrict v $ withBaseMonad m $ Lazy.runWriterT $ Lazy.mapWriterT id $ Lazy.writer v,
175+
strict = Prop $ \(m :: BaseMonad, Bot (v :: (Int, String))) -> isStrict v $ withBaseMonad m $ Strict.runWriterT $ Strict.mapWriterT id $ Strict.writer v,
176+
cps = Prop $ \(m :: BaseMonad, Bot (v :: (Int, String))) -> isStrict v $ withBaseMonad m $ CPS.runWriterT $ CPS.mapWriterT id $ CPS.writer v
177+
},
178+
runWriterProps "listen" WriterProp {
179+
lazy = Prop $ \(m :: BaseMonad, Bot (v :: (Float, Sum Int))) -> isLazy $ withBaseMonad m $ Lazy.runWriterT $ Lazy.listen $ Lazy.writer v,
180+
strict = Prop $ \(m :: BaseMonad, Bot (v :: (Float, Sum Int))) -> isStrict v $ withBaseMonad m $ Strict.runWriterT $ Strict.listen $ Strict.writer v,
181+
cps = Prop $ \(m :: BaseMonad, Bot (v :: (Float, Sum Int))) -> isStrict v $ withBaseMonad m $ CPS.runWriterT $ CPS.listen $ CPS.writer v
182+
},
183+
runWriterProps "pass" WriterProp {
184+
lazy = Prop $ \(m :: BaseMonad, Bot (v :: ((), F1 [Int] [Int]))) ->
185+
let v' = coerce v :: ((), [Int] -> [Int])
186+
in isLazy $ withBaseMonad m $ Lazy.runWriterT $ Lazy.pass $ Lazy.writer (v', []),
187+
strict = Prop $ \(m :: BaseMonad, Bot (v :: ((), F1 [Int] [Int]))) ->
188+
let v' = coerce v :: ((), [Int] -> [Int])
189+
in isStrict v $ withBaseMonad m $ Strict.runWriterT $ Strict.pass $ Strict.writer (v', []),
190+
cps = Prop $ \(m :: BaseMonad, Bot (v :: ((), F1 [Int] [Int]))) ->
191+
let v' = coerce v :: ((), [Int] -> [Int])
192+
in isStrict v $ withBaseMonad m $ CPS.runWriterT $ CPS.pass $ CPS.writer (v', [])
193+
},
194+
runWriterProps "censor" WriterProp {
195+
lazy = Prop $ \(m :: BaseMonad, Bot (v :: ((), [Int]))) -> isLazy $ withBaseMonad m $ Lazy.runWriterT $ Lazy.censor id $ Lazy.writer v,
196+
strict = Prop $ \(m :: BaseMonad, Bot (v :: ((), [Int]))) -> isStrict v $ withBaseMonad m $ Strict.runWriterT $ Strict.censor id $ Strict.writer v,
197+
cps = Prop $ \(m :: BaseMonad, Bot (v :: ((), [Int]))) -> isStrict v $ withBaseMonad m $ CPS.runWriterT $ CPS.censor id $ CPS.writer v
198+
},
199+
200+
-- == Functor/Applicative/Monad ==
201+
runWriterProps "Monad: >>=" WriterProp {
202+
lazy = Prop $ \(m :: BaseMonad, Bot v :: (Bot ((), String)), Bot w :: (Bot (Int, String))) ->
203+
isLazy $ withBaseMonad m $ Lazy.runWriterT $ Lazy.writer v >>= const (Lazy.writer w),
204+
strict = Prop $ \(m :: BaseMonad, Bot v :: (Bot ((), String)), Bot w :: (Bot (Int, String))) ->
205+
isStrict2 v w $ withBaseMonad m $ Strict.runWriterT $ Strict.writer v >>= const (Strict.writer w),
206+
cps = Prop $ \(m :: BaseMonad, Bot v :: (Bot ((), String)), Bot w :: (Bot (Int, String))) ->
207+
isStrict2 v w $ withBaseMonad m $ CPS.runWriterT $ CPS.writer v >>= const (CPS.writer w)
208+
},
209+
runWriterProps "Alternative: <|>" WriterProp {
210+
lazy = Prop $ \(v :: [Bot (Int, String)], w :: [Bot (Int, String)]) ->
211+
let v' = coerce v :: [(Int, String)]
212+
w' = coerce w :: [(Int, String)]
213+
in isBottom (Lazy.runWriterT (Lazy.WriterT v' <|> Lazy.WriterT w')) === False,
214+
strict = Prop $ \(v :: [Bot (Int, String)], w :: [Bot (Int, String)]) ->
215+
let v' = coerce v :: [(Int, String)]
216+
w' = coerce w :: [(Int, String)]
217+
in any isBottom (Strict.runWriterT (Strict.WriterT v' <|> Strict.WriterT w')) === (any isBottom v' || any isBottom w'),
218+
cps = Prop $ \(v :: [Bot (Int, String)], w :: [Bot (Int, String)]) ->
219+
let v' = coerce v :: [(Int, String)]
220+
w' = coerce w :: [(Int, String)]
221+
in any isBottom (CPS.runWriterT (CPS.writerT v' <|> CPS.writerT w')) === (any isBottom v' || any isBottom w')
222+
},
223+
224+
-- == Other type classes ==
225+
runWriterProps "Foldable: foldMap" WriterProp {
226+
-- NOTE: foldMap is lazy in both Lazy and Strict Writers due to the use of fst to pick the value.
227+
lazy = Prop $ \(v :: [Bot (Int, String)]) ->
228+
let v' = coerce v :: [(Int, String)] in isLazyValue $ getSum $ foldMap (const (Sum (0 :: Int))) (Lazy.WriterT v'),
229+
strict = Prop $ \(v :: [Bot (Int, String)]) ->
230+
let v' = coerce v :: [(Int, String)] in isLazyValue $ getSum $ foldMap (const (Sum (0 :: Int))) (Strict.WriterT v'),
231+
cps = Unsupported
232+
},
233+
runWriterProps "contramap" WriterProp {
234+
lazy = Prop $ \(Bot (v :: (Int, String))) ->
235+
let f = getOp $ Lazy.runWriterT $ contramap (+1) $ Lazy.WriterT (Op id) in isLazyValue $ f v,
236+
strict = Prop $ \(Bot (v :: (Int, String))) ->
237+
let f = getOp $ Strict.runWriterT $ contramap (+1) $ Strict.WriterT (Op id) in isStrictValue v $ f v,
238+
cps = Unsupported
239+
}
240+
]
241+
242+
strictLogTest :: [TestTree]
243+
strictLogTest = [
244+
runWriterProps "runWriter" WriterProp {
245+
lazy = Prop $ \(m :: BaseMonad, Bot (v :: Sum Int)) -> isLazy (withBaseMonad m $ Lazy.runWriterT $ Lazy.writer ((), v)),
246+
strict = Prop $ \(m :: BaseMonad, Bot (v :: Sum Int)) -> isLazy (withBaseMonad m $ Strict.runWriterT $ Strict.writer ((), v)),
247+
cps = Prop $ \(m :: BaseMonad, Bot (v :: Sum Int)) -> isStrict v (withBaseMonad m $ CPS.runWriterT $ CPS.writer ((), v))
248+
},
249+
runWriterProps "mapWriter" WriterProp {
250+
lazy = Prop $ \(m :: BaseMonad, Bot (v :: String)) -> isLazy (withBaseMonad m $ Lazy.runWriterT $ Lazy.mapWriterT id $ Lazy.writer (0 :: Int, v)),
251+
strict = Prop $ \(m :: BaseMonad, Bot (v :: String)) -> isLazy (withBaseMonad m $ Strict.runWriterT $ Strict.mapWriterT id $ Strict.writer(0 :: Int, v)),
252+
cps = Prop $ \(m :: BaseMonad, Bot (v :: String)) -> isStrict v (withBaseMonad m $ CPS.runWriterT $ CPS.mapWriterT id $ CPS.writer (0 :: Int, v))
253+
},
254+
runWriterProps "listen" WriterProp {
255+
lazy = Prop $ \(m :: BaseMonad, Bot (v :: Sum Int)) -> isLazy (withBaseMonad m $ Lazy.runWriterT $ Lazy.listen $ Lazy.writer ((), v)),
256+
strict = Prop $ \(m :: BaseMonad, Bot (v :: Sum Int)) -> isLazy (withBaseMonad m $ Strict.runWriterT $ Strict.listen $ Strict.writer ((), v)),
257+
cps = Prop $ \(m :: BaseMonad, Bot (v :: Sum Int)) -> isStrict v (withBaseMonad m $ CPS.runWriterT $ CPS.listen $ CPS.writer ((), v))
258+
},
259+
runWriterProps "tell" WriterProp {
260+
lazy = Prop $ \(m :: BaseMonad, Bot (v :: String)) -> isLazy (withBaseMonad m $ Lazy.runWriterT $ Lazy.tell v),
261+
strict = Prop $ \(m :: BaseMonad, Bot (v :: String)) -> isLazy (withBaseMonad m $ Strict.runWriterT $ Strict.tell v),
262+
cps = Prop $ \(m :: BaseMonad, Bot (v :: String)) -> isStrict v (withBaseMonad m $ CPS.runWriterT $ CPS.tell v)
263+
}
264+
]
265+
137266
-- | Strictness tests for the value (a, w) of Writers
138267
--
139268
-- Test whether the pair (a, w) is handled lazily/strictly
@@ -641,7 +770,7 @@ runTestMonadStack m cont = runReaderT rd 0
641770
const2 :: a -> b -> c -> a
642771
const2 = const . const
643772

644-
test_pair_strictness_monad :: forall k writer w (m :: k) a b. (writer w m a -> b) -> Bool -> writer w m a -> Property
773+
test_pair_strictness_monad :: (writer w m a -> b) -> Bool -> writer w m a -> Property
645774
test_pair_strictness_monad runWriter expected writer = test_pair_strictness_IOBase expected $ evaluate (runWriter writer)
646775

647776
test_pair_strictness_IO :: (writer w IO a -> IO b) -> Bool -> writer w IO a -> Property
@@ -652,3 +781,32 @@ test_pair_strictness_IOBase True v = assertExceptionIO @ErrorCall (const True) v
652781
test_pair_strictness_IOBase False v = monadicIO $ run $ do
653782
v' <- v
654783
v' `seq` return ()
784+
785+
isStrictValue :: arg1 -> a -> Property
786+
isStrictValue x = isStrict x . evaluate
787+
788+
isLazyValue :: a -> Property
789+
isLazyValue = isLazy . evaluate
790+
791+
-- Strictness in one argument:
792+
-- The result (normalized to IO) should be bottom whenever arg1 is bottom.
793+
isStrict :: arg1 -> IO a -> Property
794+
isStrict x = shouldBeBottom (isBottom x)
795+
796+
-- Strictness in two arguments:
797+
-- The result (normalized to IO) should be bottom whenever arg1 OR arg2 is bottom.
798+
isStrict2 :: arg1 -> arg2 -> IO a -> Property
799+
isStrict2 x y = shouldBeBottom (isBottom x || isBottom y)
800+
801+
isLazy :: IO a -> Property
802+
isLazy = shouldBeBottom False
803+
804+
shouldBeBottom :: Bool -> IO a -> Property
805+
shouldBeBottom True result = assertExceptionIO isBottomError result
806+
where
807+
-- Check error message only i.e. prefix, ignoring stacktrace.
808+
isBottomError :: ErrorCall -> Bool
809+
isBottomError e = "<bottom>" `isPrefixOf` displayException e
810+
shouldBeBottom False result = monadicIO $ run $ do
811+
v <- result
812+
v `seq` return ()

0 commit comments

Comments
 (0)