gistfile1.hs

{-# LANGUAGE GADTs #-}

module Main (main) where

import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad

data Case r where
    Case :: STM a -> (a -> IO r) -> Case r

select :: [Case a] -> IO a
select cases = do
   lock <- newEmptyTMVarIO
   tids <- forM cases $ \(Case stm f) ->
       forkIO $ atomically $ stm >>= putTMVar lock . f
   join $ atomically (readTMVar lock) <* mapM_ killThread tids

defaultCase :: IO r -> Case r
defaultCase = Case (pure ()) . const

fibonacci :: TMVar Int -> TMVar () -> IO ()
fibonacci c quit = go 0 1
  where go x y = select [ Case (putTMVar c x) $ \_ -> go y (y + x)
                        , Case (takeTMVar quit) $ \_ -> putStrLn "quit"
                        ]
    
main :: IO ()
main = do
    c <- newEmptyTMVarIO
    quit <- newEmptyTMVarIO

    _ <- forkIO $ do
        replicateM_ 10 $ print =<< atomically (takeTMVar c)
        atomically $ putTMVar quit ()

    fibonacci c quit