@@ -20,8 +20,8 @@ module Control.AutoUpdate
2020 ) where
2121
2222import Control.Concurrent (ThreadId, forkIO, myThreadId, threadDelay)
23−import Control.Exception (Exception, assert, fromException, handle,
24− throwIO, throwTo)
23+import Control.Exception (Exception, SomeException
24+ ,assert, fromException, handle,throwIO, throwTo)
2525import Control.Monad (forever, join)
2626import Data.IORef (IORef, atomicModifyIORef, newIORef)
2727import Data.Typeable (Typeable)
@@ -125,32 +125,36 @@ getCurrent freq spawnThreshold action istatus = do
125125 Manual -> action
126126 Spawn -> do
127127 a <- action
128− tid <- forkIO spawn
128+ tid <- forkIO $ spawn freq action istatus
129129 join $ atomicModifyIORef istatus $ \status ->
130130 case status of
131131 AutoUpdated _ cnt old -> (AutoUpdated a cnt tid, throwTo old Replaced)
132132 ManualUpdates cnt -> (AutoUpdated a cnt tid, return ())
133133 return a
134+
135+spawn :: Int -> IO a -> IORef (Status a) -> IO ()
136+spawn freq action istatus = handle (onErr istatus) $ forever $ do
137+ threadDelay freq
138+ a <- action
139+ join $ atomicModifyIORef istatus $ turnToManual a
140+ where
141+ -- Normal case.
142+ turnToManual a (AutoUpdated _ cnt tid)
143+ | cnt >= 1 = (AutoUpdated a 0 tid, return ())
144+ | otherwise = (ManualUpdates 0, stop)
145+ -- This case must not happen.
146+ turnToManual _ (ManualUpdates i) = assert False (ManualUpdates i, stop)
147+
148+onErr :: IORef (Status a) -> SomeException -> IO ()
149+onErr istatus ex = case fromException ex of
150+ Just Replaced -> return ()
151+ Nothing -> do
152+ tid <- myThreadId
153+ atomicModifyIORef istatus $ clear tid
154+ throwIO ex
134155 where
135− spawn = handle onErr $ forever $ do
136− threadDelay freq
137− a <- action
138− join $ atomicModifyIORef istatus $ \status ->
139− case status of
140− AutoUpdated _ cnt tid
141− | cnt >= 1 -> (AutoUpdated a 0 tid, return ())
142− | otherwise -> (ManualUpdates 0, stop)
143− ManualUpdates i -> assert False (ManualUpdates i, stop)
144− onErr ex =
145− case fromException ex of
146− Just Replaced -> return ()
147− Nothing -> do
148− tid <- myThreadId
149− atomicModifyIORef istatus $ \status ->
150− case status of
151− AutoUpdated _ _ tid' | tid == tid' -> (ManualUpdates 0, ())
152− _ -> (status, ())
153− throwIO ex
156+ clear tid (AutoUpdated _ _ tid') | tid == tid' = (ManualUpdates 0, ())
157+ clear _ status = (status, ())
154158
155159stop :: IO a
156160stop = throwIO Replaced