{-# 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)
resourceCounter

-- Work around for GHC bug https://gitlab.haskell.org/ghc/ghc/-/issues/19413
{-# NOINLINE  resourceCounter #-}
resourceCounter :: IO (IO Int)
resourceCounter :: IO (IO Int)
resourceCounter = do
    ref <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
    pure $ atomicModifyIORef' ref $ \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 :: forall a. Resource -> Int -> Action a -> Action a
withResource Resource
r Int
i 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
    liftIO $ globalDiagnostic $ pure $ show r ++ " waiting to acquire " ++ show i

    fence <- liftIO $ acquireResource r globalPool i
    whenJust fence $ \Fence IO ()
fence -> do
        (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
        Action $ modifyRW $ addDiscount offset

    liftIO $ globalDiagnostic $ pure $ show r ++ " running with " ++ show i
    Action $ fromAction (blockApply ("Within withResource using " ++ show r) act) `finallyRAW` do
        liftIO $ releaseResource r globalPool i
        liftIO $ globalDiagnostic $ pure $ show r ++ " released " ++ show 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
    key <- IO Int
resourceId
    var <- newVar $ Finite mx mempty
    pure $ Resource (negate key) shw (acquire var) (release 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 ())
finiteAvailable :: Finite -> Int
finiteWaiting :: Finite -> Bilist (Int, Fence IO ())
finiteAvailable :: Int
finiteWaiting :: Bilist (Int, Fence IO ())
..} ->
                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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Finite
x{finiteAvailable = finiteAvailable - want}, Maybe (Fence IO ())
forall a. Maybe a
Nothing)
                else do
                    fence <- IO (Fence IO ())
forall (m :: * -> *) a. MonadIO m => IO (Fence m a)
newFence
                    pure (x{finiteWaiting = finiteWaiting `snoc` (want, fence)}, Just 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 a. a -> IO a
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 = finiteAvailable x + 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 a b. IO a -> IO b -> IO b
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 a. a -> IO a
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 = a `cons` finiteWaiting 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
    key <- IO Int
resourceId
    var <- newVar $ ThrottleAvailable count
    pure $ Resource key shw (acquire var) (release 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 a. a -> IO a
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
                        stop <- Pool -> IO (IO ())
keepAlivePool Pool
pool
                        fence <- newFence
                        pure (ThrottleWaiting stop $ (want - i, fence) `cons` mempty, Just fence)
                ThrottleWaiting IO ()
stop Bilist (Int, Fence IO ())
xs -> do
                    fence <- IO (Fence IO ())
forall (m :: * -> *) a. MonadIO m => IO (Fence m a)
newFence
                    pure (ThrottleWaiting stop $ xs `snoc` (want, fence), Just 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 a. a -> IO a
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 a. a -> IO a
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 a b. IO a -> IO b -> IO b
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 a. a -> IO a
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)