@@ -1,6 +1,7 @@
11module Main (main) where
22
33import Control.Concurrent (threadDelay)
4+import Data.Foldable (forM_)
45import Data.List (sort)
56import Prelude hiding (take, drop)
67import Test.Hspec
@@ -25,32 +26,74 @@ main = hspec $ do
2526 it "MonadPlus - mzero" $
2627 (toList mzero) `shouldReturn` ([] :: [Int])
2728
28− describe "Bind" bind
29+ ---------------------------------------------------------------------------
30+ -- Binds
31+ ---------------------------------------------------------------------------
32+
33+ describe "Bind then" thenBind
34+ describe "Pure bind serial" $ pureBind (>>=)
35+ describe "Pure bind serial interleaved" $ pureBind (>->)
36+ describe "Pure bind parallel DFS" $ pureBind (>>|)
37+ describe "Pure bind parallel BFS" $ pureBind (>|>)
38+
39+ ---------------------------------------------------------------------------
40+ -- Compositions
41+ ---------------------------------------------------------------------------
2942
3043 describe "Serial Composition (<>)" $ compose (<>) id
31− describe "Serial interleaved (<=>)" $ interleaved (<=>) id
3244 describe "Left biased parallel Composition (<|)" $ compose (<|) sort
3345 describe "Fair parallel Composition (<|>)" $ compose (<|>) sort
46+
47+ ---------------------------------------------------------------------------
48+ -- Composition ordering checks
49+ ---------------------------------------------------------------------------
50+
51+ describe "Serial interleaved (<=>)" $ interleaved (<=>) id
3452 describe "Left biased parallel time order check" $ parallelCheck (<|)
3553 describe "Fair parallel time order check" $ parallelCheck (<|>)
3654 describe "Parallel interleaved (<|>)" $ interleaved (<|>) reverse
3755
56+ ---------------------------------------------------------------------------
57+ -- Composition recursion loops
58+ ---------------------------------------------------------------------------
59+
3860 describe "Serial loops (<>)" $ loops (<>) id reverse
3961 describe "Left biased parallel loops (<|)" $ loops (<|) sort sort
4062 describe "Fair parallel loops (<|>)" $ loops (<|>) sort sort
4163
64+ ---------------------------------------------------------------------------
65+ -- Bind and Composition combinations
66+ ---------------------------------------------------------------------------
67+
68+ forM_ [(>>=), (>->), (>>|), (>|>)] $ \f ->
69+ forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
70+ describe "Bind and compose" $ bindAndComposeSimple f g
71+
72+ let fldr f = foldr f empty
73+ fldl f = foldl f empty
74+ in forM_ [(>>=), (>->), (>>|), (>|>)] $ \f ->
75+ forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
76+ forM_ [fldr, fldl] $ \k ->
77+ describe "Bind and compose" $
78+ bindAndComposeHierarchy f (k g)
79+
80+ -- TBD combine all binds and all compose in one example
81+ describe "Miscellaneous combined examples" mixedOps
82+
4283 describe "Transformation" $ transformOps (<>)
43− describe "Miscellaneouse combined examples" mixedOps
4484
45−bind :: Spec
46−bind = do
85+thenBind :: Spec
86+thenBind = do
4787 it "Simple runAsyncly and 'then' with IO" $
4888 runAsyncly (liftIO (putStrLn "hello") >> liftIO (putStrLn "world"))
4989 `shouldReturn` ()
5090 it "Then and toList" $
5191 toList (return (1 :: Int) >> return 2) `shouldReturn` ([2] :: [Int])
92+
93+pureBind :: (AsyncT IO Int -> (Int -> AsyncT IO Int) -> AsyncT IO Int) -> Spec
94+pureBind f = do
5295 it "Bind and toList" $
53− toList (do x <- return 1; y <- return 2; return (x + y))
96+ toList (return 1 `f` \x -> return 2 `f` \y -> return (x + y))
5497 `shouldReturn` ([3] :: [Int])
5598
5699interleaved
@@ -102,13 +145,6 @@ compose f srt = do
102145 it "Compose many" $
103146 ((toList $ forEachWith f [1..100] return) >>= return . srt)
104147 `shouldReturn` [1..100]
105− it "Compose many (right fold) with bind" $
106− (toList (forEachWith f [1..10 :: Int] $ \x -> return x >>= return . id)
107− >>= return . srt) `shouldReturn` [1..10]
108− it "Compose many (left fold) with bind" $
109− let forL xs k = foldl f empty $ map k xs
110− in (toList (forL [1..10 :: Int] $ \x -> return x >>= return . id)
111− >>= return . srt) `shouldReturn` [1..10]
112148 it "Compose hierarchical (multiple levels)" $
113149 ((toList $ (((return 0 `f` return 1) `f` (return 2 `f` return 3))
114150 `f` ((return 4 `f` return 5) `f` (return 6 `f` return 7)))
@@ -137,6 +173,85 @@ loops f tsrt hsrt = do
137173 liftIO $ putStrLn "LoopTail..."
138174 return x `f` (if x < 3 then loopTail (x + 1) else empty)
139175
176+bindAndComposeSimple
177+ :: (AsyncT IO Int -> (Int -> AsyncT IO Int) -> AsyncT IO Int)
178+ -> (AsyncT IO Int -> AsyncT IO Int -> AsyncT IO Int)
179+ -> Spec
180+bindAndComposeSimple f g = do
181+ it "Compose many (right fold) with bind" $
182+ (toList (forEachWith g [1..10 :: Int] $ \x -> return x `f` (return . id))
183+ >>= return . sort) `shouldReturn` [1..10]
184+
185+ it "Compose many (left fold) with bind" $
186+ let forL xs k = foldl g empty $ map k xs
187+ in (toList (forL [1..10 :: Int] $ \x -> return x `f` (return . id))
188+ >>= return . sort) `shouldReturn` [1..10]
189+
190+bindAndComposeHierarchy
191+ :: (AsyncT IO Int -> (Int -> AsyncT IO Int) -> AsyncT IO Int)
192+ -> ([AsyncT IO Int] -> AsyncT IO Int)
193+ -> Spec
194+bindAndComposeHierarchy f g = do
195+ it "Bind and compose nested" $
196+ (toList bindComposeNested >>= return . sort)
197+ `shouldReturn` (sort (
198+ [12, 18]
199+ ++ replicate 3 13
200+ ++ replicate 3 17
201+ ++ replicate 6 14
202+ ++ replicate 6 16
203+ ++ replicate 7 15) :: [Int])
204+
205+ where
206+
207+ bindComposeNested :: AsyncT IO Int
208+ bindComposeNested =
209+ let c1 = tripleCompose (return 1) (return 2) (return 3)
210+ c2 = tripleCompose (return 4) (return 5) (return 6)
211+ c3 = tripleCompose (return 7) (return 8) (return 9)
212+ b = tripleBind c1 c2 c3
213+-- it seems to be causing a huge space leak in hspec so disabling this for now
214+-- c = tripleCompose b b b
215+-- m = tripleBind c c c
216+-- in m
217+ in b
218+
219+ tripleCompose a b c = g [a, b, c]
220+ tripleBind mx my mz =
221+ mx `f` \x -> my
222+ `f` \y -> mz
223+ `f` \z -> return (x + y + z)
224+
225+mixedOps :: Spec
226+mixedOps = do
227+ it "Compose many ops" $
228+ (toList composeMixed >>= return . sort)
229+ `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
230+ ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
231+ ] :: [Int])
232+ where
233+
234+ composeMixed :: AsyncT IO Int
235+ composeMixed = do
236+ liftIO $ return ()
237+ liftIO $ putStr ""
238+ x <- return 1
239+ y <- return 2
240+ z <- do
241+ x1 <- return 1 <|> return 2
242+ liftIO $ return ()
243+ liftIO $ putStr ""
244+ y1 <- return 1 <| return 2
245+ z1 <- do
246+ x11 <- return 1 <> return 2
247+ y11 <- return 1 <| return 2
248+ z11 <- return 1 <=> return 2
249+ liftIO $ return ()
250+ liftIO $ putStr ""
251+ return (x11 + y11 + z11)
252+ return (x1 + y1 + z1)
253+ return (x + y + z)
254+
140255transformOps :: (AsyncT IO Int -> AsyncT IO Int -> AsyncT IO Int) -> Spec
141256transformOps f = do
142257 it "take all" $
@@ -158,32 +273,3 @@ transformOps f = do
158273 it "drop 5" $
159274 (toList $ drop 5 $ foldMapWith f return [1..10])
160275 `shouldReturn` [6..10]
161−
162−mixedOps :: Spec
163−mixedOps = do
164− it "Compose many ops" $
165− (toList composeMixed >>= return . sort)
166− `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
167− ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
168− ] :: [Int])
169−
170−composeMixed :: AsyncT IO Int
171−composeMixed = do
172− liftIO $ return ()
173− liftIO $ putStr ""
174− x <- return 1
175− y <- return 2
176− z <- do
177− x1 <- return 1 <|> return 2
178− liftIO $ return ()
179− liftIO $ putStr ""
180− y1 <- return 1 <| return 2
181− z1 <- do
182− x11 <- return 1 <> return 2
183− y11 <- return 1 <| return 2
184− z11 <- return 1 <=> return 2
185− liftIO $ return ()
186− liftIO $ putStr ""
187− return (x11 + y11 + z11)
188− return (x1 + y1 + z1)
189− return (x + y + z)