module Development.Shake.Resource(
Resource, newResourceIO, newThrottleIO, acquireResource, releaseResource
) where
import Development.Shake.Errors
import General.Base
import Data.Function
import System.IO.Unsafe
import Control.Arrow
import Control.Monad
resourceIds :: Var Int
resourceIds = unsafePerformIO $ newVar 0
resourceId :: IO Int
resourceId = modifyVar resourceIds $ \i -> let j = i + 1 in j `seq` return (j, j)
data Resource = Resource
{resourceOrd :: Int
,resourceShow :: String
,acquireResource :: Int -> IO (Maybe (IO ()))
,releaseResource :: Int -> IO ()
}
instance Show Resource where show = resourceShow
instance Eq Resource where (==) = (==) `on` resourceOrd
instance Ord Resource where compare = compare `on` resourceOrd
type Finite = Var (Int, [(Int,Barrier ())])
newResourceIO :: String -> Int -> IO Resource
newResourceIO name mx = do
when (mx < 0) $
error $ "You cannot create a resource named " ++ name ++ " with a negative quantity, you used " ++ show mx
key <- resourceId
var <- newVar (mx, [])
return $ Resource (negate key) shw (acquire var) (release var)
where
shw = "Resource " ++ name
acquire :: Finite -> Int -> IO (Maybe (IO ()))
acquire var want
| want < 0 = error $ "You cannot acquire a negative quantity of " ++ shw ++ ", requested " ++ show want
| want > mx = error $ "You cannot acquire more than " ++ show mx ++ " of " ++ shw ++ ", requested " ++ show want
| otherwise = modifyVar var $ \(available,waiting) ->
if want <= available then
return ((available want, waiting), Nothing)
else do
bar <- newBarrier
return ((available, waiting ++ [(want,bar)]), Just $ waitBarrier bar)
release :: Finite -> Int -> IO ()
release var i = modifyVar_ var $ \(available,waiting) -> f (available+i) waiting
where
f i ((wi,wa):ws) | wi <= i = signalBarrier wa () >> f (iwi) ws
| otherwise = do (i,ws) <- f i ws; return (i,(wi,wa):ws)
f i [] = return (i, [])
data Throttle = Throttle
{throttleLock :: Lock
,throttleVal :: Var (Either (Barrier ()) [(Time, Int)])
,throttleTime :: IO Time
}
newThrottleIO :: String -> Int -> Double -> IO Resource
newThrottleIO name count period_ = do
when (count < 0) $
error $ "You cannot create a throttle named " ++ name ++ " with a negative quantity, you used " ++ show count
key <- resourceId
lock <- newLock
time <- offsetTime
rep <- newVar $ Right [(0, count)]
let s = Throttle lock rep time
return $ Resource key shw (acquire s) (release s)
where
period = fromRational $ toRational period_
shw = "Throttle " ++ name
release :: Throttle -> Int -> IO ()
release Throttle{..} n = do
t <- throttleTime
modifyVar_ throttleVal $ \v -> case v of
Left b -> signalBarrier b () >> return (Right [(t+period, n)])
Right ts -> return $ Right $ ts ++ [(t+period, n)]
acquire :: Throttle -> Int -> IO (Maybe (IO ()))
acquire Throttle{..} want
| want < 0 = error $ "You cannot acquire a negative quantity of " ++ shw ++ ", requested " ++ show want
| want > count = error $ "You cannot acquire more than " ++ show count ++ " of " ++ shw ++ ", requested " ++ show want
| otherwise = do
let grab t vs = do
let (a,b) = span ((<= t) . fst) vs
return (sum $ map snd a, map (first $ min $ t+period) b)
let push i vs = [(0,i) | i > 0] ++ vs
res <- withLockTry throttleLock $ do
modifyVar throttleVal $ \v -> case v of
Right vs -> do
t <- throttleTime
(got,vs) <- grab t vs
if got >= want then
return (Right $ push (got want) vs, True)
else
return (Right $ push got vs, False)
_ -> return (v, False)
if res == Just True then
return Nothing
else
return $ Just $ withLock throttleLock $ do
let f want = join $ modifyVar throttleVal $ \v -> case v of
Left _ -> err "newThrottle, invariant failed, Left while holding throttleLock"
Right vs -> do
t <- throttleTime
(got,vs) <- grab t vs
case vs of
_ | got >= want -> return (Right $ push (got want) vs, return ())
[] -> do
b <- newBarrier
return (Left b, waitBarrier b >> f (want got))
(t2,n):vs -> do
return $ (,) (Right $ (0,n):vs) $ do
sleep $ min period (t2t)
f $ want got
f want