{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
module Control.Reaper (
ReaperSettings
, defaultReaperSettings
, reaperAction
, reaperDelay
, reaperCons
, reaperNull
, reaperEmpty
, Reaper(..)
, mkReaper
, mkListAction
) where
import Control.AutoUpdate.Util (atomicModifyIORef')
import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
import Control.Exception (mask_)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
data ReaperSettings workload item = ReaperSettings
{ forall workload item.
ReaperSettings workload item
-> workload -> IO (workload -> workload)
reaperAction :: workload -> IO (workload -> workload)
, forall workload item. ReaperSettings workload item -> Int
reaperDelay :: {-# UNPACK #-} !Int
, forall workload item.
ReaperSettings workload item -> item -> workload -> workload
reaperCons :: item -> workload -> workload
, forall workload item.
ReaperSettings workload item -> workload -> Bool
reaperNull :: workload -> Bool
, forall workload item. ReaperSettings workload item -> workload
reaperEmpty :: workload
}
defaultReaperSettings :: ReaperSettings [item] item
defaultReaperSettings :: forall item. ReaperSettings [item] item
defaultReaperSettings = ReaperSettings
{ reaperAction :: [item] -> IO ([item] -> [item])
reaperAction = \[item]
wl -> forall (m :: * -> *) a. Monad m => a -> m a
return ([item]
wl forall a. [a] -> [a] -> [a]
++)
, reaperDelay :: Int
reaperDelay = Int
30000000
, reaperCons :: item -> [item] -> [item]
reaperCons = (:)
, reaperNull :: [item] -> Bool
reaperNull = forall (t :: * -> *) a. Foldable t => t a -> Bool
null
, reaperEmpty :: [item]
reaperEmpty = []
}
data Reaper workload item = Reaper {
forall workload item. Reaper workload item -> item -> IO ()
reaperAdd :: item -> IO ()
, forall workload item. Reaper workload item -> IO workload
reaperRead :: IO workload
, forall workload item. Reaper workload item -> IO workload
reaperStop :: IO workload
, forall workload item. Reaper workload item -> IO ()
reaperKill :: IO ()
}
data State workload = NoReaper
| Workload !workload
mkReaper :: ReaperSettings workload item -> IO (Reaper workload item)
mkReaper :: forall workload item.
ReaperSettings workload item -> IO (Reaper workload item)
mkReaper settings :: ReaperSettings workload item
settings@ReaperSettings{workload
Int
workload -> Bool
workload -> IO (workload -> workload)
item -> workload -> workload
reaperEmpty :: workload
reaperNull :: workload -> Bool
reaperCons :: item -> workload -> workload
reaperDelay :: Int
reaperAction :: workload -> IO (workload -> workload)
reaperEmpty :: forall workload item. ReaperSettings workload item -> workload
reaperNull :: forall workload item.
ReaperSettings workload item -> workload -> Bool
reaperCons :: forall workload item.
ReaperSettings workload item -> item -> workload -> workload
reaperDelay :: forall workload item. ReaperSettings workload item -> Int
reaperAction :: forall workload item.
ReaperSettings workload item
-> workload -> IO (workload -> workload)
..} = do
IORef (State workload)
stateRef <- forall a. a -> IO (IORef a)
newIORef forall workload. State workload
NoReaper
IORef (Maybe ThreadId)
tidRef <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return Reaper {
reaperAdd :: item -> IO ()
reaperAdd = forall workload item.
ReaperSettings workload item
-> IORef (State workload)
-> IORef (Maybe ThreadId)
-> item
-> IO ()
add ReaperSettings workload item
settings IORef (State workload)
stateRef IORef (Maybe ThreadId)
tidRef
, reaperRead :: IO workload
reaperRead = IORef (State workload) -> IO workload
readRef IORef (State workload)
stateRef
, reaperStop :: IO workload
reaperStop = IORef (State workload) -> IO workload
stop IORef (State workload)
stateRef
, reaperKill :: IO ()
reaperKill = IORef (Maybe ThreadId) -> IO ()
kill IORef (Maybe ThreadId)
tidRef
}
where
readRef :: IORef (State workload) -> IO workload
readRef IORef (State workload)
stateRef = do
State workload
mx <- forall a. IORef a -> IO a
readIORef IORef (State workload)
stateRef
case State workload
mx of
State workload
NoReaper -> forall (m :: * -> *) a. Monad m => a -> m a
return workload
reaperEmpty
Workload workload
wl -> forall (m :: * -> *) a. Monad m => a -> m a
return workload
wl
stop :: IORef (State workload) -> IO workload
stop IORef (State workload)
stateRef = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (State workload)
stateRef forall a b. (a -> b) -> a -> b
$ \State workload
mx ->
case State workload
mx of
State workload
NoReaper -> (forall workload. State workload
NoReaper, workload
reaperEmpty)
Workload workload
x -> (forall workload. workload -> State workload
Workload workload
reaperEmpty, workload
x)
kill :: IORef (Maybe ThreadId) -> IO ()
kill IORef (Maybe ThreadId)
tidRef = do
Maybe ThreadId
mtid <- forall a. IORef a -> IO a
readIORef IORef (Maybe ThreadId)
tidRef
case Maybe ThreadId
mtid of
Maybe ThreadId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ThreadId
tid -> ThreadId -> IO ()
killThread ThreadId
tid
add :: ReaperSettings workload item
-> IORef (State workload) -> IORef (Maybe ThreadId)
-> item -> IO ()
add :: forall workload item.
ReaperSettings workload item
-> IORef (State workload)
-> IORef (Maybe ThreadId)
-> item
-> IO ()
add settings :: ReaperSettings workload item
settings@ReaperSettings{workload
Int
workload -> Bool
workload -> IO (workload -> workload)
item -> workload -> workload
reaperEmpty :: workload
reaperNull :: workload -> Bool
reaperCons :: item -> workload -> workload
reaperDelay :: Int
reaperAction :: workload -> IO (workload -> workload)
reaperEmpty :: forall workload item. ReaperSettings workload item -> workload
reaperNull :: forall workload item.
ReaperSettings workload item -> workload -> Bool
reaperCons :: forall workload item.
ReaperSettings workload item -> item -> workload -> workload
reaperDelay :: forall workload item. ReaperSettings workload item -> Int
reaperAction :: forall workload item.
ReaperSettings workload item
-> workload -> IO (workload -> workload)
..} IORef (State workload)
stateRef IORef (Maybe ThreadId)
tidRef item
item =
forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
IO ()
next <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (State workload)
stateRef State workload -> (State workload, IO ())
cons
IO ()
next
where
cons :: State workload -> (State workload, IO ())
cons State workload
NoReaper = let wl :: workload
wl = item -> workload -> workload
reaperCons item
item workload
reaperEmpty
in (forall workload. workload -> State workload
Workload workload
wl, forall workload item.
ReaperSettings workload item
-> IORef (State workload) -> IORef (Maybe ThreadId) -> IO ()
spawn ReaperSettings workload item
settings IORef (State workload)
stateRef IORef (Maybe ThreadId)
tidRef)
cons (Workload workload
wl) = let wl' :: workload
wl' = item -> workload -> workload
reaperCons item
item workload
wl
in (forall workload. workload -> State workload
Workload workload
wl', forall (m :: * -> *) a. Monad m => a -> m a
return ())
spawn :: ReaperSettings workload item
-> IORef (State workload) -> IORef (Maybe ThreadId)
-> IO ()
spawn :: forall workload item.
ReaperSettings workload item
-> IORef (State workload) -> IORef (Maybe ThreadId) -> IO ()
spawn ReaperSettings workload item
settings IORef (State workload)
stateRef IORef (Maybe ThreadId)
tidRef = do
ThreadId
tid <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall workload item.
ReaperSettings workload item
-> IORef (State workload) -> IORef (Maybe ThreadId) -> IO ()
reaper ReaperSettings workload item
settings IORef (State workload)
stateRef IORef (Maybe ThreadId)
tidRef
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe ThreadId)
tidRef forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ThreadId
tid
reaper :: ReaperSettings workload item
-> IORef (State workload) -> IORef (Maybe ThreadId)
-> IO ()
reaper :: forall workload item.
ReaperSettings workload item
-> IORef (State workload) -> IORef (Maybe ThreadId) -> IO ()
reaper settings :: ReaperSettings workload item
settings@ReaperSettings{workload
Int
workload -> Bool
workload -> IO (workload -> workload)
item -> workload -> workload
reaperEmpty :: workload
reaperNull :: workload -> Bool
reaperCons :: item -> workload -> workload
reaperDelay :: Int
reaperAction :: workload -> IO (workload -> workload)
reaperEmpty :: forall workload item. ReaperSettings workload item -> workload
reaperNull :: forall workload item.
ReaperSettings workload item -> workload -> Bool
reaperCons :: forall workload item.
ReaperSettings workload item -> item -> workload -> workload
reaperDelay :: forall workload item. ReaperSettings workload item -> Int
reaperAction :: forall workload item.
ReaperSettings workload item
-> workload -> IO (workload -> workload)
..} IORef (State workload)
stateRef IORef (Maybe ThreadId)
tidRef = do
Int -> IO ()
threadDelay Int
reaperDelay
workload
wl <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (State workload)
stateRef forall {b}. State b -> (State workload, b)
swapWithEmpty
!workload -> workload
merge <- workload -> IO (workload -> workload)
reaperAction workload
wl
IO ()
next <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (State workload)
stateRef (forall {workload}.
(workload -> workload) -> State workload -> (State workload, IO ())
check workload -> workload
merge)
IO ()
next
where
swapWithEmpty :: State b -> (State workload, b)
swapWithEmpty State b
NoReaper = forall a. HasCallStack => [Char] -> a
error [Char]
"Control.Reaper.reaper: unexpected NoReaper (1)"
swapWithEmpty (Workload b
wl) = (forall workload. workload -> State workload
Workload workload
reaperEmpty, b
wl)
check :: (workload -> workload) -> State workload -> (State workload, IO ())
check workload -> workload
_ State workload
NoReaper = forall a. HasCallStack => [Char] -> a
error [Char]
"Control.Reaper.reaper: unexpected NoReaper (2)"
check workload -> workload
merge (Workload workload
wl)
| workload -> Bool
reaperNull workload
wl' = (forall workload. State workload
NoReaper, forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe ThreadId)
tidRef forall a. Maybe a
Nothing)
| Bool
otherwise = (forall workload. workload -> State workload
Workload workload
wl', forall workload item.
ReaperSettings workload item
-> IORef (State workload) -> IORef (Maybe ThreadId) -> IO ()
reaper ReaperSettings workload item
settings IORef (State workload)
stateRef IORef (Maybe ThreadId)
tidRef)
where
wl' :: workload
wl' = workload -> workload
merge workload
wl
mkListAction :: (item -> IO (Maybe item'))
-> [item]
-> IO ([item'] -> [item'])
mkListAction :: forall item item'.
(item -> IO (Maybe item')) -> [item] -> IO ([item'] -> [item'])
mkListAction item -> IO (Maybe item')
f =
forall {c}. ([item'] -> c) -> [item] -> IO ([item'] -> c)
go forall a. a -> a
id
where
go :: ([item'] -> c) -> [item] -> IO ([item'] -> c)
go ![item'] -> c
front [] = forall (m :: * -> *) a. Monad m => a -> m a
return [item'] -> c
front
go ![item'] -> c
front (item
x:[item]
xs) = do
Maybe item'
my <- item -> IO (Maybe item')
f item
x
let front' :: [item'] -> c
front' =
case Maybe item'
my of
Maybe item'
Nothing -> [item'] -> c
front
Just item'
y -> [item'] -> c
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (item'
yforall a. a -> [a] -> [a]
:)
([item'] -> c) -> [item] -> IO ([item'] -> c)
go [item'] -> c
front' [item]
xs