{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards, ViewPatterns #-}
module Development.Shake.Internal.Resource(
Resource, newResourceIO, newThrottleIO, withResource
) where
import Data.Function
import System.IO.Unsafe
import Control.Concurrent.Extra
import General.Fence
import Control.Exception.Extra
import Data.Tuple.Extra
import Data.IORef
import Control.Monad.Extra
import General.Bilist
import General.Pool
import Development.Shake.Internal.Core.Action
import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Core.Monad
import Development.Shake.Internal.Core.Pool
import Control.Monad.IO.Class
import System.Time.Extra
{-# NOINLINE resourceId #-}
resourceId :: IO Int
resourceId :: IO Int
resourceId = IO (IO Int) -> IO Int
forall a. IO a -> a
unsafePerformIO (IO (IO Int) -> IO Int) -> IO (IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ do
IORef Int
ref <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 0
IO Int -> IO (IO Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO Int -> IO (IO Int)) -> IO Int -> IO (IO Int)
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
ref ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \i :: Int
i -> let j :: Int
j = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 in (Int
j, Int
j)
withResource :: Resource -> Int -> Action a -> Action a
withResource :: Resource -> Int -> Action a -> Action a
withResource r :: Resource
r i :: Int
i act :: Action a
act = do
Global{..} <- RAW ([String], [Key]) [Value] Global Local Global -> Action Global
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action RAW ([String], [Key]) [Value] Global Local Global
forall k v ro rw. RAW k v ro rw ro
getRO
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO String -> IO ()
globalDiagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Resource -> String
forall a. Show a => a -> String
show Resource
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ " waiting to acquire " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
Maybe (Fence IO ())
fence <- IO (Maybe (Fence IO ())) -> Action (Maybe (Fence IO ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Fence IO ())) -> Action (Maybe (Fence IO ())))
-> IO (Maybe (Fence IO ())) -> Action (Maybe (Fence IO ()))
forall a b. (a -> b) -> a -> b
$ Resource -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquireResource Resource
r Pool
globalPool Int
i
Maybe (Fence IO ()) -> (Fence IO () -> Action ()) -> Action ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (Fence IO ())
fence ((Fence IO () -> Action ()) -> Action ())
-> (Fence IO () -> Action ()) -> Action ()
forall a b. (a -> b) -> a -> b
$ \fence :: Fence IO ()
fence -> do
(offset :: Seconds
offset, ()) <- (() -> Either SomeException ())
-> Fence IO () -> Action (Seconds, ())
forall a b.
(a -> Either SomeException b) -> Fence IO a -> Action (Seconds, b)
actionFenceRequeueBy () -> Either SomeException ()
forall a b. b -> Either a b
Right Fence IO ()
fence
RAW ([String], [Key]) [Value] Global Local () -> Action ()
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local () -> Action ())
-> RAW ([String], [Key]) [Value] Global Local () -> Action ()
forall a b. (a -> b) -> a -> b
$ (Local -> Local) -> RAW ([String], [Key]) [Value] Global Local ()
forall rw k v ro. (rw -> rw) -> RAW k v ro rw ()
modifyRW ((Local -> Local) -> RAW ([String], [Key]) [Value] Global Local ())
-> (Local -> Local)
-> RAW ([String], [Key]) [Value] Global Local ()
forall a b. (a -> b) -> a -> b
$ Seconds -> Local -> Local
addDiscount Seconds
offset
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO String -> IO ()
globalDiagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Resource -> String
forall a. Show a => a -> String
show Resource
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ " running with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
RAW ([String], [Key]) [Value] Global Local a -> Action a
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action (RAW ([String], [Key]) [Value] Global Local a -> Action a)
-> RAW ([String], [Key]) [Value] Global Local a -> Action a
forall a b. (a -> b) -> a -> b
$ Action a -> RAW ([String], [Key]) [Value] Global Local a
forall a. Action a -> RAW ([String], [Key]) [Value] Global Local a
fromAction (String -> Action a -> Action a
forall a. String -> Action a -> Action a
blockApply ("Within withResource using " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Resource -> String
forall a. Show a => a -> String
show Resource
r) Action a
act) RAW ([String], [Key]) [Value] Global Local a
-> RAW ([String], [Key]) [Value] Global Local ()
-> RAW ([String], [Key]) [Value] Global Local a
forall k v ro rw a b.
RAW k v ro rw a -> RAW k v ro rw b -> RAW k v ro rw a
`finallyRAW` do
IO () -> RAW ([String], [Key]) [Value] Global Local ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RAW ([String], [Key]) [Value] Global Local ())
-> IO () -> RAW ([String], [Key]) [Value] Global Local ()
forall a b. (a -> b) -> a -> b
$ Resource -> Pool -> Int -> IO ()
releaseResource Resource
r Pool
globalPool Int
i
IO () -> RAW ([String], [Key]) [Value] Global Local ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RAW ([String], [Key]) [Value] Global Local ())
-> IO () -> RAW ([String], [Key]) [Value] Global Local ()
forall a b. (a -> b) -> a -> b
$ IO String -> IO ()
globalDiagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Resource -> String
forall a. Show a => a -> String
show Resource
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ " released " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
data Resource = Resource
{Resource -> Int
resourceOrd :: Int
,Resource -> String
resourceShow :: String
,Resource -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquireResource :: Pool -> Int -> IO (Maybe (Fence IO ()))
,Resource -> Pool -> Int -> IO ()
releaseResource :: Pool -> Int -> IO ()
}
instance Show Resource where show :: Resource -> String
show = Resource -> String
resourceShow
instance Eq Resource where == :: Resource -> Resource -> Bool
(==) = Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool)
-> (Resource -> Int) -> Resource -> Resource -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Resource -> Int
resourceOrd
instance Ord Resource where compare :: Resource -> Resource -> Ordering
compare = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> (Resource -> Int) -> Resource -> Resource -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Resource -> Int
resourceOrd
data Finite = Finite
{Finite -> Int
finiteAvailable :: !Int
,Finite -> Bilist (Int, Fence IO ())
finiteWaiting :: Bilist (Int, Fence IO ())
}
newResourceIO :: String -> Int -> IO Resource
newResourceIO :: String -> Int -> IO Resource
newResourceIO name :: String
name mx :: Int
mx = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
mx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall a. Partial => String -> IO a
errorIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "You cannot create a resource named " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ " with a negative quantity, you used " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
mx
Int
key <- IO Int
resourceId
Var Finite
var <- Finite -> IO (Var Finite)
forall a. a -> IO (Var a)
newVar (Finite -> IO (Var Finite)) -> Finite -> IO (Var Finite)
forall a b. (a -> b) -> a -> b
$ Int -> Bilist (Int, Fence IO ()) -> Finite
Finite Int
mx Bilist (Int, Fence IO ())
forall a. Monoid a => a
mempty
Resource -> IO Resource
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resource -> IO Resource) -> Resource -> IO Resource
forall a b. (a -> b) -> a -> b
$ Int
-> String
-> (Pool -> Int -> IO (Maybe (Fence IO ())))
-> (Pool -> Int -> IO ())
-> Resource
Resource (Int -> Int
forall a. Num a => a -> a
negate Int
key) String
shw (Var Finite -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquire Var Finite
var) (Var Finite -> Pool -> Int -> IO ()
release Var Finite
var)
where
shw :: String
shw = "Resource " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
acquire :: Var Finite -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquire :: Var Finite -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquire var :: Var Finite
var _ want :: Int
want
| Int
want Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = String -> IO (Maybe (Fence IO ()))
forall a. Partial => String -> IO a
errorIO (String -> IO (Maybe (Fence IO ())))
-> String -> IO (Maybe (Fence IO ()))
forall a b. (a -> b) -> a -> b
$ "You cannot acquire a negative quantity of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
shw String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", requested " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
want
| Int
want Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
mx = String -> IO (Maybe (Fence IO ()))
forall a. Partial => String -> IO a
errorIO (String -> IO (Maybe (Fence IO ())))
-> String -> IO (Maybe (Fence IO ()))
forall a b. (a -> b) -> a -> b
$ "You cannot acquire more than " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
mx String -> String -> String
forall a. [a] -> [a] -> [a]
++ " of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
shw String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", requested " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
want
| Bool
otherwise = Var Finite
-> (Finite -> IO (Finite, Maybe (Fence IO ())))
-> IO (Maybe (Fence IO ()))
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Finite
var ((Finite -> IO (Finite, Maybe (Fence IO ())))
-> IO (Maybe (Fence IO ())))
-> (Finite -> IO (Finite, Maybe (Fence IO ())))
-> IO (Maybe (Fence IO ()))
forall a b. (a -> b) -> a -> b
$ \x :: Finite
x@Finite{..} ->
if Int
want Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
finiteAvailable then
(Finite, Maybe (Fence IO ())) -> IO (Finite, Maybe (Fence IO ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Finite
x{finiteAvailable :: Int
finiteAvailable = Int
finiteAvailable Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
want}, Maybe (Fence IO ())
forall a. Maybe a
Nothing)
else do
Fence IO ()
fence <- IO (Fence IO ())
forall (m :: * -> *) a. MonadIO m => IO (Fence m a)
newFence
(Finite, Maybe (Fence IO ())) -> IO (Finite, Maybe (Fence IO ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Finite
x{finiteWaiting :: Bilist (Int, Fence IO ())
finiteWaiting = Bilist (Int, Fence IO ())
finiteWaiting Bilist (Int, Fence IO ())
-> (Int, Fence IO ()) -> Bilist (Int, Fence IO ())
forall a. Bilist a -> a -> Bilist a
`snoc` (Int
want, Fence IO ()
fence)}, Fence IO () -> Maybe (Fence IO ())
forall a. a -> Maybe a
Just Fence IO ()
fence)
release :: Var Finite -> Pool -> Int -> IO ()
release :: Var Finite -> Pool -> Int -> IO ()
release var :: Var Finite
var _ i :: Int
i = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Finite -> (Finite -> IO (Finite, IO ())) -> IO (IO ())
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Finite
var ((Finite -> IO (Finite, IO ())) -> IO (IO ()))
-> (Finite -> IO (Finite, IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \x :: Finite
x -> (Finite, IO ()) -> IO (Finite, IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Finite, IO ()) -> IO (Finite, IO ()))
-> (Finite, IO ()) -> IO (Finite, IO ())
forall a b. (a -> b) -> a -> b
$ Finite -> (Finite, IO ())
f Finite
x{finiteAvailable :: Int
finiteAvailable = Finite -> Int
finiteAvailable Finite
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i}
where
f :: Finite -> (Finite, IO ())
f (Finite i :: Int
i (Bilist (Int, Fence IO ())
-> Maybe ((Int, Fence IO ()), Bilist (Int, Fence IO ()))
forall a. Bilist a -> Maybe (a, Bilist a)
uncons -> Just ((wi :: Int
wi,wa :: Fence IO ()
wa),ws :: Bilist (Int, Fence IO ())
ws)))
| Int
wi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i = (IO () -> IO ()) -> (Finite, IO ()) -> (Finite, IO ())
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (Fence IO () -> () -> IO ()
forall (m :: * -> *) a.
(Partial, MonadIO m) =>
Fence m a -> a -> m ()
signalFence Fence IO ()
wa () IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>) ((Finite, IO ()) -> (Finite, IO ()))
-> (Finite, IO ()) -> (Finite, IO ())
forall a b. (a -> b) -> a -> b
$ Finite -> (Finite, IO ())
f (Finite -> (Finite, IO ())) -> Finite -> (Finite, IO ())
forall a b. (a -> b) -> a -> b
$ Int -> Bilist (Int, Fence IO ()) -> Finite
Finite (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
wi) Bilist (Int, Fence IO ())
ws
| Bool
otherwise = (Finite -> Finite) -> (Finite, IO ()) -> (Finite, IO ())
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first ((Int, Fence IO ()) -> Finite -> Finite
add (Int
wi,Fence IO ()
wa)) ((Finite, IO ()) -> (Finite, IO ()))
-> (Finite, IO ()) -> (Finite, IO ())
forall a b. (a -> b) -> a -> b
$ Finite -> (Finite, IO ())
f (Finite -> (Finite, IO ())) -> Finite -> (Finite, IO ())
forall a b. (a -> b) -> a -> b
$ Int -> Bilist (Int, Fence IO ()) -> Finite
Finite Int
i Bilist (Int, Fence IO ())
ws
f (Finite i :: Int
i _) = (Int -> Bilist (Int, Fence IO ()) -> Finite
Finite Int
i Bilist (Int, Fence IO ())
forall a. Monoid a => a
mempty, () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
add :: (Int, Fence IO ()) -> Finite -> Finite
add a :: (Int, Fence IO ())
a s :: Finite
s = Finite
s{finiteWaiting :: Bilist (Int, Fence IO ())
finiteWaiting = (Int, Fence IO ())
a (Int, Fence IO ())
-> Bilist (Int, Fence IO ()) -> Bilist (Int, Fence IO ())
forall a. a -> Bilist a -> Bilist a
`cons` Finite -> Bilist (Int, Fence IO ())
finiteWaiting Finite
s}
waiter :: Seconds -> IO () -> IO ()
waiter :: Seconds -> IO () -> IO ()
waiter period :: Seconds
period act :: IO ()
act = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
Seconds -> IO ()
sleep Seconds
period
IO ()
act
data Throttle
= ThrottleAvailable !Int
| ThrottleWaiting (IO ()) (Bilist (Int, Fence IO ()))
newThrottleIO :: String -> Int -> Double -> IO Resource
newThrottleIO :: String -> Int -> Seconds -> IO Resource
newThrottleIO name :: String
name count :: Int
count period :: Seconds
period = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall a. Partial => String -> IO a
errorIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "You cannot create a throttle named " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ " with a negative quantity, you used " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
count
Int
key <- IO Int
resourceId
Var Throttle
var <- Throttle -> IO (Var Throttle)
forall a. a -> IO (Var a)
newVar (Throttle -> IO (Var Throttle)) -> Throttle -> IO (Var Throttle)
forall a b. (a -> b) -> a -> b
$ Int -> Throttle
ThrottleAvailable Int
count
Resource -> IO Resource
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resource -> IO Resource) -> Resource -> IO Resource
forall a b. (a -> b) -> a -> b
$ Int
-> String
-> (Pool -> Int -> IO (Maybe (Fence IO ())))
-> (Pool -> Int -> IO ())
-> Resource
Resource Int
key String
shw (Var Throttle -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquire Var Throttle
var) (Var Throttle -> Pool -> Int -> IO ()
release Var Throttle
var)
where
shw :: String
shw = "Throttle " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
acquire :: Var Throttle -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquire :: Var Throttle -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquire var :: Var Throttle
var pool :: Pool
pool want :: Int
want
| Int
want Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = String -> IO (Maybe (Fence IO ()))
forall a. Partial => String -> IO a
errorIO (String -> IO (Maybe (Fence IO ())))
-> String -> IO (Maybe (Fence IO ()))
forall a b. (a -> b) -> a -> b
$ "You cannot acquire a negative quantity of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
shw String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", requested " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
want
| Int
want Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
count = String -> IO (Maybe (Fence IO ()))
forall a. Partial => String -> IO a
errorIO (String -> IO (Maybe (Fence IO ())))
-> String -> IO (Maybe (Fence IO ()))
forall a b. (a -> b) -> a -> b
$ "You cannot acquire more than " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
count String -> String -> String
forall a. [a] -> [a] -> [a]
++ " of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
shw String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", requested " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
want
| Bool
otherwise = Var Throttle
-> (Throttle -> IO (Throttle, Maybe (Fence IO ())))
-> IO (Maybe (Fence IO ()))
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Throttle
var ((Throttle -> IO (Throttle, Maybe (Fence IO ())))
-> IO (Maybe (Fence IO ())))
-> (Throttle -> IO (Throttle, Maybe (Fence IO ())))
-> IO (Maybe (Fence IO ()))
forall a b. (a -> b) -> a -> b
$ \case
ThrottleAvailable i :: Int
i
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
want -> (Throttle, Maybe (Fence IO ()))
-> IO (Throttle, Maybe (Fence IO ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Throttle
ThrottleAvailable (Int -> Throttle) -> Int -> Throttle
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
want, Maybe (Fence IO ())
forall a. Maybe a
Nothing)
| Bool
otherwise -> do
IO ()
stop <- Pool -> IO (IO ())
keepAlivePool Pool
pool
Fence IO ()
fence <- IO (Fence IO ())
forall (m :: * -> *) a. MonadIO m => IO (Fence m a)
newFence
(Throttle, Maybe (Fence IO ()))
-> IO (Throttle, Maybe (Fence IO ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> Bilist (Int, Fence IO ()) -> Throttle
ThrottleWaiting IO ()
stop (Bilist (Int, Fence IO ()) -> Throttle)
-> Bilist (Int, Fence IO ()) -> Throttle
forall a b. (a -> b) -> a -> b
$ (Int
want Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i, Fence IO ()
fence) (Int, Fence IO ())
-> Bilist (Int, Fence IO ()) -> Bilist (Int, Fence IO ())
forall a. a -> Bilist a -> Bilist a
`cons` Bilist (Int, Fence IO ())
forall a. Monoid a => a
mempty, Fence IO () -> Maybe (Fence IO ())
forall a. a -> Maybe a
Just Fence IO ()
fence)
ThrottleWaiting stop :: IO ()
stop xs :: Bilist (Int, Fence IO ())
xs -> do
Fence IO ()
fence <- IO (Fence IO ())
forall (m :: * -> *) a. MonadIO m => IO (Fence m a)
newFence
(Throttle, Maybe (Fence IO ()))
-> IO (Throttle, Maybe (Fence IO ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> Bilist (Int, Fence IO ()) -> Throttle
ThrottleWaiting IO ()
stop (Bilist (Int, Fence IO ()) -> Throttle)
-> Bilist (Int, Fence IO ()) -> Throttle
forall a b. (a -> b) -> a -> b
$ Bilist (Int, Fence IO ())
xs Bilist (Int, Fence IO ())
-> (Int, Fence IO ()) -> Bilist (Int, Fence IO ())
forall a. Bilist a -> a -> Bilist a
`snoc` (Int
want, Fence IO ()
fence), Fence IO () -> Maybe (Fence IO ())
forall a. a -> Maybe a
Just Fence IO ()
fence)
release :: Var Throttle -> Pool -> Int -> IO ()
release :: Var Throttle -> Pool -> Int -> IO ()
release var :: Var Throttle
var _ n :: Int
n = Seconds -> IO () -> IO ()
waiter Seconds
period (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Throttle -> (Throttle -> IO (Throttle, IO ())) -> IO (IO ())
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Throttle
var ((Throttle -> IO (Throttle, IO ())) -> IO (IO ()))
-> (Throttle -> IO (Throttle, IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \x :: Throttle
x -> (Throttle, IO ()) -> IO (Throttle, IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Throttle, IO ()) -> IO (Throttle, IO ()))
-> (Throttle, IO ()) -> IO (Throttle, IO ())
forall a b. (a -> b) -> a -> b
$ case Throttle
x of
ThrottleAvailable i :: Int
i -> (Int -> Throttle
ThrottleAvailable (Int -> Throttle) -> Int -> Throttle
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n, () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
ThrottleWaiting stop :: IO ()
stop xs :: Bilist (Int, Fence IO ())
xs -> IO () -> Int -> Bilist (Int, Fence IO ()) -> (Throttle, IO ())
f IO ()
stop Int
n Bilist (Int, Fence IO ())
xs
where
f :: IO () -> Int -> Bilist (Int, Fence IO ()) -> (Throttle, IO ())
f stop :: IO ()
stop i :: Int
i (Bilist (Int, Fence IO ())
-> Maybe ((Int, Fence IO ()), Bilist (Int, Fence IO ()))
forall a. Bilist a -> Maybe (a, Bilist a)
uncons -> Just ((wi :: Int
wi,wa :: Fence IO ()
wa),ws :: Bilist (Int, Fence IO ())
ws))
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
wi = (IO () -> IO ()) -> (Throttle, IO ()) -> (Throttle, IO ())
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (Fence IO () -> () -> IO ()
forall (m :: * -> *) a.
(Partial, MonadIO m) =>
Fence m a -> a -> m ()
signalFence Fence IO ()
wa () IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>) ((Throttle, IO ()) -> (Throttle, IO ()))
-> (Throttle, IO ()) -> (Throttle, IO ())
forall a b. (a -> b) -> a -> b
$ IO () -> Int -> Bilist (Int, Fence IO ()) -> (Throttle, IO ())
f IO ()
stop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
wi) Bilist (Int, Fence IO ())
ws
| Bool
otherwise = (IO () -> Bilist (Int, Fence IO ()) -> Throttle
ThrottleWaiting IO ()
stop (Bilist (Int, Fence IO ()) -> Throttle)
-> Bilist (Int, Fence IO ()) -> Throttle
forall a b. (a -> b) -> a -> b
$ (Int
wiInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i,Fence IO ()
wa) (Int, Fence IO ())
-> Bilist (Int, Fence IO ()) -> Bilist (Int, Fence IO ())
forall a. a -> Bilist a -> Bilist a
`cons` Bilist (Int, Fence IO ())
ws, () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
f stop :: IO ()
stop i :: Int
i _ = (Int -> Throttle
ThrottleAvailable Int
i, IO ()
stop)