{-# 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 Int
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
$ \Int
i -> let j :: Int
j = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 in (Int
j, Int
j)


-- | Run an action which uses part of a finite resource. For more details see 'Resource'.
--   You cannot depend on a rule (e.g. 'need') while a resource is held.
withResource :: Resource -> Int -> Action a -> Action a
withResource :: Resource -> Int -> Action a -> Action a
withResource Resource
r Int
i Action a
act = do
    Global{Bool
Maybe Shared
Maybe Cloud
IO Seconds
IO Progress
IORef [IO ()]
IORef [(Key, Key)]
HashMap TypeRep BuiltinRule
Cleanup
ShakeOptions
Database
Pool
Map UserRuleVersioned
Step
[String] -> [Key] -> Action [Value]
IO String -> IO ()
Key -> Action ()
Verbosity -> String -> IO ()
globalOneShot :: Global -> Bool
globalStep :: Global -> Step
globalCloud :: Global -> Maybe Cloud
globalShared :: Global -> Maybe Shared
globalUserRules :: Global -> Map UserRuleVersioned
globalProgress :: Global -> IO Progress
globalTrackAbsent :: Global -> IORef [(Key, Key)]
globalAfter :: Global -> IORef [IO ()]
globalRuleFinished :: Global -> Key -> Action ()
globalDiagnostic :: Global -> IO String -> IO ()
globalOptions :: Global -> ShakeOptions
globalOutput :: Global -> Verbosity -> String -> IO ()
globalRules :: Global -> HashMap TypeRep BuiltinRule
globalTimestamp :: Global -> IO Seconds
globalCleanup :: Global -> Cleanup
globalPool :: Global -> Pool
globalDatabase :: Global -> Database
globalBuild :: Global -> [String] -> [Key] -> Action [Value]
globalOneShot :: Bool
globalStep :: Step
globalCloud :: Maybe Cloud
globalShared :: Maybe Shared
globalUserRules :: Map UserRuleVersioned
globalProgress :: IO Progress
globalTrackAbsent :: IORef [(Key, Key)]
globalAfter :: IORef [IO ()]
globalRuleFinished :: Key -> Action ()
globalDiagnostic :: IO String -> IO ()
globalOptions :: ShakeOptions
globalOutput :: Verbosity -> String -> IO ()
globalRules :: HashMap TypeRep BuiltinRule
globalTimestamp :: IO Seconds
globalCleanup :: Cleanup
globalPool :: Pool
globalDatabase :: Database
globalBuild :: [String] -> [Key] -> Action [Value]
..} <- 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]
++ String
" 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 IO ()
fence -> do
        (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]
++ String
" 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 (String
"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]
++ String
" released " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i



-- | A type representing an external resource which the build system should respect. There
--   are two ways to create 'Resource's in Shake:
--
-- * 'Development.Shake.newResource' creates a finite resource, stopping too many actions running
--   simultaneously.
--
-- * 'Development.Shake.newThrottle' creates a throttled resource, stopping too many actions running
--   over a short time period.
--
--   These resources are used with 'Development.Shake.withResource' when defining rules. Typically only
--   system commands (such as 'Development.Shake.cmd') should be run inside 'Development.Shake.withResource',
--   not commands such as 'Development.Shake.need'.
--
--   Be careful that the actions run within 'Development.Shake.withResource' do not themselves require further
--   resources, or you may get a \"thread blocked indefinitely in an MVar operation\" exception.
--   If an action requires multiple resources, use 'Development.Shake.withResources' to avoid deadlock.
data Resource = Resource
    {Resource -> Int
resourceOrd :: Int
        -- ^ Key used for Eq/Ord operations. To make withResources work, we require newResourceIO < newThrottleIO
    ,Resource -> String
resourceShow :: String
        -- ^ String used for Show
    ,Resource -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquireResource :: Pool -> Int -> IO (Maybe (Fence IO ()))
        -- ^ Acquire the resource and call the function.
    ,Resource -> Pool -> Int -> IO ()
releaseResource :: Pool -> Int -> IO ()
        -- ^ You should only ever releaseResource that you obtained with acquireResource.
    }

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


---------------------------------------------------------------------
-- FINITE RESOURCES

data Finite = Finite
    {Finite -> Int
finiteAvailable :: !Int
        -- ^ number of currently available resources
    ,Finite -> Bilist (Int, Fence IO ())
finiteWaiting :: Bilist (Int, Fence IO ())
        -- ^ queue of people with how much they want and the action when it is allocated to them
    }

-- | A version of 'Development.Shake.newResource' that runs in IO, and can be called before calling 'Development.Shake.shake'.
--   Most people should use 'Development.Shake.newResource' instead.
newResourceIO :: String -> Int -> IO Resource
newResourceIO :: String -> Int -> IO Resource
newResourceIO String
name 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
< Int
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
$ String
"You cannot create a resource named " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 = String
"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 Finite
var Pool
_ Int
want
            | Int
want Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
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
$ String
"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]
++ String
", 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
$ String
"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]
++ String
" of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
shw String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", 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{Int
Bilist (Int, Fence IO ())
finiteWaiting :: Bilist (Int, Fence IO ())
finiteAvailable :: Int
finiteWaiting :: Finite -> Bilist (Int, Fence IO ())
finiteAvailable :: Finite -> Int
..} ->
                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 Finite
var Pool
_ 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
$ \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 Int
i (Bilist (Int, Fence IO ())
-> Maybe ((Int, Fence IO ()), Bilist (Int, Fence IO ()))
forall a. Bilist a -> Maybe (a, Bilist a)
uncons -> Just ((Int
wi,Fence IO ()
wa),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 Int
i Bilist (Int, Fence IO ())
_) = (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 (Int, Fence IO ())
a 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}


---------------------------------------------------------------------
-- THROTTLE RESOURCES


-- call a function after a certain delay
waiter :: Seconds -> IO () -> IO ()
waiter :: Seconds -> IO () -> IO ()
waiter Seconds
period 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
      -- | Some number of resources are available
    = ThrottleAvailable !Int
      -- | Some users are blocked (non-empty), plus an action to call once we go back to Available
    | ThrottleWaiting (IO ()) (Bilist (Int, Fence IO ()))


-- | A version of 'Development.Shake.newThrottle' that runs in IO, and can be called before calling 'Development.Shake.shake'.
--   Most people should use 'Development.Shake.newThrottle' instead.
newThrottleIO :: String -> Int -> Double -> IO Resource
newThrottleIO :: String -> Int -> Seconds -> IO Resource
newThrottleIO String
name Int
count 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
< Int
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
$ String
"You cannot create a throttle named " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 = String
"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 Throttle
var Pool
pool Int
want
            | Int
want Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
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
$ String
"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]
++ String
", 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
$ String
"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]
++ String
" of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
shw String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", 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 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 IO ()
stop 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 Throttle
var Pool
_ 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
$ \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 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 IO ()
stop 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 IO ()
stop Int
i (Bilist (Int, Fence IO ())
-> Maybe ((Int, Fence IO ()), Bilist (Int, Fence IO ()))
forall a. Bilist a -> Maybe (a, Bilist a)
uncons -> Just ((Int
wi,Fence IO ()
wa),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 IO ()
stop Int
i Bilist (Int, Fence IO ())
_ = (Int -> Throttle
ThrottleAvailable Int
i, IO ()
stop)