4b95305 · typeable/wai

20 ) where

21

22import Control.Concurrent (ThreadId, forkIO, myThreadId, threadDelay)

23−import Control.Exception (Exception, assert, fromException, handle,

23+import Control.Exception (Exception, SomeException

24− throwIO, throwTo)

24+ ,assert, fromException, handle,throwIO, throwTo)

25import Control.Monad (forever, join)

26import Data.IORef (IORef, atomicModifyIORef, newIORef)

27import Data.Typeable (Typeable)

125 Manual -> action

126 Spawn -> do

127 a <- action

128− tid <- forkIO spawn

128+ tid <- forkIO $ spawn freq action istatus

129 join $ atomicModifyIORef istatus $ \status ->

130 case status of

131 AutoUpdated _ cnt old -> (AutoUpdated a cnt tid, throwTo old Replaced)

132 ManualUpdates cnt -> (AutoUpdated a cnt tid, return ())

133 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

134 where

155 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, ())

156+ clear tid (AutoUpdated _ _ tid') | tid == tid' = (ManualUpdates 0, ())

152− _ -> (status, ())

157+ clear _ status = (status, ())

153− throwIO ex

154

158

155stop :: IO a

159stop :: IO a

156stop = throwIO Replaced

160stop = throwIO Replaced