Skip to content

Commit 1781938

Browse files
ynishizaynishiza
committed
[TEST] finalize State transformer tests
1 parent a1d2ef3 commit 1781938

5 files changed

Lines changed: 97 additions & 89 deletions

File tree

‎test/Arbitrary.hs‎

Lines changed: 26 additions & 53 deletions
Original file line numberDiff line numberDiff line change
@@ -9,8 +9,7 @@
99
module Arbitrary
1010
( Bot (..),
1111
BaseMonad,
12-
isStrictType,
13-
isStrictMonad,
12+
baseMonadName,
1413
F1 (..),
1514
F1Bot (..),
1615
withBaseMonad,
@@ -41,58 +40,32 @@ isBottomError e = "<bottom>" `isInfixOf` displayException e
4140
-- | Arbitrary (Bot a) values may be bottom.
4241
--
4342
-- Borrowed from container tests: https://github.com/haskell/containers/
44-
newtype Bot a
45-
= Bot { unBot :: a }
46-
47-
-- Strictness as a data type
48-
-- e.g.
49-
--
50-
-- newtype A = ... strict
51-
-- data A a = A a lazy
52-
-- data A a = A !a strict
53-
--
54-
data TypeStrictness = StrictType | LazyType
55-
deriving (Eq, Show)
56-
57-
-- Strictness in monadic sequencing.
58-
-- e.g.
59-
--
60-
-- Identity m >>= k = k (runIdentity m) lazy due to runIdentity
61-
--
62-
-- Solo MkSolo x >>= k = k x strict due to MkSolo
63-
--
64-
data MonadStrictness = StrictMonad | LazyMonad
65-
deriving (Eq, Show)
43+
newtype Bot a = Bot { unBot :: a }
6644

6745
data BaseMonad
68-
= forall m. (Typeable m, Monad m) => BaseMonad TypeStrictness MonadStrictness (forall a. m a -> IO a)
46+
= forall m. (Typeable m, Monad m) => BaseMonad (forall a. m a -> IO a)
6947

7048
-- Use the underlying Monad of a BaseMonad.
7149
withBaseMonad :: BaseMonad -> (forall m. (Monad m) => m a) -> IO a
72-
withBaseMonad (BaseMonad _ _ v) = v
50+
withBaseMonad (BaseMonad v) = v
7351

74-
isStrictType :: BaseMonad -> Bool
75-
isStrictType (BaseMonad t _ _) = t == StrictType
76-
77-
isStrictMonad :: BaseMonad -> Bool
78-
isStrictMonad (BaseMonad _ t _) = t == StrictMonad
52+
baseMonadName :: BaseMonad -> String
53+
baseMonadName (BaseMonad m) = getName m
54+
where
55+
getName :: forall m. (Typeable m) => (forall a. m a -> IO a) -> String
56+
getName _ = show $ typeRep (Proxy @m)
7957

8058
instance Arbitrary BaseMonad where
8159
arbitrary =
8260
elements
83-
[ BaseMonad LazyType StrictMonad id, -- IO
84-
BaseMonad StrictType LazyMonad (evaluate . runIdentity), -- Identity
85-
BaseMonad LazyType StrictMonad (evaluate . getSolo), -- Solo
86-
BaseMonad LazyType LazyMonad (\f -> evaluate $ f ()) -- constant function () -> a
61+
[ BaseMonad id, -- IO
62+
BaseMonad (evaluate . runIdentity), -- Identity: newtype, lazy sequencing
63+
BaseMonad (evaluate . getSolo), -- Solo: lazy type, strict sequencing
64+
BaseMonad (\f -> evaluate $ f ()) -- constant function () -> a: lazy type, lazy sequencing
8765
]
8866

8967
instance Show BaseMonad where
90-
show v@(BaseMonad _ _ m) = getName m <> " [" <> typeLabel <> " " <> monadLabel <> "]"
91-
where
92-
typeLabel = "type:" <> (if isStrictType v then "strict" else "lazy")
93-
monadLabel = "monad:" <> (if isStrictMonad v then "strict" else "lazy")
94-
getName :: forall m. (Typeable m) => (forall a. m a -> IO a) -> String
95-
getName _ = show $ typeRep (Proxy @m)
68+
show v@(BaseMonad {}) = "BaseMonad " <> baseMonadName v
9669

9770
instance Show a => Show (Bot a) where
9871
show (Bot x) = if isBottom x then "<bottom>" else show x
@@ -105,8 +78,7 @@ instance Arbitrary a => Arbitrary (Bot a) where
10578
]
10679

10780
-- | Arbitrary function of one argument.
108-
newtype F1 a b
109-
= F1 { unF1 :: a -> b }
81+
newtype F1 a b = F1 { unF1 :: a -> b }
11082
deriving newtype (Arbitrary)
11183

11284
instance (Typeable a, Typeable b) => Show (F1 a b) where
@@ -124,8 +96,14 @@ instance (Typeable a, Typeable b) => Show (F1 a b) where
12496
--
12597
-- In particular, the QuickCheck built-in Func cannot be used for this, since
12698
-- Func a (Bot b) generates a function which may or may not bottom depending on the input.
127-
newtype F1Bot a b
128-
= F1Bot { unF1Bot :: a -> b }
99+
newtype F1Bot a b = F1Bot { unF1Bot :: a -> b }
100+
101+
isBottomFunc :: F1Bot a b -> Bool
102+
isBottomFunc (F1Bot f) = unsafePerformIO $ do
103+
result <- try (evaluate (f undefined))
104+
case result of
105+
Left (e :: ErrorCall) -> return $ isBottomError e
106+
_ -> return False
129107

130108
instance (CoArbitrary a, Arbitrary b) => Arbitrary (F1Bot a b) where
131109
arbitrary = do
@@ -137,14 +115,9 @@ instance (CoArbitrary a, Arbitrary b) => Arbitrary (F1Bot a b) where
137115

138116
instance (Typeable a, Typeable b) => Show (F1Bot a b) where
139117
show :: F1Bot a b -> String
140-
show (F1Bot f) = if unsafePerformIO isBottomFunc
141-
then a <> " -> bottom"
142-
else a <> " -> " <> b
118+
show f = if isBottomFunc f
119+
then a <> " -> bottom"
120+
else a <> " -> " <> b
143121
where
144-
isBottomFunc = do
145-
result <- try (evaluate (f undefined))
146-
case result of
147-
Left (e :: ErrorCall) -> return $ isBottomError e
148-
_ -> return False
149122
a = show $ typeRep (Proxy @a)
150123
b = show $ typeRep (Proxy @b)

‎test/StateStrictness.hs‎

Lines changed: 53 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -26,10 +26,14 @@ import Test.Tasty.QuickCheck
2626
test :: TestTree
2727
test = testGroup "State" strictnessTest
2828

29+
-- | NOTE: Strictness test
30+
--
31+
-- See note in WriterStrictness.hs regarding the choice of Solo as the monad used for testing.
32+
--
2933
strictnessTest :: [TestTree]
3034
strictnessTest = [
31-
-- NOTE: Lazy and Strict are the same since there is no computational sequence involved.
32-
-- The output is exactly the same as the input.
35+
-- NOTE: Lazy and Strict are the same since there is no computation involved.
36+
-- i.e. just returns the input.
3337
testGroup "evalStateT" [
3438
testProperty "Lazy" $ \(F1Bot (x :: () -> (Int, ()))) ->
3539
let result = flip Lazy.evalStateT () $ Lazy.StateT (MkSolo . x)
@@ -49,8 +53,7 @@ strictnessTest = [
4953
],
5054

5155
testGroup "withStateT" [
52-
-- NOTE: Lazy and Strict are the same since there is no computational sequence involved.
53-
-- The output is exactly the same as the input.
56+
-- NOTE: f is not evaluated strictly, so the result depends only on the original input.
5457
testProperty "Lazy" $ \(F1Bot (f :: () -> ())) (F1Bot (x :: () -> (Int, ()))) ->
5558
let result = flip Lazy.runStateT () $ Lazy.withStateT f (Lazy.StateT (MkSolo . x))
5659
in isLazy result .&. isStrictIn (x ()) (getSolo result),
@@ -59,14 +62,28 @@ strictnessTest = [
5962
in isLazy result .&. isStrictIn (x ()) (getSolo result)
6063
],
6164

65+
testGroup "mapStateT" [
66+
-- NOTE: f is applied directly on the underlying monad without any intervention by the State, so the result
67+
-- depends only on the result of f.
68+
testProperty "Lazy" $ \(F1Bot (f :: (Int, ()) -> (Int, ()))) ->
69+
let result = flip Lazy.runStateT () $ Lazy.mapStateT (f <$>) (Lazy.StateT (MkSolo . const (0, ())))
70+
in isLazy result .&. isStrictIn (f (0, ())) (getSolo result),
71+
testProperty "Strict" $ \(F1Bot (f :: (Int, ()) -> (Int, ())) ) ->
72+
let result = flip Strict.runStateT () $ Strict.mapStateT (f <$>) (Strict.StateT (MkSolo . const (0, ())))
73+
in isLazy result .&. isStrictIn (f (0, ())) (getSolo result)
74+
],
75+
6276
testGroup "put" [
63-
-- NOTE: Lazy and Strict are the same since there is no computational sequence involved.
77+
-- NOTE: lazy since there is no computation involved.
6478
testProperty "Lazy" $ \(Bot (x :: Int)) ->
6579
isValueLazy getSolo $ flip Lazy.runStateT 0 $ Lazy.put x,
6680
testProperty "Strict" $ \(Bot (x :: Int)) ->
67-
isValueLazy getSolo $ flip Lazy.runStateT 0 $ Lazy.put x
81+
isValueLazy getSolo $ flip Strict.runStateT 0 $ Strict.put x
6882
],
6983

84+
-- NOTE: modify and get variants, with the exception of modify',
85+
-- only act on the state s of the State's context (a, s).
86+
-- Hence, the mapping is evaluated lazily.
7087
testGroup "modify" [
7188
testProperty "Lazy" $ \(F1Bot (f :: Int -> Int)) ->
7289
isValueLazy getSolo $ flip Lazy.runStateT 0 $ Lazy.modify f,
@@ -85,14 +102,20 @@ strictnessTest = [
85102
testProperty "Strict" $ \(F1Bot (f :: Int -> Int)) ->
86103
isValueLazy getSolo $ flip Strict.runStateT 0 $ Strict.modifyM $ MkSolo . f
87104
],
88-
105+
testGroup "gets" [
106+
testProperty "Lazy" $ \(F1Bot (f :: Int -> ())) ->
107+
isValueLazy getSolo $ flip Lazy.runStateT 0 $ Lazy.gets f,
108+
testProperty "Strict" $ \(F1Bot (f :: Int -> ())) ->
109+
isValueLazy getSolo $ flip Strict.runStateT 0 $ Strict.gets f
110+
],
89111

90112
-- == Functor/Applicative/Monad ==
91113
testGroup "Functor: fmap" [
92114
testProperty "Lazy" $ \(F1Bot (x :: () -> (Int, ()))) ->
93115
isValueLazy getSolo $ flip Lazy.runStateT () $ (+1) <$> Lazy.StateT (MkSolo. x),
94-
testProperty "Strict" $ \(F1Bot (x :: () -> (Int, ()))) ->
116+
testProperty "Strict" $ \(F1Bot (x :: () -> (Int, ()))) ->
95117
let result = flip Strict.runStateT () $ (+1) <$> Strict.StateT (MkSolo . x)
118+
-- Does not bottom in the outer constructor since Functor only exposes control over the inner value.
96119
in isLazy result .&. isStrictIn (x ()) (getSolo result)
97120
],
98121

@@ -102,18 +125,17 @@ strictnessTest = [
102125
in isValueLazy getSolo $ flip Lazy.runStateT () $ Lazy.StateT (MkSolo . f') <*> Lazy.StateT (MkSolo . x),
103126
testProperty "Strict" $ \(F1Bot (x :: () -> (Int, ()))) (F1Bot (y :: () -> (F1 Int Int, ()))) ->
104127
let f' = coerce y :: () -> (Int -> Int, ())
105-
result = flip Strict.runStateT () $ Strict.StateT (MkSolo . f') <*> Strict.StateT (MkSolo . x)
106-
in isBiStrictIn (x ()) (f' ()) (getSolo result)
128+
result = flip Strict.runStateT () $ Strict.StateT (MkSolo . f') <*> Strict.StateT (MkSolo . x)
129+
in isBiStrictIn (x ()) (f' ()) result
107130
],
108131
testGroup "Applicative: liftA2" [
109132
testProperty "Lazy" $ \(F1Bot (x :: () -> (Int, ()))) (F1Bot (y :: () -> (Int, ()))) ->
110-
isValueLazy getSolo $ Lazy.runStateT (liftA2 (+) (Lazy.StateT $ MkSolo . x) (Lazy.StateT $ MkSolo . y)) (),
133+
isValueLazy getSolo $ Lazy.runStateT (liftA2 (+) (Lazy.StateT $ MkSolo . x) (Lazy.StateT $ MkSolo . y)) (),
111134
testProperty "Strict" $ \(F1Bot (x :: () -> (Int, ()))) (F1Bot (q :: () -> (Int, ()))) ->
112-
isBiStrictIn (x ()) (q ()) $ Strict.runStateT (liftA2 (+) (Strict.StateT $ MkSolo . x) (Strict.StateT $ MkSolo . q)) ()
135+
isBiStrictIn (x ()) (q ()) $ Strict.runStateT (liftA2 (+) (Strict.StateT $ MkSolo . x) (Strict.StateT $ MkSolo . q)) ()
113136
],
114137

115138
testGroup "Monad: >>=" [
116-
-- NOTE:
117139
testProperty "Lazy" $ \(F1Bot (x :: () -> (Int, ()))) (F1Bot (k :: () -> (Int, ()))) ->
118140
let result = flip Lazy.runStateT () $ Lazy.StateT (MkSolo . x) >>= const (Lazy.StateT (MkSolo . k))
119141
in isLazy result .&. isStrictIn (k ()) (getSolo result),
@@ -143,6 +165,7 @@ strictnessTest = [
143165
in x' () === runIdentity (Strict.runStateT (mfix (const (Strict.StateT $ Identity . x'))) ())
144166
],
145167

168+
146169
-- == Lift ==
147170
testGroup "liftListen" [
148171
testProperty "Lazy" $ \(F1Bot (x :: () -> (Int, ()))) ->
@@ -177,34 +200,40 @@ strictnessTest = [
177200
(F1Bot (x :: Int -> (String, Int)))
178201
(F1Bot (f :: Int -> Int))
179202
(Bot (s :: String))
180-
(Bot (t :: ())) ->
181-
-- TODO: Solo is strict in sequencing whereas Identity is lazy
203+
(Bot (t :: Int)) ->
204+
-- In general, the computations are lazy since this is the Lazy State.
182205
--
183-
-- MkSolo x >>= k = k x strict due to MkSolo
184-
-- x >>= k = k (runIdentity x) lazy due to runIdentity
206+
-- However, one exception is modify', which enforces strictness on the state value.
207+
-- Thus, modify' will bottom for monads which are strict in the underlying sequencing.
208+
-- i.e. Solo and IO
185209
--
186-
let expected = isStrictMonad m && isBottom (f (snd (x 0)))
210+
-- In particular, note that Identity is lazy whereas Solo is strict:
211+
--
212+
-- m >>= k = k (runIdentity m) lazy runIdentity
213+
-- MkSolo x >>= k = k x strict pattern match
214+
--
215+
let expected = (baseMonadName m == "Solo" || baseMonadName m == "IO") && isBottom (f (snd (x 0)))
187216
in shouldBeBottomIO expected $ withBaseMonad m $ flip Lazy.runStateT 0 $ do
188217
p <- Lazy.StateT $ return . x
189218
q <- Lazy.get
190-
Lazy.modify' f
219+
220+
Lazy.modify' f -- may throw depending on the underlying monad. See above.
221+
191222
Lazy.put $ q + length (s <> p)
192-
Lazy.gets (const t)
193-
,
223+
Lazy.gets (+ t),
194224

195225
testProperty "Strict" $
196226
\m
197227
(F1Bot (x :: Int -> (String, Int)))
198228
(F1Bot (f :: Int -> Int))
199229
(Bot (s :: String))
200-
(Bot (t :: ())) ->
230+
(Bot (t :: Int)) ->
201231
let expected = isBottom (x 0) || isBottom (f 0)
202232
in shouldBeBottomIO expected $ withBaseMonad m $ flip Strict.runStateT 0 $ do
203233
p <- Strict.StateT $ return . x
204234
q <- Strict.get
205235
Strict.modify' f
206236
Strict.put $ q + length (s <> p)
207-
Strict.gets (const t)
237+
Strict.gets (+ t)
208238
]
209239
]
210-

‎test/StrictnessCheck.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -48,8 +48,8 @@ isBiStrictIn :: arg1 -> arg2 -> o -> Property
4848
isBiStrictIn x y =
4949
let bottomX = isBottom x
5050
bottomY = isBottom y
51-
in label (bottomLabelFor "arg1" bottomX <> ", " <> bottomLabelFor "arg2" bottomY)
52-
. shouldBeBottom (bottomX || bottomY)
51+
in label (bottomLabelFor "arg1" bottomX <> ", " <> bottomLabelFor "arg2" bottomY)
52+
. shouldBeBottom (bottomX || bottomY)
5353

5454
shouldBeBottom :: Bool -> o -> Property
5555
shouldBeBottom expectBottom result = classify expectBottom bottomLabel $

‎test/WriterStrictness.hs‎

Lines changed: 9 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -68,21 +68,24 @@ type SumInt = Sum Int
6868
--
6969
-- if k _|_ = _|_ then also (return _|_) >>= k = _|_
7070
--
71-
-- b) lazy in its constructor
71+
-- b) does not short-circuit in the bind
72+
-- e.g. Maybe short-circuits
7273
--
73-
-- We employ Solo since it is a simple monad that has both properties.
74+
-- Nothing >>= _|_ = Nothing
75+
--
76+
-- c) lazy in its constructor
77+
--
78+
-- Considering the above, we employ Solo since it is a simple monad that has both properties.
7479
--
7580
-- The reasoning is as follows.
7681
-- The distinguishing feature of the strict writer is that it is strict in the sequencing of computations.
7782
-- To be precise, this means that when binding in the underlying monad, the map k used
7883
-- is strict with the strict writer and lazy with the lazy writer.
7984
-- The map k of the CPS writer is further strict in the log w of (a, w) >>= k.
8085
-- Thus, in order to observe this effect in tests, we need to use a monad that preserves this property.
81-
-- Not all monads satsify this property. e.g. Maybe may short-circuit
82-
--
83-
-- runWriter (WriterT Nothing >>= undefined) = Nothing
8486
--
85-
-- Using such a monad can complicate the tests.
87+
-- Short-circuiting is a problem since it also breaks the preservation of strictness, as seen in the Maybe example.
88+
-- Thus, using such a monad will also complicate the tests.
8689
--
8790
-- However, for the data type itself, we use one that is lazy.
8891
-- This is because otherwise, it becomes impossible to distinguish between a map k that bottoms in the monad itself or the computed value.

‎test/main.hs‎

Lines changed: 7 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,17 @@
11
module Main (main) where
22

33
import qualified ComposeT
4-
import qualified WriterStrictness
4+
55
import qualified StateStrictness
6-
import Test.Tasty
6+
7+
import Test.Tasty
8+
9+
import qualified WriterStrictness
710

811
main :: IO ()
912
main = do
1013
ComposeT.test
1114
defaultMain $ testGroup "Transformers" [
12-
WriterStrictness.test,
13-
StateStrictness.test
15+
StateStrictness.test,
16+
WriterStrictness.test
1417
]

0 commit comments

Comments
 (0)