@@ -23,10 +23,9 @@ module Control.Reaper (
2323 ) where
2424
2525import Control.AutoUpdate.Util (atomicModifyIORef')
26−import Control.Concurrent (forkIO, threadDelay)
26+import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
2727import Control.Exception (mask_)
28−import Control.Monad (void)
29−import Data.IORef (IORef, newIORef, readIORef)
28+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
3029
3130-- | Settings for creating a reaper. This type has two parameters:
3231-- @workload@ gives the entire workload, whereas @item@ gives an
@@ -97,6 +96,8 @@ data Reaper workload item = Reaper {
9796 -- | Stopping the reaper thread if exists.
9897 -- The current workload is returned.
9998 , reaperStop :: IO workload
99+ -- | Killing the reaper thread immediately if exists.
100+ , reaperKill :: IO ()
100101 }
101102
102103-- | State of reaper.
@@ -111,10 +112,12 @@ data State workload = NoReaper -- ^ No reaper thread
111112mkReaper :: ReaperSettings workload item -> IO (Reaper workload item)
112113mkReaper settings@ReaperSettings{..} = do
113114 stateRef <- newIORef NoReaper
115+ tidRef <- newIORef Nothing
114116 return Reaper {
115− reaperAdd = add settings stateRef
117+ reaperAdd = add settings stateRef tidRef
116118 , reaperRead = readRef stateRef
117119 , reaperStop = stop stateRef
120+ , reaperKill = kill tidRef
118121 }
119122 where
120123 readRef stateRef = do
@@ -126,24 +129,36 @@ mkReaper settings@ReaperSettings{..} = do
126129 case mx of
127130 NoReaper -> (NoReaper, reaperEmpty)
128131 Workload x -> (Workload reaperEmpty, x)
132+ kill tidRef = do
133+ mtid <- readIORef tidRef
134+ case mtid of
135+ Nothing -> return ()
136+ Just tid -> killThread tid
129137
130−add :: ReaperSettings workload item -> IORef (State workload) -> item
131− -> IO ()
132−add settings@ReaperSettings{..} stateRef item =
138+add :: ReaperSettings workload item
139+ -> IORef (State workload) -> IORef (Maybe ThreadId)
140+ -> item -> IO ()
141+add settings@ReaperSettings{..} stateRef tidRef item =
133142 mask_ $ do
134143 next <- atomicModifyIORef' stateRef cons
135144 next
136145 where
137146 cons NoReaper = let !wl = reaperCons item reaperEmpty
138− in (Workload wl, spawn settings stateRef)
147+ in (Workload wl, spawn settings stateRef tidRef)
139148 cons (Workload wl) = let wl' = reaperCons item wl
140149 in (Workload wl', return ())
141150
142−spawn :: ReaperSettings workload item -> IORef (State workload) -> IO ()
143−spawn settings stateRef = void . forkIO $ reaper settings stateRef
151+spawn :: ReaperSettings workload item
152+ -> IORef (State workload) -> IORef (Maybe ThreadId)
153+ -> IO ()
154+spawn settings stateRef tidRef = do
155+ tid <- forkIO $ reaper settings stateRef tidRef
156+ writeIORef tidRef $ Just tid
144157
145−reaper :: ReaperSettings workload item -> IORef (State workload) -> IO ()
146−reaper settings@ReaperSettings{..} stateRef = do
158+reaper :: ReaperSettings workload item
159+ -> IORef (State workload) -> IORef (Maybe ThreadId)
160+ -> IO ()
161+reaper settings@ReaperSettings{..} stateRef tidRef = do
147162 threadDelay reaperDelay
148163 -- Getting the current jobs. Push an empty job to the reference.
149164 wl <- atomicModifyIORef' stateRef swapWithEmpty
@@ -161,9 +176,9 @@ reaper settings@ReaperSettings{..} stateRef = do
161176 check _ NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (2)"
162177 check merge (Workload wl)
163178 -- If there is no job, reaper is terminated.
164− | reaperNull wl' = (NoReaper, return ())
179+ | reaperNull wl' = (NoReaper, writeIORef tidRef Nothing)
165180 -- If there are jobs, carry them out.
166− | otherwise = (Workload wl', reaper settings stateRef)
181+ | otherwise = (Workload wl', reaper settings stateRef tidRef)
167182 where
168183 wl' = merge wl
169184