GHCJS: calling async JS functions in parallel, with time limits

async.hs

{-# LANGUAGE JavaScriptFFI #-}
module Main where

import Control.Concurrent
import Control.Monad

-- | Very simple, no exception safety. Intended for async JS functions.
parallel :: [IO a] -> IO [a]
parallel fs = do
  vars <- forM fs $ \f -> do
    v <- newEmptyMVar
    _ <- forkIO $ f >>= putMVar v
    return v
  mapM takeMVar vars

-- | Just your average async JS function.
foreign import javascript interruptible
  " console.log('Starting ' + $1); \
  \ setTimeout(function(){         \
  \   console.log('Ending ' + $1); \
  \   $c($1 * 100);                \
  \ }, $1 * 1000);                 "
  seconds :: Int -> IO Int

-- | Waits a maximum of 5 seconds for the action to finish.
timeout :: IO a -> IO (Maybe a)
timeout f = do
  v <- newEmptyMVar
  _ <- forkIO $ f >>= putMVar v . Just
  _ <- forkIO $ threadDelay 5000000 >> putMVar v Nothing
  takeMVar v

main :: IO ()
main = do
  parallel (map timeout [seconds 1, seconds 2, seconds 10]) >>= print
  print "done"