swh:1:snp:36f6853f4c867e5bf757ecdd45b41d7d9a561f40
Tip revision: 8f1d807dc134d31bb868011182aeaeda4a4e0a92 authored by Simon Marlow on 25 September 2018, 19:31:59 UTC
0.4.7
0.4.7
Tip revision: 8f1d807
geturls7.hs
{-# LANGUAGE CPP #-}
import GetURL
import Control.Concurrent
#if __GLASGOW_HASKELL__ < 706
import ConcurrentUtils (forkFinally)
#endif
import Control.Exception
import qualified Data.ByteString as B
import Control.Concurrent.STM
-----------------------------------------------------------------------------
-- Our Async API:
-- <<Async
data Async a = Async ThreadId (TMVar (Either SomeException a))
-- >>
-- <<async
async :: IO a -> IO (Async a)
async action = do
var <- newEmptyTMVarIO
t <- forkFinally action (atomically . putTMVar var)
return (Async t var)
-- >>
--- <<watchCatch
waitCatch :: Async a -> IO (Either SomeException a)
waitCatch = atomically . waitCatchSTM
-- >>
-- <<waitCatchSTM
waitCatchSTM :: Async a -> STM (Either SomeException a)
waitCatchSTM (Async _ var) = readTMVar var
-- >>
-- <<waitSTM
waitSTM :: Async a -> STM a
waitSTM a = do
r <- waitCatchSTM a
case r of
Left e -> throwSTM e
Right a -> return a
-- >>
-- <<wait
wait :: Async a -> IO a
wait = atomically . waitSTM
-- >>
-- <<cancel
cancel :: Async a -> IO ()
cancel (Async t _) = throwTo t ThreadKilled
-- >>
-- <<waitEither
waitEither :: Async a -> Async b -> IO (Either a b)
waitEither a b = atomically $
fmap Left (waitSTM a)
`orElse`
fmap Right (waitSTM b)
-- >>
-- <<waitAny
waitAny :: [Async a] -> IO a
waitAny asyncs =
atomically $ foldr orElse retry $ map waitSTM asyncs
-- >>
-- <<withAsync
withAsync :: IO a -> (Async a -> IO b) -> IO b
withAsync io operation = bracket (async io) cancel operation
-- >>
-----------------------------------------------------------------------------
-- <<main
main =
withAsync (getURL "http://www.wikipedia.org/wiki/Shovel") $ \a1 ->
withAsync (getURL "http://www.wikipedia.org/wiki/Spade") $ \a2 -> do
r1 <- wait a1
r2 <- wait a2
print (B.length r1, B.length r2)
-- >>