{-# LANGUAGE CPP #-}
module Control.AutoUpdate (
UpdateSettings
, defaultUpdateSettings
, updateAction
, updateFreq
, updateSpawnThreshold
, mkAutoUpdate
, mkAutoUpdateWithModify
) where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative ((<*>))
#endif
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar,
takeMVar, tryPutMVar)
import Control.Exception (SomeException, catch, mask_, throw,
try)
import Control.Monad (void)
import Data.IORef (newIORef, readIORef, writeIORef)
defaultUpdateSettings :: UpdateSettings ()
defaultUpdateSettings :: UpdateSettings ()
defaultUpdateSettings = UpdateSettings
{ updateFreq :: Int
updateFreq = Int
1000000
, updateSpawnThreshold :: Int
updateSpawnThreshold = Int
3
, updateAction :: IO ()
updateAction = forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
data UpdateSettings a = UpdateSettings
{ forall a. UpdateSettings a -> Int
updateFreq :: Int
, forall a. UpdateSettings a -> Int
updateSpawnThreshold :: Int
, forall a. UpdateSettings a -> IO a
updateAction :: IO a
}
mkAutoUpdate :: UpdateSettings a -> IO (IO a)
mkAutoUpdate :: forall a. UpdateSettings a -> IO (IO a)
mkAutoUpdate UpdateSettings a
us = forall a. UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)
mkAutoUpdateHelper UpdateSettings a
us forall a. Maybe a
Nothing
mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a)
mkAutoUpdateWithModify :: forall a. UpdateSettings a -> (a -> IO a) -> IO (IO a)
mkAutoUpdateWithModify UpdateSettings a
us a -> IO a
f = forall a. UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)
mkAutoUpdateHelper UpdateSettings a
us (forall a. a -> Maybe a
Just a -> IO a
f)
mkAutoUpdateHelper :: UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)
mkAutoUpdateHelper :: forall a. UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)
mkAutoUpdateHelper UpdateSettings a
us Maybe (a -> IO a)
updateActionModify = do
MVar ()
needsRunning <- forall a. IO (MVar a)
newEmptyMVar
MVar a
responseVar0 <- forall a. IO (MVar a)
newEmptyMVar
IORef (Either (MVar a) a)
currRef <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left MVar a
responseVar0
let fillRefOnExit :: IO () -> IO ()
fillRefOnExit IO ()
f = do
Either SomeException ()
eres <- forall e a. Exception e => IO a -> IO (Either e a)
try IO ()
f
case Either SomeException ()
eres of
Left SomeException
e -> forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (MVar a) a)
currRef forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
[Char]
"Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (SomeException
e :: SomeException)
Right () -> forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (MVar a) a)
currRef forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
[Char]
"Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "
forall a. [a] -> [a] -> [a]
++ [Char]
"which should be impossible due to usage of infinite loop"
forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
fillRefOnExit forall a b. (a -> b) -> a -> b
$ do
let loop :: MVar a -> Maybe a -> IO b
loop MVar a
responseVar Maybe a
maybea = do
forall a. MVar a -> IO a
takeMVar MVar ()
needsRunning
a
a <- forall a. IO a -> IO a
catchSome forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. UpdateSettings a -> IO a
updateAction UpdateSettings a
us) forall a. a -> a
id (Maybe (a -> IO a)
updateActionModify forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe a
maybea)
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (MVar a) a)
currRef forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
a
forall a. MVar a -> a -> IO ()
putMVar MVar a
responseVar a
a
Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ forall a. UpdateSettings a -> Int
updateFreq UpdateSettings a
us
MVar a
responseVar' <- forall a. IO (MVar a)
newEmptyMVar
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (MVar a) a)
currRef forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left MVar a
responseVar'
MVar a -> Maybe a -> IO b
loop MVar a
responseVar' (forall a. a -> Maybe a
Just a
a)
forall {b}. MVar a -> Maybe a -> IO b
loop MVar a
responseVar0 forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
Either (MVar a) a
mval <- forall a. IORef a -> IO a
readIORef IORef (Either (MVar a) a)
currRef
case Either (MVar a) a
mval of
Left MVar a
responseVar -> do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
needsRunning ()
forall a. MVar a -> IO a
readMVar MVar a
responseVar
Right a
val -> forall (m :: * -> *) a. Monad m => a -> m a
return a
val
catchSome :: IO a -> IO a
catchSome :: forall a. IO a -> IO a
catchSome IO a
act = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch IO a
act forall a b. (a -> b) -> a -> b
$ \SomeException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a e. Exception e => e -> a
throw (SomeException
e :: SomeException)