@@ -0,0 +1,107 @@
1+{-# LANGUAGE DeriveDataTypeable, RankNTypes #-}
2+-- FIXME: should we replace Data with System?
3+module Data.AutoUpdate where
4+
5+import Control.Applicative ((<$>))
6+import Data.IORef
7+import Control.Concurrent (threadDelay, forkIOWithUnmask)
8+import Control.Monad (forever, void)
9+import Control.Exception (Exception, SomeException(..), handle, catches, throwIO, assert, Handler(..), mask)
10+import Data.Typeable (Typeable)
11+
12+----------------------------------------------------------------
13+
14+data UpdateSettings a = UpdateSettings
15+ { updateFreq :: !Int
16+ , updateSpawnThreshold :: !Int
17+ , updateAction :: !(IO a)
18+ }
19+
20+data Status a = AutoUpdated !a !Int -- ^ # of manual update during updateFreq
21+ | SemiAuto
22+ | ManualUpdates !Int -- ^ # of manual update
23+
24+data AutoUpdate a = AutoUpdate
25+ { auSettings :: !(UpdateSettings a)
26+ , auStatus :: !(IORef (Status a))
27+ }
28+
29+data Action a = Return a | Manual | Spawn
30+
31+data Replaced = Replaced deriving (Show, Typeable)
32+instance Exception Replaced
33+
34+----------------------------------------------------------------
35+
36+mkAutoUpdate :: UpdateSettings a -> IO (AutoUpdate a)
37+mkAutoUpdate settings = AutoUpdate settings <$> newIORef (ManualUpdates 0)
38+
39+getCurrent :: AutoUpdate a -> IO a
40+getCurrent au@(AutoUpdate (UpdateSettings _ spawnThreshold action) istatus) =
41+ handle handler update
42+ where
43+ update = mask $ \restore -> do
44+ ea <- atomicModifyIORef' istatus increment
45+ case ea of
46+ Return a -> return a
47+ Manual -> restore action
48+ Spawn -> do
49+ a <- restore action
50+ void $ forkIOWithUnmask $ spawn au a
51+ -- Without mask, an asynchronous exeption here may lead
52+ -- to spawn multiple threads.
53+ return a
54+
55+ increment (AutoUpdated a cnt) = (AutoUpdated a (succ cnt), Return a)
56+ increment SemiAuto = (SemiAuto, Manual)
57+ increment (ManualUpdates i)
58+ | i > spawnThreshold = (SemiAuto, Spawn)
59+ | otherwise = (ManualUpdates (succ i), Manual)
60+
61+ handler (SomeException ex) = do
62+ atomicModifyIORef' istatus reset
63+ throwIO ex
64+
65+ -- Resetting to the safe status
66+ reset SemiAuto = (ManualUpdates 0, ())
67+ -- If status is AutoUpdated, an thread is running.
68+ -- So, let's keep the status.
69+ reset status = (status, ())
70+
71+----------------------------------------------------------------
72+
73+spawn :: AutoUpdate a -> a -> (forall b. IO b -> IO b) -> IO ()
74+spawn (AutoUpdate (UpdateSettings freq _ action) istatus) x restore =
75+ update `catches` handlers
76+ where
77+ update = do
78+ void $ atomicModifyIORef' istatus (turnToAuto x)
79+ restore loop
80+
81+ turnToAuto a _ = (AutoUpdated a 0, ())
82+
83+ loop = forever $ do
84+ threadDelay freq
85+ a <- action
86+ doit <- atomicModifyIORef' istatus $ trunToManual a
87+ doit
88+
89+ -- Normal case.
90+ trunToManual a (AutoUpdated _ cnt)
91+ | cnt >= 1 = (AutoUpdated a 0, return ())
92+ | otherwise = (ManualUpdates 0, stop)
93+ -- This case must not happen.
94+ trunToManual _ _ = assert False (ManualUpdates 0, stop)
95+
96+ stop :: IO a
97+ stop = throwIO Replaced
98+
99+ handlers :: [Handler ()]
100+ handlers = [Handler rhandler, Handler ohandler]
101+
102+ rhandler Replaced = return ()
103+ ohandler (SomeException ex) = do
104+ -- This thread is killed.
105+ -- Resetting to the safe status.
106+ atomicModifyIORef' istatus $ \_ -> (ManualUpdates 0, ())
107+ throwIO ex