module Control.AutoUpdate
( UpdateSettings
, defaultUpdateSettings
, updateFreq
, updateSpawnThreshold
, updateAction
, mkAutoUpdate
) where
import Control.Concurrent (ThreadId, forkIO, myThreadId, threadDelay)
import Control.Exception (Exception, SomeException
,assert, fromException, handle,throwIO, throwTo)
import Control.Monad (forever, join)
import Data.IORef (IORef, newIORef)
import Data.Typeable (Typeable)
#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#endif
#if MIN_VERSION_base(4,6,0)
import Data.IORef (atomicModifyIORef')
#else
import Data.IORef (atomicModifyIORef)
atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b
atomicModifyIORef' ref f = do
c <- atomicModifyIORef ref
(\x -> let (a, b) = f x
in (a, a `seq` b))
c `seq` return c
#endif
defaultUpdateSettings :: UpdateSettings ()
defaultUpdateSettings = UpdateSettings
{ updateFreq = 1000000
, updateSpawnThreshold = 3
, updateAction = return ()
}
data UpdateSettings a = UpdateSettings
{ updateFreq :: Int
, updateSpawnThreshold :: Int
, updateAction :: IO a
}
data Status a = AutoUpdated
!a
!Int
!ThreadId
| ManualUpdates
!Int
mkAutoUpdate :: UpdateSettings a -> IO (IO a)
mkAutoUpdate (UpdateSettings !f !t !a) = do
istatus <- newIORef $ ManualUpdates 0
return $! getCurrent f t a istatus
data Action a = Return a | Manual | Spawn
data Replaced = Replaced deriving (Show, Typeable)
instance Exception Replaced
getCurrent :: Int
-> Int
-> IO a
-> IORef (Status a)
-> IO a
getCurrent freq spawnThreshold update istatus = do
ea <- atomicModifyIORef' istatus increment
case ea of
Return a -> return a
Manual -> update
Spawn -> do
a <- update
tid <- forkIO $ spawn freq update istatus
join $ atomicModifyIORef' istatus $ turnToAuto a tid
return a
where
increment (AutoUpdated a cnt tid) = (AutoUpdated a (succ cnt) tid, Return a)
increment (ManualUpdates i) = (ManualUpdates (succ i), act)
where
act = if i > spawnThreshold then Spawn else Manual
turnToAuto a tid (ManualUpdates cnt) = (AutoUpdated a cnt tid
,return ())
turnToAuto a tid (AutoUpdated _ cnt old) = (AutoUpdated a cnt tid
,throwTo old Replaced)
spawn :: Int -> IO a -> IORef (Status a) -> IO ()
spawn freq update istatus = handle (onErr istatus) $ forever $ do
threadDelay freq
a <- update
join $ atomicModifyIORef' istatus $ turnToManual a
where
turnToManual a (AutoUpdated _ cnt tid)
| cnt >= 1 = (AutoUpdated a 0 tid, return ())
| otherwise = (ManualUpdates 0, stop)
turnToManual _ (ManualUpdates i) = assert False (ManualUpdates i, stop)
onErr :: IORef (Status a) -> SomeException -> IO ()
onErr istatus ex = case fromException ex of
Just Replaced -> return ()
Nothing -> do
tid <- myThreadId
atomicModifyIORef' istatus $ clear tid
throwIO ex
where
clear tid (AutoUpdated _ _ tid') | tid == tid' = (ManualUpdates 0, ())
clear _ status = (status, ())
stop :: IO a
stop = throwIO Replaced