module Control.AutoUpdate (
UpdateSettings
, defaultUpdateSettings
, updateFreq
, updateSpawnThreshold
, updateAction
, mkAutoUpdate
) where
import Control.AutoUpdate.Util (atomicModifyIORef')
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)
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 us = do
istatus <- newIORef $ ManualUpdates 0
return $! getCurrent us istatus
data Action a = Return a | Manual | Spawn
data Replaced = Replaced deriving (Show, Typeable)
instance Exception Replaced
getCurrent :: UpdateSettings a
-> IORef (Status a)
-> IO a
getCurrent settings@UpdateSettings{..} istatus = do
ea <- atomicModifyIORef' istatus increment
case ea of
Return a -> return a
Manual -> updateAction
Spawn -> do
a <- updateAction
tid <- forkIO $ spawn settings 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 > updateSpawnThreshold 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 :: UpdateSettings a -> IORef (Status a) -> IO ()
spawn UpdateSettings{..} istatus = handle (onErr istatus) $ forever $ do
threadDelay updateFreq
a <- updateAction
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