-- Communicating Haskell Processes.
-- Copyright (c) 2009, 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 CHP behaviours.  See 'offer' for details.
--
-- This whole module was added in CHP 1.6.0.
module Control.Concurrent.CHP.Behaviours (
  CHPBehaviour, offer, offerAll, alongside, alongside_, endWhen, once, repeatedly, repeatedly_,
  repeatedlyRecurse, repeatedlyRecurse_) where

import Control.Applicative
import Control.Monad

import Control.Concurrent.CHP

-- | This data represents a behaviour (potentially repeated) that will result in
-- returning a value of type @a@.  See 'offer' for more details.
data CHPBehaviour a = CHPBehaviour a (Maybe (CHP (CHPBehaviour a)))

instance Functor CHPBehaviour where
  fmap f (CHPBehaviour x Nothing) = CHPBehaviour (f x) Nothing
  fmap f (CHPBehaviour x (Just m)) = CHPBehaviour (f x) (Just $ fmap f <$> m)

-- | Offers the given behaviour, and when it occurs, ends the entire call to 'offer'.
--  Returns Just the result if the behaviour happens, otherwise gives Nothing.
endWhen :: CHP a -> CHPBehaviour (Maybe a)
endWhen m = CHPBehaviour Nothing (Just $ (\x -> CHPBehaviour (Just x) Nothing) <$> m)

-- | Offers the given behaviour, and when it occurs, does not offer it again.
-- Returns Just the result if the behaviour happens, otherwise gives Nothing.
-- 'once' is different to 'endWhen' because the latter terminates the call to 'offer'
-- regardless of other behaviours, whereas 'once' does not terminate the call to 'offer',
-- it just won't be offered again during the call to 'offer'.  Thus if you only
-- offer some 'once' items without any 'endWhen', then after all the 'once' events
-- have happened, the process will deadlock.
once :: CHP a -> CHPBehaviour (Maybe a)
once m = CHPBehaviour Nothing (Just $ (\x -> CHPBehaviour (Just x) (Just stop)) <$> m)

-- | Repeatedly offers the given behaviour until the outer call to 'offer' is terminated
-- by an 'endWhen' event.  A list is returned (in chronological order) of the results
-- of each occurrence of the behaviour.
repeatedly :: forall a. CHP a -> CHPBehaviour [a]
repeatedly m = reverse <$> repeatedly' []
  where
    repeatedly' :: [a] -> CHPBehaviour [a]
    repeatedly' xs = CHPBehaviour xs $ Just $ 
      (\x -> repeatedly' (x:xs)) <$> m

-- | Like 'repeatedly', but discards the output.  Useful if the event is likely
-- to occur a lot, and you don't need the results.
repeatedly_ :: CHP a -> CHPBehaviour ()
repeatedly_ m = CHPBehaviour () $ Just $ m >> return (repeatedly_ m)

-- | Like 'repeatedly', but allows some state (of type @a@) to be passed from one
-- subsequent call to another, as well as generating the results of type @b@.
-- To begin with the function (first parameter) will be called with the initial
-- state (second parameter).  If chosen, it will return the new state, and a result
-- to be accumulated into the list.  The second call to the function will be passed
-- the new state, to then return the even newer state and a second result, and
-- so on.
--
-- If you want to use this with the StateT monad transformer from the mtl library,
-- you can call:
--
-- > repeatedlyRecurse (runStateT myStateAction) initialState
-- >   where
-- >     myStateAction :: StateT s CHP a
-- >     initialState :: s
repeatedlyRecurse :: forall a b. (a -> CHP (b, a)) -> a -> CHPBehaviour [b]
repeatedlyRecurse f = fmap reverse . repeatedlyRecurse' []
  where
    repeatedlyRecurse' :: [b] -> a -> CHPBehaviour [b]
    repeatedlyRecurse' rs x = CHPBehaviour rs $ Just $
      (\(r, y) -> repeatedlyRecurse' (r : rs) y) <$> f x

-- | Like 'repeatedlyRecurse', but does not accumulate a list of results.
--
-- If you want to use this with the StateT monad transformer from the mtl library,
-- you can call:
--
-- > repeatedlyRecurse (execStateT myStateAction) initialState
-- >   where
-- >     myStateAction :: StateT s CHP a
-- >     initialState :: s
repeatedlyRecurse_ :: forall a. (a -> CHP a) -> a -> CHPBehaviour ()
repeatedlyRecurse_ f = repeatedlyRecurse'
  where
    repeatedlyRecurse' :: a -> CHPBehaviour ()
    repeatedlyRecurse' x = CHPBehaviour () $ Just $ repeatedlyRecurse' <$> f x

-- | Offers one behaviour alongside another, combining their semantics.  See 'offer'.
--
-- This operation is semantically associative and commutative.
alongside :: CHPBehaviour a -> CHPBehaviour b -> CHPBehaviour (a, b)
alongside oa@(CHPBehaviour a mfa) ob@(CHPBehaviour b mfb)
  = CHPBehaviour (a, b) (do fa <- mfa
                            fb <- mfb
                            return $ (flip alongside ob <$> fa) <-> (alongside oa <$> fb)
                        )

-- | Offers one behaviour alongside another, combining their semantics.  See 'offer'.
-- Unlike 'alongside', discards the output of the behaviours.
--
-- This operation is associative and commutative.
alongside_ :: CHPBehaviour a -> CHPBehaviour b -> CHPBehaviour ()
alongside_ (CHPBehaviour _ mfa) (CHPBehaviour _ mfb)
  = CHPBehaviour () (liftM2 (<->) (liftM blank <$> mfa) (liftM blank <$> mfb))
  where
    blank :: CHPBehaviour c -> CHPBehaviour ()
    blank = fmap (const ())

infixr `alongside`

-- | Offers the given behaviour until finished.
--
-- For example,
-- 
-- > offer $ repeatedly p `alongside` repeatedly q
-- 
-- will repeatedly offer p and q without ever terminating.  This:
-- 
-- > offer $ repeatedly p `alongside` repeatedly q `alongside` endWhen r
-- 
-- will offer p repeatedly and q repeatedly and r, until r happens, at which point
-- the behaviour will end.
-- This:
-- 
-- > offer $ once p `alongside` endWhen q
-- 
-- will offer p and q; if p happens first it will wait for q, but if q happens
-- first it will finish.  This:
-- 
-- > offer $ once p `alongside` endWhen q `alongside` endWhen r
-- 
-- permits p to happen at most once, while either of q or r happening will finish
-- the call.
--
-- All sorts of combinations are possible, but it is important to note that you
-- need at least one 'endWhen' event if you ever intend the call to finish.  Some
-- laws involving 'offer' (ignoring the types and return values) are:
--
-- > offer (repeatedly p) == forever p
-- > offer (once p) == p >> stop -- i.e. it does not finish
-- > offer (endWhen q) == Just <$> q
-- > offer (endWhen p `alongside` endWhen q) == p <-> q
-- > offer (once p `alongside` endWhen q) == (p >> q) <-> q
--
-- Most other uses of 'offer' and 'alongside' do not reduce down to simple CHP
-- programs, which is of course their attraction.
offer :: CHPBehaviour a -> CHP a
offer (CHPBehaviour x Nothing) = return x
offer (CHPBehaviour _x (Just m)) = m >>= offer

-- | Offers all the given behaviours together, and gives back a list of the outcomes.
--  
-- This is roughly a shorthand for @offer . foldl1 alongside@, except that if you
-- pass the empty list, you simply get the empty list returned (rather than an
-- error)
offerAll :: [CHPBehaviour a] -> CHP [a]
offerAll [] = return []
offerAll bs = offer $ foldl1 (\x y -> fmap (uncurry (++)) $ alongside x y) bs'
  where
    bs' = map (fmap (:[])) bs