    {-# LANGUAGE FlexibleContexts #-}

    -- | Propellor properties can be made to run concurrently, using this
    -- module. This can speed up propellor, at the expense of using more CPUs
    -- and other resources.
    --
    -- It's up to you to make sure that properties that you make run concurrently
    -- don't implicitly depend on one-another. The worst that can happen
    -- though, is that propellor fails to ensure some of the properties,
    -- and tells you what went wrong.
    --
    -- Another potential problem is that output of concurrent properties could
    -- interleave into a scrambled mess. This is mostly prevented; all messages
    -- output by propellor are concurrency safe, including `errorMessage`,
    -- `infoMessage`, etc. However, if you write a property that directly
    -- uses `print` or `putStrLn`, you can still experience this problem.
    --
    -- Similarly, when properties run external commands, the command's output
    -- can be a problem for concurrency. No need to worry;
    -- `Propellor.Property.Cmd.createProcess` is concurrent output safe
    -- (it actually uses `Propellor.Message.createProcessConcurrent`), and
    -- everything else in propellor that runs external commands is built on top
    -- of that. Of course, if you import System.Process and use it in a
    -- property, you can bypass that and shoot yourself in the foot.
    --
    -- Finally, anything that directly accesses the tty can bypass
    -- these protections. That's sometimes done for eg, password prompts.
    -- A well-written property should avoid running interactive commands
    -- anyway.

    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

    -- | Ensures two properties concurrently.
    --
    -- >	& foo `concurrently` bar
    --
    -- To ensure three properties concurrently, just use this combinator twice:
    --
    -- >	& foo `concurrently` bar `concurrently` baz
    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
    p1 p2 :: 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]
    ++ " `concurrently` " Desc -> Desc -> Desc
    forall a. [a] -> [a] -> [a]
    ++ p2 -> Desc
    forall p. IsProp p => p -> Desc
    getDesc p2
    p2
    	-- Increase the number of capabilities right up to the number of
    	-- processors, so that A `concurrently` B `concurrently` C
    	-- runs all 3 properties on different processors when possible.
    	go :: ResultCombiner
    go (Just a1 :: Propellor Result
    a1) (Just a2 :: 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 a1 :: Propellor Result
    a1) Nothing = Propellor Result -> Maybe (Propellor Result)
    forall a. a -> Maybe a
    Just Propellor Result
    a1
    	go Nothing (Just a2 :: Propellor Result
    a2) = Propellor Result -> Maybe (Propellor Result)
    forall a. a -> Maybe a
    Just Propellor Result
    a2
    	go Nothing Nothing = Maybe (Propellor Result)
    forall a. Maybe a
    Nothing

    -- | Ensures all the properties in the list, with a specified amount of
    -- concurrency.
    --
    -- > concurrentList (pure 2) "demo" $ props
    -- >	& foo
    -- >	& bar
    -- >	& baz
    --
    -- The above example will run foo and bar concurrently, and once either of
    -- those 2 properties finishes, will start running baz.
    concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
    concurrentList :: IO Int
    -> Desc
    -> Props (MetaTypes metatypes)
    -> Property (MetaTypes metatypes)
    concurrentList getn :: IO Int
    getn d :: Desc
    d (Props ps :: [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 n :: t
    n q :: MVar [p]
    q
    		| t
    n t -> t -> Bool
    forall a. Ord a => a -> a -> Bool
    < 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
    == 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
    -1) MVar [p]
    q
    	worker :: MVar [p] -> Result -> Propellor Result
    worker q :: MVar [p]
    q r :: 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
    $ \v :: [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]
    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
    			Nothing -> Result -> Propellor Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    r
    			Just p :: 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
    					Nothing -> Result -> Propellor Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    NoChange
    					Just a :: 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')

    -- | Run an action with the number of capabiities increased as necessary to
    -- allow running on the specified number of cores.
    --
    -- Never increases the number of capabilities higher than the actual number
    -- of processors.
    withCapabilities :: Int -> Propellor a -> Propellor a
    withCapabilities :: Int -> Propellor a -> Propellor a
    withCapabilities n :: Int
    n a :: 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

    -- | Running Propellor actions concurrently.
    concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result
    concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result
    concurrentSatisfy a1 :: Propellor Result
    a1 a2 :: Propellor Result
    a2 = do
    	Host
    h <- Propellor Host
    forall r (m :: * -> *). MonadReader r m => m r
    ask
    	((r1 :: Result
    r1, w1 :: [EndAction]
    w1), (r2 :: Result
    r2, w2 :: [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 a :: Propellor Result
    a h :: 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 ()