module HAppS.Util.Concurrent where
import Control.Concurrent
import Prelude hiding (catch)
import Control.Exception
#ifdef INTERACTIVE
import System.IO.Unsafe
import System.Mem
#endif
forkEverSt :: (t -> IO t) -> t -> IO ThreadId
forkEverSt f state = fork (foreverSt f state)
foreverSt :: (Monad m) => (t -> m t) -> t -> m b
foreverSt f state=do {newState<-f state;foreverSt f newState;}
forkEver :: IO a -> IO ThreadId
forkEver a = fork (forever a)
writeChanRight :: Chan (Either a b) -> b -> IO ()
writeChanRight chan x= writeChan chan (Right x)
writeChanLeft :: Chan (Either a b) -> a -> IO ()
writeChanLeft chan x= writeChan chan (Left x)
fork_ :: IO a -> IO ()
fork_ c = fork c >> return ()
fork :: IO a -> IO ThreadId
registerResetAction :: IO () -> IO ()
reset :: IO ()
forever :: IO a -> IO a
#ifndef INTERACTIVE
forever a = do {finally a (forever a)}
fork c = forkIO (c >> return ())
registerResetAction _ = return ()
reset = return ()
#else
forever a = try a >>= w
where w (Right _) = forever a
w (Left (AsyncException ThreadKilled)) = return ()
w (Left e) = print e >> forever a
registerResetAction x = modifyMVar_ happsThreadList (return . (x:))
fork c = do
x <- forkIO (c >> return ())
modifyMVar_ happsThreadList (\xs -> return (killThread x:xs))
return x
reset = do xs <- swapMVar happsThreadList []
sequence_ xs
threadDelay 10000
performGC
logM "HAppS.Util.Concurrent" INFO "reset ok"
happsThreadList = unsafePerformIO $ newMVar []
#endif
sleep :: Int -> IO ()
sleep n = threadDelay (n * second) where second = 1000000