{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property.Concurrent (
concurrently,
concurrentList,
props,
getNumProcessors,
concurrentSatisfy,
) where
import Propellor.Base
import Propellor.Types.Core
import Propellor.Types.MetaTypes
import Control.Concurrent
import qualified Control.Concurrent.Async as A
import GHC.Conc (getNumProcessors)
import Control.Monad.RWS.Strict
concurrently
:: (IsProp p1, IsProp p2, Combines p1 p2, IsProp (CombinedType p1 p2))
=> p1
-> p2
-> CombinedType p1 p2
concurrently :: p1 -> p2 -> CombinedType p1 p2
concurrently p1
p1 p2
p2 = (ResultCombiner -> ResultCombiner -> p1 -> p2 -> CombinedType p1 p2
forall x y.
Combines x y =>
ResultCombiner -> ResultCombiner -> x -> y -> CombinedType x y
combineWith ResultCombiner
go ResultCombiner
go p1
p1 p2
p2)
CombinedType p1 p2 -> Desc -> CombinedType p1 p2
forall p. IsProp p => p -> Desc -> p
`describe` Desc
d
where
d :: Desc
d = p1 -> Desc
forall p. IsProp p => p -> Desc
getDesc p1
p1 Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
" `concurrently` " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ p2 -> Desc
forall p. IsProp p => p -> Desc
getDesc p2
p2
go :: ResultCombiner
go (Just Propellor Result
a1) (Just Propellor Result
a2) = Propellor Result -> Maybe (Propellor Result)
forall a. a -> Maybe a
Just (Propellor Result -> Maybe (Propellor Result))
-> Propellor Result -> Maybe (Propellor Result)
forall a b. (a -> b) -> a -> b
$ do
Int
n <- IO Int -> Propellor Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
Int -> Propellor Result -> Propellor Result
forall a. Int -> Propellor a -> Propellor a
withCapabilities Int
n (Propellor Result -> Propellor Result)
-> Propellor Result -> Propellor Result
forall a b. (a -> b) -> a -> b
$
Propellor Result -> Propellor Result -> Propellor Result
concurrentSatisfy Propellor Result
a1 Propellor Result
a2
go (Just Propellor Result
a1) Maybe (Propellor Result)
Nothing = Propellor Result -> Maybe (Propellor Result)
forall a. a -> Maybe a
Just Propellor Result
a1
go Maybe (Propellor Result)
Nothing (Just Propellor Result
a2) = Propellor Result -> Maybe (Propellor Result)
forall a. a -> Maybe a
Just Propellor Result
a2
go Maybe (Propellor Result)
Nothing Maybe (Propellor Result)
Nothing = Maybe (Propellor Result)
forall a. Maybe a
Nothing
concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
concurrentList :: IO Int
-> Desc
-> Props (MetaTypes metatypes)
-> Property (MetaTypes metatypes)
concurrentList IO Int
getn Desc
d (Props [ChildProperty]
ps) = Desc -> Propellor Result -> Property (MetaTypes metatypes)
forall k (metatypes :: k).
SingI metatypes =>
Desc -> Propellor Result -> Property (MetaTypes metatypes)
property Desc
d Propellor Result
go Property (MetaTypes metatypes)
-> [ChildProperty] -> Property (MetaTypes metatypes)
forall p. IsProp p => p -> [ChildProperty] -> p
`addChildren` [ChildProperty]
ps
where
go :: Propellor Result
go = do
Int
n <- IO Int -> Propellor Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getn
Int -> Propellor Result -> Propellor Result
forall a. Int -> Propellor a -> Propellor a
withCapabilities Int
n (Propellor Result -> Propellor Result)
-> Propellor Result -> Propellor Result
forall a b. (a -> b) -> a -> b
$
Int -> MVar [ChildProperty] -> Propellor Result
forall t p.
(Ord t, Num t, IsProp p) =>
t -> MVar [p] -> Propellor Result
startworkers Int
n (MVar [ChildProperty] -> Propellor Result)
-> Propellor (MVar [ChildProperty]) -> Propellor Result
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (MVar [ChildProperty]) -> Propellor (MVar [ChildProperty])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([ChildProperty] -> IO (MVar [ChildProperty])
forall a. a -> IO (MVar a)
newMVar [ChildProperty]
ps)
startworkers :: t -> MVar [p] -> Propellor Result
startworkers t
n MVar [p]
q
| t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
1 = Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
| t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
1 = MVar [p] -> Result -> Propellor Result
forall p. IsProp p => MVar [p] -> Result -> Propellor Result
worker MVar [p]
q Result
NoChange
| Bool
otherwise =
MVar [p] -> Result -> Propellor Result
forall p. IsProp p => MVar [p] -> Result -> Propellor Result
worker MVar [p]
q Result
NoChange
Propellor Result -> Propellor Result -> Propellor Result
`concurrentSatisfy`
t -> MVar [p] -> Propellor Result
startworkers (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) MVar [p]
q
worker :: MVar [p] -> Result -> Propellor Result
worker MVar [p]
q Result
r = do
Maybe p
v <- IO (Maybe p) -> Propellor (Maybe p)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe p) -> Propellor (Maybe p))
-> IO (Maybe p) -> Propellor (Maybe p)
forall a b. (a -> b) -> a -> b
$ MVar [p] -> ([p] -> IO ([p], Maybe p)) -> IO (Maybe p)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar [p]
q (([p] -> IO ([p], Maybe p)) -> IO (Maybe p))
-> ([p] -> IO ([p], Maybe p)) -> IO (Maybe p)
forall a b. (a -> b) -> a -> b
$ \[p]
v -> case [p]
v of
[] -> ([p], Maybe p) -> IO ([p], Maybe p)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe p
forall a. Maybe a
Nothing)
(p
p:[p]
rest) -> ([p], Maybe p) -> IO ([p], Maybe p)
forall (m :: * -> *) a. Monad m => a -> m a
return ([p]
rest, p -> Maybe p
forall a. a -> Maybe a
Just p
p)
case Maybe p
v of
Maybe p
Nothing -> Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
Just p
p -> do
Desc
hn <- (Host -> Desc) -> Propellor Desc
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Host -> Desc
hostName
Result
r' <- case p -> Maybe (Propellor Result)
forall p. IsProp p => p -> Maybe (Propellor Result)
getSatisfy p
p of
Maybe (Propellor Result)
Nothing -> Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
Just Propellor Result
a -> Desc -> Desc -> Propellor Result -> Propellor Result
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
Desc -> Desc -> m r -> m r
actionMessageOn Desc
hn (p -> Desc
forall p. IsProp p => p -> Desc
getDesc p
p) Propellor Result
a
MVar [p] -> Result -> Propellor Result
worker MVar [p]
q (Result
r Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result
r')
withCapabilities :: Int -> Propellor a -> Propellor a
withCapabilities :: Int -> Propellor a -> Propellor a
withCapabilities Int
n Propellor a
a = Propellor Int
-> (Int -> Propellor ()) -> (Int -> Propellor a) -> Propellor a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket Propellor Int
setup Int -> Propellor ()
cleanup (Propellor a -> Int -> Propellor a
forall a b. a -> b -> a
const Propellor a
a)
where
setup :: Propellor Int
setup = do
Int
np <- IO Int -> Propellor Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
let n' :: Int
n' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
np
Int
c <- IO Int -> Propellor Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumCapabilities
Bool -> Propellor () -> Propellor ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
c) (Propellor () -> Propellor ()) -> Propellor () -> Propellor ()
forall a b. (a -> b) -> a -> b
$
IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
n'
Int -> Propellor Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
c
cleanup :: Int -> Propellor ()
cleanup = IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> (Int -> IO ()) -> Int -> Propellor ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
setNumCapabilities
concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result
concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result
concurrentSatisfy Propellor Result
a1 Propellor Result
a2 = do
Host
h <- Propellor Host
forall r (m :: * -> *). MonadReader r m => m r
ask
((Result
r1, [EndAction]
w1), (Result
r2, [EndAction]
w2)) <- IO ((Result, [EndAction]), (Result, [EndAction]))
-> Propellor ((Result, [EndAction]), (Result, [EndAction]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((Result, [EndAction]), (Result, [EndAction]))
-> Propellor ((Result, [EndAction]), (Result, [EndAction])))
-> IO ((Result, [EndAction]), (Result, [EndAction]))
-> Propellor ((Result, [EndAction]), (Result, [EndAction]))
forall a b. (a -> b) -> a -> b
$
Propellor Result -> Host -> IO (Result, [EndAction])
runp Propellor Result
a1 Host
h IO (Result, [EndAction])
-> IO (Result, [EndAction])
-> IO ((Result, [EndAction]), (Result, [EndAction]))
forall a b. IO a -> IO b -> IO (a, b)
`A.concurrently` Propellor Result -> Host -> IO (Result, [EndAction])
runp Propellor Result
a2 Host
h
[EndAction] -> Propellor ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([EndAction]
w1 [EndAction] -> [EndAction] -> [EndAction]
forall a. Semigroup a => a -> a -> a
<> [EndAction]
w2)
Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
r1 Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result
r2)
where
runp :: Propellor Result -> Host -> IO (Result, [EndAction])
runp Propellor Result
a Host
h = RWST Host [EndAction] () IO Result
-> Host -> () -> IO (Result, [EndAction])
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> r -> s -> m (a, w)
evalRWST (Propellor Result -> RWST Host [EndAction] () IO Result
forall p. Propellor p -> RWST Host [EndAction] () IO p
runWithHost (Propellor Result -> Propellor Result
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
m Result -> m Result
catchPropellor Propellor Result
a)) Host
h ()