@@ -1,3 +1,5 @@
1+{-# LANGUAGE RecordWildCards #-}
2+
13-- | This module provides the ability to create reapers: dedicated cleanup
24-- threads. These threads will automatically spawn and die based on the
35-- presence of a workload to process on.
@@ -17,14 +19,12 @@ module Control.Reaper (
1719 , mkListAction
1820 ) where
1921
20−import Prelude hiding (null)
2122import Control.Monad (join, void)
2223import Data.Function (fix)
2324import Control.AutoUpdate.Util (atomicModifyIORef')
2425import Control.Concurrent (forkIO, threadDelay)
2526import Data.IORef (IORef, newIORef)
2627import Control.Exception (mask_)
27−import qualified Prelude
2828
2929-- | Settings for creating a reaper. This type has two parameters:
3030-- @workload@ gives the entire workload, whereas @item@ gives an
@@ -62,7 +62,7 @@ data ReaperSettings workload item = ReaperSettings
6262 -- ^ Check if a workload is empty, in which case the worker thread
6363 -- will shut down.
6464 --
65− -- Default: 'Prelude.null'.
65+ -- Default: 'null'.
6666 --
6767 -- Since 0.1.1
6868 , reaperEmpty :: workload
@@ -82,7 +82,7 @@ defaultReaperSettings = ReaperSettings
8282 { reaperAction = \wl -> return (wl ++)
8383 , reaperDelay = 30000000
8484 , reaperCons = (:)
85− , reaperNull = Prelude.null
85+ , reaperNull = null
8686 , reaperEmpty = []
8787 }
8888
@@ -93,30 +93,37 @@ defaultReaperSettings = ReaperSettings
9393-- Since 0.1.1
9494reaper :: ReaperSettings workload item
9595 -> IO (item -> IO (), IORef (Maybe workload))
96−reaper (ReaperSettings action delay cons null empty) = do
96+reaper settings = do
9797 stateRef <- newIORef Nothing
98− return (update stateRef, stateRef)
98+ return (update settings stateRef, stateRef)
99+
100+update :: ReaperSettings workload item -> IORef (Maybe workload) -> item
101+ -> IO ()
102+update settings@ReaperSettings{..} stateRef item =
103+ mask_ $ join $ atomicModifyIORef' stateRef cons
104+ where
105+ cons Nothing = (Just $ reaperCons item reaperEmpty, spawn settings stateRef)
106+ cons (Just wl) = (Just $ reaperCons item wl, return ())
107+
108+spawn :: ReaperSettings workload item -> IORef (Maybe workload) -> IO ()
109+spawn settings stateRef = void . forkIO $ loop settings stateRef
110+
111+loop :: ReaperSettings workload item -> IORef (Maybe workload) -> IO ()
112+loop settings@ReaperSettings{..} stateRef = do
113+ threadDelay reaperDelay
114+ wl1 <- atomicModifyIORef' stateRef get
115+ wl2 <- reaperAction wl1
116+ join $ atomicModifyIORef' stateRef (check wl2)
99117 where
100− update stateRef item = mask_ $ join $ atomicModifyIORef' stateRef $ \ms ->
101− case ms of
102− Nothing -> (Just $ cons item empty, spawn stateRef)
103− Just wl -> (Just $ cons item wl, return ())
118+ get Nothing = error "Control.Reaper.loop: unexpected Nothing (1)"
119+ get (Just wl) = (Just reaperEmpty, wl)
104120
105− spawn stateRef = void $ forkIO $ fix $ \loop -> do
106− threadDelay delay
107− wl1 <- atomicModifyIORef' stateRef $ \ms ->
108− case ms of
109− Nothing -> error "Control.Reaper.reaper.spawn: unexpected Nothing (1)"
110− Just wl -> (Just empty, wl)
111− wl2 <- action wl1
112− join $ atomicModifyIORef' stateRef $ \ms ->
113− case ms of
114− Nothing -> error "Control.Reaper.reaper.spawn: unexpected Nothing (2)"
115− Just wl3 ->
116− let wl4 = wl2 wl3
117− in if null wl4
118− then (Nothing, return ())
119− else (Just wl4, loop)
121+ check _ Nothing = error "Control.Reaper.loop: unexpected Nothing (2)"
122+ check wl2 (Just wl3)
123+ | reaperNull wl4 = (Nothing, return ())
124+ | otherwise = (Just wl4, loop settings stateRef)
125+ where
126+ wl4 = wl2 wl3
120127
121128-- | A helper function for creating 'reaperAction' functions. You would
122129-- provide this function with a function to process a single work item and
@@ -128,13 +135,13 @@ mkListAction :: (item -> IO (Maybe item'))
128135 -> [item]
129136 -> IO ([item'] -> [item'])
130137mkListAction f =
131− loop id
138+ go id
132139 where
133− loop front [] = return front
134− loop front (x:xs) = do
140+ go front [] = return front
141+ go front (x:xs) = do
135142 my <- f x
136143 let front' =
137144 case my of
138145 Nothing -> front
139− Just y -> front . (y:)
140− loop front' xs
146+ Just y -> front . (y:)
147+ go front' xs