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