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 f state = fork (foreverSt f state)
foreverSt f state=do {newState<-f state;foreverSt f newState;}
forkEver a = fork (forever a)
writeChanRight chan x= writeChan chan (Right x)
writeChanLeft chan x= writeChan chan (Left x)
ignoreFail ret op = op `catch`
(\err ->(error $ "\n\n\nFAILED"++(show err)) >> return ret)
fork_ :: IO a -> IO ()
fork_ c = fork c >> return ()
fork :: IO a -> IO ThreadId
registerResetAction :: IO () -> IO ()
reset :: IO ()
#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