Alt.hs

-- 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 constructs for choice, or alting.  An ALT (a term inherited from
-- occam) is a choice between several alternate events.  Events that inherently support choice are:
--
-- * 'Control.Concurrent.CHP.Monad.skip'
--
-- * 'Control.Concurrent.CHP.Monad.stop'
-- 
-- * 'Control.Concurrent.CHP.Monad.waitFor'
-- 
-- * Reading from a channel (including extended reads): that is, calls to 'Control.Concurrent.CHP.Channels.Communication.readChannel'
-- and 'Control.Concurrent.CHP.Channels.Communication.extReadChannel'
-- 
-- * Writing to a channel (including extended writes): that is, calls to 'Control.Concurrent.CHP.Channels.Communication.writeChannel'
-- and 'Control.Concurrent.CHP.Channels.Communication.extWriteChannel'
-- 
-- * Synchronising on a barrier (using 'Control.Concurrent.CHP.Barriers.syncBarrier')
-- 
-- * An alting construct (that is, you can nest alts) such as 'alt', 'priAlt' (or
-- the operator versions)
-- 
-- * A sequential composition, if the first event supports alting (i.e. is in this
-- list)
--
-- * A call to 'every', which joins together several items (see the documentation
-- on 'every').
--
-- There are several other events that can occur in CHP; these are assumed to be
-- always-ready when they are included in a choice.  Examples include:
--
-- * Enrolling and resigning with a barrier
-- 
-- * Poisoning a channel
-- 
-- * Processes composed in parallel (using 'runParallel', etc)
-- 
-- * Any lifted IO event
--
-- * Creating channels, barriers, etc
--
-- * Claiming a shared channel (yet...)
--
-- * A return statement by itself
--
-- Here are some examples of using alting:
--
-- * Wait for an integer channel, or 1 second to elapse:
--
-- > liftM Just (readChannel c) <|> (waitFor 1000000 >> return Nothing)
--
-- * Check if a channel is ready, otherwise return immediately; this can be done
-- using the 'optional' function from "Control.Applicative":
-- 
-- > optional (readChannel c)
--
-- * Wait for input from one of two (identically typed) channels
-- 
-- > readChannel c0 <|> readChannel c1
--
-- * Check if a channel is ready; if so send, it on, otherwise return immediately:
-- 
-- > (readChannel c >>= writeChannel d) <|> skip
--
-- Note that if you wait for a sequential composition:
--
-- > (readChannel c >>= writeChannel d) <|> (writeChannel e 6 >> readChannel f)
--
-- This only waits for the first action in both (reading from channel c, or writing
-- to channel e), not for all of the actions (as, for example, an STM transaction
-- would).
module Control.Concurrent.CHP.Alt (alt, (<->), priAlt, (</>), every, every_, (<&>)) where

import Control.Applicative ((<$>), (<|>))
import Data.Monoid (mappend)

import Control.Concurrent.CHP.Base (CHP(..), CHP'(..), liftIO_CHP, makeAltable', priAlt, throwPoison, wrapPoison)
import Control.Concurrent.CHP.Guard (Guard(..))
import Control.Concurrent.CHP.Monad (skip)
import Control.Concurrent.CHP.Parallel (runParallel)
import Control.Concurrent.CHP.Poison (WithPoison(..))

-- | An alt between several actions, with arbitrary priority.  The first
-- available action is chosen (with an arbitrary choice if many actions are
-- available at the same time), its body run, and its value returned.
alt :: [CHP a] -> CHP a
alt = priAlt

-- | A useful operator to perform an 'alt'.  This operator is associative,
-- and has arbitrary priority.  When you have lots of guards, it is probably easier
-- to use the 'alt' function.  'alt' /may/ be more efficent than
-- foldl1 (\<-\>)
(<->) :: CHP a -> CHP a -> CHP a
(<->) a b = alt [a,b]
  
-- | A useful operator to perform a 'priAlt'.  This operator is
-- associative, and has descending priority (that is, it is
-- left-biased).  When you have lots of actions, it is probably easier
-- to use the 'priAlt' function.  'priAlt' /may/ be more efficent than
-- foldl1 (\<\/\>)
--
-- Since version 2.2.0, this operator is deprecated in favour of the (<|>) operator
-- from the Alternative type-class.
(</>) :: CHP a -> CHP a -> CHP a
(</>) = (<|>)

infixl </>
infixl <->
infixl <&>

-- | Runs all the given processes in parallel with each other, but only when the
-- choice at the beginning of each item is ready.
--
-- So for example, if you do:
--
-- > every [ readChannel c >>= writeChannel d, readChannel e >>= writeChannel f]
--
-- This will forward values from c and e to d and f respectively in parallel, but
-- only once both channels c and e are ready to be read from.  So f cannot be written
-- to before c is read from (contrast this with what would happen if 'every' were
-- replaced with 'runParallel').
--
-- This behaviour can be somewhat useful, but 'every' is much more powerful when
-- used as part of an 'alt'.  This code:
--
-- > alt [ every [ readChannel c, readChannel d]
-- >     , every [ writeChannel e 6, writeChannel f 8] ]
--
-- Waits to either read from channels c and d, or to write to channels e and f.
--
-- The events involved can partially overlap, e.g.
--
-- > alt [ every [ readChannel a, readChannel b]
-- >     , every [ readChannel a, writeChannel c 6] ]
-- 
-- This will wait to either read from channels a and b, or to read from a and write
-- to c, whichever combination is ready first.  If both are ready, the choice between
-- them will be arbitrary (just as with any other choices; see 'alt' for more details).
--
-- The sets can even be subsets of each other, such as:
--
-- > alt [ every [ readChannel a, readChannel b]
-- >     , every [ readChannel a, readChannel b, readChannel b] ]
--
-- In this case there are no guarantees as to which choice will happen.  Do not
-- assume it will be the smaller, and do not assume it will be the larger.  
--
-- Be wary of what happens if a single event is included multiple times in the same 'every', as
-- this may not do what you expect (with or without choice).  Consider:
-- 
-- > every [ readChannel c >> writeChannel d 6
-- >       , readChannel c >> writeChannel d 8 ]
--
-- What will happen is that the excecution will wait to read from c, but then it
-- will execute only one of the bodies (an arbitrary choice).  In general, do not
-- rely on this behaviour, and instead try to avoid having the same events in an
-- 'every'.  Also note that if you synchronise on a barrier twice in an 'every',
-- this will only count as one member enrolling, even if you have two enrolled
-- ends!  For such a use, look at 'runParallel' instead.
--
-- Also note that this currently applies to both ends of channels, so that:
--
-- > every [ readChannel c, writeChannel c 2 ]
--
-- Will block indefinitely, rather than completing the communication.
--
-- Each item 'every' must support choice (and in fact
-- only a subset of the items supported by 'alt' are supported by 'every').  Currently the items
-- in the list passed to 'every' must be one of the following:
--
-- * A call to 'Control.Concurrent.CHP.Channels.readChannel' (or 'Control.Concurrent.CHP.Channels.extReadChannel').
-- 
-- * A call to 'Control.Concurrent.CHP.Channels.writeChannel' (or 'Control.Concurrent.CHP.Channels.extWriteChannel').
--
-- * 'Control.Concurrent.CHP.Monad.skip', the always-ready guard.
--
-- * 'Control.Concurrent.CHP.Monad.stop', the never-ready guard (will cause the whole 'every' to never be ready,
-- since 'every' has to wait for all guards).
--
-- * A call to 'Control.Concurrent.CHP.Monad.syncBarrier'.
--
-- * A sequential composition where the first item is one of the things in this
-- list.
--
-- * A call to 'every' (you can nest 'every' blocks inside each other).
--
-- Timeouts (e.g. 'Control.Concurrent.CHP.Monad.waitFor') are currently not supported.  You can always get another
-- process to synchronise on an event with you once a certain time has passed.
--
-- Note also that you cannot put an 'alt' inside an 'every'.  So you cannot say:
--
-- > every [ readChannel c
-- >       , alt [ readChannel d, readChannel e ] ]
--
-- To wait for c and (d or e) like this you must expand it out into (c and d) or
-- (c and e):
--
-- > alt [ every [ readChannel c, readChannel d]
-- >     , every [ readChannel c, readChannel e] ]
--
-- As long as x meets the conditions laid out above, 'every' [x] will have the same
-- behaviour as x.
--
-- Added in version 1.1.0
every :: [CHP a] -> CHP [a]
every [] = skip >> return []
every xs = makeAltable' (\tr -> let gs = map fst $ getAltable tr
  in [(foldl1 merge gs, return $ NoPoison ())]) >> wrapped
  where
    wrapped = PoisonT $ \t f -> let bodies = map snd $ getAltable t
      in wrapPoison t (runParallel (map wrap bodies)) >>= f

    wrap m = liftIO_CHP m >>= \v -> case v of
      PoisonItem -> throwPoison
      NoPoison x -> return x

    getAltable tr = flip map xs $ \x -> case runPoisonT x tr return of
      Altable _ [ga] -> ga
      _ -> error "Bad item in every"

    merge :: Guard -> Guard -> Guard
    merge SkipGuard g = g
    merge g SkipGuard = g
    merge StopGuard _ = StopGuard
    merge _ StopGuard = StopGuard
    merge (EventGuard recx actx esx) (EventGuard recy acty esy)
      = EventGuard (\n -> recx n ++ recy n) (actx `mappend` acty) (esx ++ esy)
    merge _ _ = error "every: merging unsupported guards"


-- | Like 'every' but discards the results.
--
-- Added in version 1.8.0.
every_ :: [CHP a] -> CHP ()
every_ ps = every ps >> return ()

-- | A useful operator that acts like 'every'.  The operator is associative and
-- commutative (see 'every' for notes on idempotence).  When you have lots of things
-- to join with this operator, it's probably easier to use the 'every' function.
--
-- Added in version 1.1.0
(<&>) :: CHP a -> CHP b -> CHP (a, b)
(<&>) a b = merge <$> every [Left <$> a, Right <$> b]
  where
    merge :: [Either a b] -> (a, b)
    merge [Left x, Right y] = (x, y)
    merge [Right y, Left x] = (x, y)
    merge _ = error "Invalid merge possibility in <&>"