module Main where

import Concurrent

type Answer b = Either IOError b

propagate :: Answer b-> IO b
propagate (Left e)  = ioError e
propagate (Right v) = return v

try :: (a-> IO b)-> a-> IO (Answer b)
try f a = catch (f a >>= return . Right) (return . Left)



data Service a b = Service (Chan (Req a b))
data Req a b     = Req a (MVar (Answer b))


newServer :: (a-> IO b)-> IO (Service a b)
newServer f = 
  do c<- newChan
     forkIO (serve c)
     return (Service c)
  where serve c = do (Req val s) <- readChan c
                     res <- try f val
                     catch (putMVar s res) (\_ -> return ())
                     serve c

call :: Service a b-> a -> IO (IO b)
call (Service ch) val = 
  do v<- newEmptyMVar
     writeChan ch (Req val v)
     return (takeMVar v >>= propagate)

-- a very silly test
main :: IO ()
main = 
 do s<- newServer (\x-> putStrLn "Computing..." >> return (x*(x::Int)))
    c<- call s 10
    putStrLn "called, waiting for result..."
    r<- c
    putStrLn ("Result: "++ show r)