    {-# 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 = (combineWith go go p1 p2)
    	`describe` d
      where
    	d = getDesc p1 ++ " `concurrently` " ++ getDesc 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 (Just a1) (Just a2) = Just $ do
    		n <- liftIO getNumProcessors
    		withCapabilities n $
    			concurrentSatisfy a1 a2
    	go (Just a1) Nothing = Just a1
    	go Nothing (Just a2) = Just a2
    	go Nothing Nothing = 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 getn d (Props ps) = property d go `addChildren` ps
      where
    	go = do
    		n <- liftIO getn
    		withCapabilities n $
    			startworkers n =<< liftIO (newMVar ps)
    	startworkers n q
    		| n < 1 = return NoChange
    		| n == 1 = worker q NoChange
    		| otherwise =
    			worker q NoChange
    				`concurrentSatisfy`
    			startworkers (n-1) q
    	worker q r = do
    		v <- liftIO $ modifyMVar q $ \v -> case v of
    			[] -> return ([], Nothing)
    			(p:rest) -> return (rest, Just p)
    		case v of
    			Nothing -> return r
    			Just p -> do
    				hn <- asks hostName
    				r' <- case getSatisfy p of
    					Nothing -> return NoChange
    					Just a -> actionMessageOn hn (getDesc p) a
    				worker q (r <> 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 n a = bracket setup cleanup (const a)
      where
    	setup = do
    		np <- liftIO getNumProcessors
    		let n' = min n np
    		c <- liftIO getNumCapabilities
    		when (n' > c) $
    			liftIO $ setNumCapabilities n'
    		return c
    	cleanup = liftIO . setNumCapabilities

    -- | Running Propellor actions concurrently.
    concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result
    concurrentSatisfy a1 a2 = do
    	h <- ask
    	((r1, w1), (r2, w2)) <- liftIO $
    		runp a1 h `A.concurrently` runp a2 h
    	tell (w1 <> w2)
    	return (r1 <> r2)
      where
    	runp a h = evalRWST (runWithHost (catchPropellor a)) h ()