-- Communicating Haskell Processes.
-- Copyright (c) 2008, University of Kent.
-- All rights reserved.
-- 
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--  * Redistributions of source code must retain the above copyright
--    notice, this list of conditions and the following disclaimer.
--  * Redistributions in binary form must reproduce the above copyright
--    notice, this list of conditions and the following disclaimer in the
--    documentation and/or other materials provided with the distribution.
--  * Neither the name of the University of Kent nor the names of its
--    contributors may be used to endorse or promote products derived from
--    this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
-- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-- | A module containing barriers.
--
-- A barrier is a synchronisation primitive.  When N processes are enrolled
-- on a barrier, all N must synchronise on the barrier before any synchronisations
-- may complete, at which point they all complete.  That is, when a single
-- process synchronises on a barrier, it must then wait until all the other
-- enrolled processes also synchronise before it can finish.
--
-- Only processes enrolled on a barrier may synchronise on it.  Enrolled barriers
-- should not be passed around between processes, or used twice in a parallel
-- composition.  Instead, each process should enroll on the barrier itself.
--
-- Barriers support choice (alting).  This can lead to a lot of non-determinism
-- and some confusion.  Consider these two processes, both enrolled on barriers a and b:
--
-- > (sync a <-> sync b)
-- > (sync b <-> sync a)
--
-- Which barrier completes is determined by the run-time, and will be an arbitrary
-- choice.  This is even the case when priority is involved:
--
-- > (sync a </> sync b)
-- > (sync b </> sync a)
--
-- Clearly there is no way to resolve this to satisfy both priorities; the
-- run-time will end up choosing.
--
-- Barrier poison can be detected when syncing, enrolling or resigning.  You
-- may only poison a barrier that you are currently enrolled on.
--
-- Barriers can also support phases.  The idea behind a phased barrier is that
-- a barrier is always on a certain phase P.  Whenever a barrier successfully
-- completes, the phase is incremented (but it does not have to be an integer).
--  Everyone is told the new phase once they complete a synchronisation, and
-- may query the current phase for any barrier that they are currently enrolled
-- on.
module Control.Concurrent.CHP.Barriers (Barrier, EnrolledBarrier, newBarrier, newBarrierWithLabel,
  PhasedBarrier, newPhasedBarrier, newPhasedBarrierWithLabel, newPhasedBarrierCustomInc,
    newPhasedBarrierWithLabelCustomInc, currentPhase, waitForPhase,
    syncBarrier, getBarrierIdentifier) where

import Control.Concurrent.STM
import Control.Monad.State
import Control.Monad.Trans
import Data.Unique

import Control.Concurrent.CHP.Base
import Control.Concurrent.CHP.CSP
import Control.Concurrent.CHP.Enroll
import Control.Concurrent.CHP.Event
import Control.Concurrent.CHP.Traces.Base

-- | A special case of the PhasedBarrier that has no useful phases, i.e. a
-- standard barrier.
type Barrier = PhasedBarrier ()

-- | A useful type synonym for enrolled barriers with no phases
--
-- Added in 1.1.0
type EnrolledBarrier = Enrolled PhasedBarrier ()

-- | Synchronises on the given barrier.  You must be enrolled on a barrier in order
-- to synchronise on it.  Returns the new phase, following the synchronisation.
syncBarrier :: Enrolled PhasedBarrier phase -> CHP phase
syncBarrier = syncBarrierWith (indivRecJust BarrierSyncIndiv)
    
-- | Finds out the current phase a barrier is on.
currentPhase :: Enrolled PhasedBarrier phase -> CHP phase
currentPhase (Enrolled (Barrier (_, tv, _))) = liftIO $ atomically $ readTVar tv

repeatUntil :: (Monad m) => (a -> Bool) -> m a -> m ()
repeatUntil target comp = do x <- comp
                             unless (target x) $ repeatUntil target comp

-- | If the barrier is not in the given phase, synchronises on the barrier
-- repeatedly until it /is/ in the given phase.
waitForPhase :: Eq phase => phase -> Enrolled PhasedBarrier phase -> CHP ()
waitForPhase ph b = do phCur <- currentPhase b
                       when (ph /= phCur) $
                         repeatUntil (== ph) (syncBarrier b)

-- | Creates a new barrier with no processes enrolled
newBarrier :: CHP Barrier
newBarrier = newPhasedBarrier ()

-- | Creates a new barrier with no processes enrolled, that will be on the
-- given phase.  You will often want to pass in the last value in your phase
-- cycle, so that the first synchronisation moves it on to the first
newPhasedBarrier :: (Enum phase, Bounded phase, Eq phase) => phase -> CHP (PhasedBarrier phase)
newPhasedBarrier ph = liftPoison $ liftTrace $ do
  e <- liftIO $ newEvent BarrierSync 0
  tv <- liftIO $ atomically $ newTVar ph
  return $ Barrier (e, tv, \p -> if p == maxBound then minBound else succ p)

-- | Creates a new barrier with no processes enrolled, that will be on the
-- given phase, along with a custom function to increment the phase.  You can therefore
-- use this function with Integer as the inner type (and succ or (+1) as the incrementing
-- function) to get a barrier that never cycles.  You can also do things like supplying
-- (+2) as the incrementing function, or even using lists as the phase type to
-- do crazy things.
newPhasedBarrierCustomInc :: (phase -> phase) -> phase -> CHP (PhasedBarrier phase)
newPhasedBarrierCustomInc f ph = liftPoison $ liftTrace $ do
  e <- liftIO $ newEvent BarrierSync 0
  tv <- liftIO $ atomically $ newTVar ph
  return $ Barrier (e, tv, f)


-- | Creates a new barrier with no processes enrolled and labels it in traces
-- using the given label.  See 'newBarrier'.
newBarrierWithLabel :: String -> CHP Barrier
newBarrierWithLabel l = newPhasedBarrierWithLabel l ()

-- | Creates a new barrier with no processes enrolled and labels it in traces
-- using the given label.  See 'newPhasedBarrier'.
newPhasedBarrierWithLabel :: (Enum phase, Bounded phase, Eq phase) => String -> phase -> CHP (PhasedBarrier phase)
newPhasedBarrierWithLabel l ph = liftPoison $ liftTrace $ do
  e <- liftIO $ newEvent BarrierSync 0
  labelEvent e l
  tv <- liftIO $ atomically $ newTVar ph
  return $ Barrier (e, tv, \p -> if p == maxBound then minBound else succ p)

-- | Creates a new barrier with no processes enrolled and labels it in traces
-- using the given label.  See 'newPhasedBarrierCustomInc'.
newPhasedBarrierWithLabelCustomInc :: String -> (phase -> phase) -> phase -> CHP (PhasedBarrier phase)
newPhasedBarrierWithLabelCustomInc l f ph = liftPoison $ liftTrace $ do
  e <- liftIO $ newEvent BarrierSync 0
  labelEvent e l
  tv <- liftIO $ atomically $ newTVar ph
  return $ Barrier (e, tv, f)


-- | Gets the identifier of a Barrier.  Useful if you want to identify it in
-- the trace later on.
getBarrierIdentifier :: PhasedBarrier ph -> Unique
getBarrierIdentifier (Barrier (e, _, _)) = getEventUnique e