@@ -1,5 +1,7 @@
11{-# LANGUAGE BangPatterns #-}
22{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE CPP #-}
4+
35-- | A common problem is the desire to have an action run at a scheduled
46-- interval, but only if it is needed. For example, instead of having
57-- every web request result in a new @getCurrentTime@ call, we'd like to
@@ -23,9 +25,28 @@ import Control.Concurrent (ThreadId, forkIO, myThreadId, threadDelay)
2325import Control.Exception (Exception, SomeException
2426 ,assert, fromException, handle,throwIO, throwTo)
2527import Control.Monad (forever, join)
26−import Data.IORef (IORef, atomicModifyIORef, newIORef)
28+import Data.IORef (IORef, newIORef)
2729import Data.Typeable (Typeable)
2830
31+#ifndef MIN_VERSION_base
32+#define MIN_VERSION_base(x,y,z) 1
33+#endif
34+
35+#if MIN_VERSION_base(4,6,0)
36+import Data.IORef (atomicModifyIORef')
37+#else
38+import Data.IORef (atomicModifyIORef)
39+-- | Strict version of 'atomicModifyIORef'. This forces both the value stored
40+-- in the 'IORef' as well as the value returned.
41+atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b
42+atomicModifyIORef' ref f = do
43+ c <- atomicModifyIORef ref
44+ (\x -> let (a, b) = f x -- Lazy application of "f"
45+ in (a, a `seq` b)) -- Lazy application of "seq"
46+ -- The following forces "a `seq` b", so it also forces "f x".
47+ c `seq` return c
48+#endif
49+
2950-- | Default value for creating an @UpdateSettings@.
3051--
3152-- Since 0.1.0
@@ -116,14 +137,14 @@ getCurrent :: Int -- ^ frequency
116137 -> IORef (Status a) -- ^ mutable state
117138 -> IO a
118139getCurrent freq spawnThreshold action istatus = do
119− ea <- atomicModifyIORef istatus increment
140+ ea <- atomicModifyIORef' istatus increment
120141 case ea of
121142 Return a -> return a
122143 Manual -> action
123144 Spawn -> do
124145 a <- action
125146 tid <- forkIO $ spawn freq action istatus
126− join $ atomicModifyIORef istatus $ turnToAuto a tid
147+ join $ atomicModifyIORef' istatus $ turnToAuto a tid
127148 return a
128149 where
129150 increment (AutoUpdated a cnt tid) = (AutoUpdated a (succ cnt) tid, Return a)
@@ -143,7 +164,7 @@ spawn :: Int -> IO a -> IORef (Status a) -> IO ()
143164spawn freq action istatus = handle (onErr istatus) $ forever $ do
144165 threadDelay freq
145166 a <- action
146− join $ atomicModifyIORef istatus $ turnToManual a
167+ join $ atomicModifyIORef' istatus $ turnToManual a
147168 where
148169 -- Normal case.
149170 turnToManual a (AutoUpdated _ cnt tid)
@@ -157,7 +178,7 @@ onErr istatus ex = case fromException ex of
157178 Just Replaced -> return ()
158179 Nothing -> do
159180 tid <- myThreadId
160− atomicModifyIORef istatus $ clear tid
181+ atomicModifyIORef' istatus $ clear tid
161182 throwIO ex
162183 where
163184 -- In the race condition described above,