Applicative async programming

asyncidiom.hs

import Control.Concurrent
import Control.Concurrent.Async
import Control.Applicative
import Control.Monad

import Data.Traversable

newtype Concurrently a = Concurrently { runConcurrently :: IO a }

instance Functor Concurrently where
  fmap f (Concurrently a) = Concurrently $ f <$> a

instance Applicative Concurrently where
  pure = Concurrently . return
  Concurrently fs <*> Concurrently as = 
    Concurrently $ (\(f, a) -> f a) <$> concurrently fs as

instance Alternative Concurrently where
  empty = Concurrently $ forever (threadDelay maxBound)
  Concurrently as <|> Concurrently bs = 
    Concurrently $ either id id <$> race as bs

doConcurrently :: Traversable t => (a -> IO b) -> t a -> IO (t b)
doConcurrently f = runConcurrently . traverse (Concurrently . f)

-- testing
getURL :: String -> IO String
getURL s = return $ "<" ++ s ++ ">" 

main :: IO ()
main = do
  
  (page1, page2, page3) 
    <-  runConcurrently $ (,,) 
    <$> Concurrently (getURL "url1") 
    <*> Concurrently (getURL "url2") 
    <*> Concurrently (getURL "url3")
  print [page1, page2, page3]

  pages <- doConcurrently getURL ["url1", "url2", "url3"]
  print pages
  
  page <- runConcurrently 
     $  Concurrently (getURL "url1")
    <|> empty
    <|> Concurrently (getURL "url2") 
  print page