@@ -2,6 +2,7 @@ module Main (main) where
22
33import Asyncly
44import Control.Applicative ((<|>), empty)
5+import Control.Monad (mzero)
56import Control.Concurrent (myThreadId, threadDelay)
67import Data.Monoid ((<>))
78import Control.Monad.IO.Class (liftIO)
@@ -12,61 +13,105 @@ default (Int)
1213
1314main :: IO ()
1415main = hspec $ do
15− it "simple runAsyncly" $
16− runAsyncly (return 0) `shouldReturn` ()
17− it "simple runAsyncly with IO" $
18− runAsyncly (liftIO $ putStrLn "hello") `shouldReturn` ()
19− it "Captures a return value using toList" $
20− toList (return 0) `shouldReturn` ([0] :: [Int])
21− it "Monoid composition" $
22− toList (return 0 <> return 1) `shouldReturn` ([0, 1] :: [Int])
23− it "Monoid composition - each" $
24− ((toList $ forEachWith (<>) [1..100] return) >>= return . sort) `shouldReturn` ([1..100] :: [Int])
25− it "Interleaved composition" $
26− toList (return (0 :: Int) <> return 1 <=> return 100 <> return 101)
27− `shouldReturn` ([0, 100, 1, 101])
28− it "simple runAsyncly and 'then' with IO" $
29− runAsyncly (liftIO (putStrLn "hello") >> liftIO (putStrLn "world")) `shouldReturn` ()
16+ describe "Runners" $ do
17+ it "simple runAsyncly" $
18+ runAsyncly (return 0) `shouldReturn` ()
19+ it "simple runAsyncly with IO" $
20+ runAsyncly (liftIO $ putStrLn "hello") `shouldReturn` ()
21+ it "Captures a return value using toList" $
22+ toList (return 0) `shouldReturn` ([0] :: [Int])
23+
24+ describe "Empty" $ do
25+ it "Monoid - mempty" $
26+ (toList mempty) `shouldReturn` ([] :: [Int])
27+ it "Alternative - empty" $
28+ (toList empty) `shouldReturn` ([] :: [Int])
29+ it "MonadPlus - mzero" $
30+ (toList mzero) `shouldReturn` ([] :: [Int])
31+
32+ describe "Bind" bind
33+
34+ describe "Serial Composition (<>)" $ compose (<>) id
35+ describe "Left Biased parallel Composition (<|)" $ compose (<|) sort
36+ describe "Fair parallel Composition (<|>)" $ compose (<|>) sort
37+ describe "Serial interleaved (<=>)" $ interleaved (<=>)
38+ describe "Parallel interleaved (<|>)" $ interleaved (<|>)
39+
40+ describe "Serial loops (<>)" $ loops (<>) id reverse
41+ describe "Left Biased parallel loops (<|)" $ loops (<|) sort sort
42+ describe "Fair parallel loops (<|>)" $ loops (<|>) sort sort
43+
44+bind = do
45+ it "Simple runAsyncly and 'then' with IO" $
46+ runAsyncly (liftIO (putStrLn "hello") >> liftIO (putStrLn "world"))
47+ `shouldReturn` ()
3048 it "Then and toList" $
3149 toList (return 1 >> return 2) `shouldReturn` ([2] :: [Int])
3250 it "Bind and toList" $
33− toList (do x <- return 1; y <- return 2; return (x + y)) `shouldReturn` ([3] :: [Int])
34− it "Alternative - empty" $
35− (toList empty) `shouldReturn` ([] :: [Int])
36− it "Alternative composition - empty <|> empty" $
37− (toList (empty <|> empty)) `shouldReturn` ([] :: [Int])
38− it "Alternative composition - empty at the beginning" $
39− (toList $ (empty <|> return 1)) `shouldReturn` ([1] :: [Int])
40− it "Alternative composition - empty at the end" $
41− (toList $ (return 1 <|> empty)) `shouldReturn` ([1] :: [Int])
42− it "Alternative composition" $
43− ((toList $ (return 0 <|> return 1)) >>= return . sort) `shouldReturn` ([0, 1] :: [Int])
44− it "Alternative composition - empty in the middle" $
45− ((toList $ (return 0 <|> empty <|> return 1)) >>= return . sort) `shouldReturn` ([0, 1] :: [Int])
46− it "Alternative composition - left associated" $
47− ((toList $ (((return 0 <|> return 1) <|> return 2) <|> return 3)) >>= return . sort) `shouldReturn` ([0, 1, 2, 3] :: [Int])
48− it "Alternative composition - right associated" $
49− ((toList $ (return 0 <|> (return 1 <|> (return 2 <|> return 3)))) >>= return . sort) `shouldReturn` ([0, 1, 2, 3] :: [Int])
50− it "Alternative composition (right fold) with bind" $
51− (toList (forEachWith (<|>) [1..10 :: Int] $ \x -> return x >>= return . id) >>= return . sort) `shouldReturn` ([1..10] :: [Int])
52− it "Alternative composition (left fold) with bind" $
53− let forL xs f = foldl (<|>) empty $ map f xs
54− in (toList (forL [1..10 :: Int] $ \x -> return x >>= return . id) >>= return . sort) `shouldReturn` ([1..10] :: [Int])
55− it "Alternative composition - hierarchical" $
56− ((toList $ (((return 0 <|> return 1) <|> (return 2 <|> return 3))
57− <|> ((return 4 <|> return 5) <|> (return 6 <|> return 7)))
58− ) >>= return . sort) `shouldReturn` ([0..7] :: [Int])
59− it "loopHead" $
60− toList (loopHead (0 :: Int)) `shouldReturn` ([3, 2..0] :: [Int])
61− it "loopHeadA" $
62− (toList (loopHeadA (0 :: Int)) >>= return . sort)
51+ toList (do x <- return 1; y <- return 2; return (x + y))
52+ `shouldReturn` ([3] :: [Int])
53+
54+interleaved f =
55+ it "Interleave four" $
56+ toList ((return (0 :: Int) <> return 1) `f` (return 100 <> return 101))
57+ `shouldReturn` ([0, 100, 1, 101])
58+
59+compose f srt = do
60+ it "Compose mempty, mempty" $
61+ (toList (mempty `f` mempty)) `shouldReturn` ([] :: [Int])
62+ it "Compose empty, empty" $
63+ (toList (empty `f` empty)) `shouldReturn` ([] :: [Int])
64+ it "Compose empty at the beginning" $
65+ (toList $ (empty `f` return 1)) `shouldReturn` ([1] :: [Int])
66+ it "Compose empty at the end" $
67+ (toList $ (return 1 `f` empty)) `shouldReturn` ([1] :: [Int])
68+ it "Compose two" $
69+ (toList (return 0 `f` return 1) >>= return . srt)
70+ `shouldReturn` ([0, 1] :: [Int])
71+ it "Compose three - empty in the middle" $
72+ ((toList $ (return 0 `f` empty `f` return 1)) >>= return . srt)
73+ `shouldReturn` ([0, 1] :: [Int])
74+ it "Compose left associated" $
75+ ((toList $ (((return 0 `f` return 1) `f` return 2) `f` return 3))
76+ >>= return . srt) `shouldReturn` ([0, 1, 2, 3] :: [Int])
77+ it "Compose right associated" $
78+ ((toList $ (return 0 `f` (return 1 `f` (return 2 `f` return 3))))
79+ >>= return . srt) `shouldReturn` ([0, 1, 2, 3] :: [Int])
80+ it "Compose many" $
81+ ((toList $ forEachWith f [1..100] return) >>= return . srt)
82+ `shouldReturn` ([1..100] :: [Int])
83+ it "Compose many (right fold) with bind" $
84+ (toList (forEachWith f [1..10 :: Int] $ \x -> return x >>= return . id)
85+ >>= return . srt) `shouldReturn` ([1..10] :: [Int])
86+ it "Compose many (left fold) with bind" $
87+ let forL xs k = foldl f empty $ map k xs
88+ in (toList (forL [1..10 :: Int] $ \x -> return x >>= return . id)
89+ >>= return . srt) `shouldReturn` ([1..10] :: [Int])
90+ it "Compose hierarchical (multiple levels)" $
91+ ((toList $ (((return 0 `f` return 1) `f` (return 2 `f` return 3))
92+ `f` ((return 4 `f` return 5) `f` (return 6 `f` return 7)))
93+ ) >>= return . srt) `shouldReturn` ([0..7] :: [Int])
94+
95+loops f tsrt hsrt = do
96+ it "Tail recursive loop" $
97+ (toList (loopTail (0 :: Int)) >>= return . tsrt)
6398 `shouldReturn` ([0..3] :: [Int])
64− it "loopTail" $
65− toList (loopTail (0 :: Int)) `shouldReturn` ([0..3] :: [Int])
66− it "loopTailA" $
67− (toList (loopTailA (0 :: Int)) >>= return . sort)
99+
100+ it "Head recursive loop" $
101+ (toList (loopHead (0 :: Int)) >>= return . hsrt)
68102 `shouldReturn` ([0..3] :: [Int])
69103
104+ where
105+ loopHead x = do
106+ -- this print line is important for the test (causes a bind)
107+ liftIO $ putStrLn "LoopHead..."
108+ (if x < 3 then loopHead (x + 1) else empty) `f` return x
109+
110+ loopTail x = do
111+ -- this print line is important for the test (causes a bind)
112+ liftIO $ putStrLn "LoopTail..."
113+ return x `f` (if x < 3 then loopTail (x + 1) else empty)
114+
70115 {-
71116 it "Alternative composition of async and sync tasks" $
72117 ((wait (threads 0 ((async (return 0) <|> return 1)))) >>= return . sort)
@@ -164,27 +209,6 @@ main = hspec $ do
164209 ) >>= return . sort)
165210 `shouldReturn` ([0, 1] :: [Int])
166211 -}
167− where
168− loopHead x = do
169− -- this print line is important for the test (causes a bind)
170− liftIO $ putStrLn "LoopHead..."
171− (if x < 3 then loopHead (x + 1) else empty) <> return x
172−
173− loopHeadA x = do
174− -- this print line is important for the test (causes a bind)
175− liftIO $ putStrLn "LoopHeadA..."
176− (if x < 3 then loopHeadA (x + 1) else empty) <|> return x
177−
178− loopTailA x = do
179− -- this print line is important for the test (causes a bind)
180− liftIO $ putStrLn "LoopTailA..."
181− return x <|> (if x < 3 then loopTailA (x + 1) else empty)
182−
183− loopTail x = do
184− -- this print line is important for the test (causes a bind)
185− liftIO $ putStrLn "LoopTail..."
186− return x <> (if x < 3 then loopTail (x + 1) else empty)
187−
188212{-
189213generalExample :: AsyncT IO Int
190214generalExample = do