Event.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.

--TODO document this (for internal purposes)
module Control.Concurrent.CHP.Event where

import Control.Concurrent.STM
import Control.Monad
import Data.List
import Data.Maybe
import Data.Unique

import Control.Concurrent.CHP.Poison
import Control.Concurrent.CHP.ProcessId

-- Not really a CSP event, more like an enrollable poisonable alting barrier!
newtype Event = Event (
  Unique, -- Event identifier
  TVar (WithPoison
    (Int, -- Enrolled count
    [OfferSet]) -- A list of offer sets
 ))

type OfferSet = (TVar (Maybe [Int]) -- Variable to use to signal when committed
                , [Int] -- Value to send when committed
                , ProcessId -- Id of the process making the offer
                , [Event]) -- A list of all events currently offered

newEvent :: Int -> IO Event
newEvent n
  = do u <- newUnique
       atomically $ do tv <- newTVar (NoPoison (n, []))
                       return $ Event (u, tv)

enrollEvent :: Event -> STM (WithPoison ())
enrollEvent (Event (_, tv))
  = do x <- readTVar tv
       case x of
         PoisonItem -> return PoisonItem
         NoPoison (count, offers) ->
           do writeTVar tv $ NoPoison (count + 1, offers)
              return $ NoPoison ()

resignEvent :: Event -> STM (WithPoison ())
resignEvent (Event (_, tv))
  = do x <- readTVar tv
       case x of
         PoisonItem -> return PoisonItem
         NoPoison (count, offers) ->
           do writeTVar tv $ NoPoison (count - 1, offers)
              if (count - 1 == length offers)
                then completeEvent False tv
                else return $ NoPoison ()

retractOffers :: [(TVar (Maybe [Int]), [Event])] -> STM ()
retractOffers = mapM_ retractAll
  where
    retractAll :: (TVar (Maybe [Int]), [Event]) -> STM ()
    retractAll (tvid, evts) = mapM_ retract evts
      where
        retract :: Event -> STM ()
        retract (Event (_,tv))
          = do x <- readTVar tv
               case x of
                 PoisonItem -> return ()
                 NoPoison (enrolled, offers) ->
                   let reducedOffers = filter (\(tvx,_,_,_) -> tvx /= tvid) offers in
                   writeTVar tv $ NoPoison (enrolled, reducedOffers)

-- Takes True to poison the event, False to complete normally
completeEvent :: Bool -> TVar (WithPoison (Int, [OfferSet])) -> STM (WithPoison ())
completeEvent addPoison tv
  = do x <- readTVar tv
       case (x, addPoison) of
         (PoisonItem, _) -> return PoisonItem
         (NoPoison (_, offers), False) ->
           do retractOffers $ [(tvw, events) | (tvw,_,_,events) <- offers]
              sequence_ [writeTVar tvw (Just wx) | (tvw, wx, _,_) <- offers]
              return $ NoPoison ()
         (NoPoison (_, offers), True) ->
           do retractOffers $ [(tvw, events) | (tvw,_,_,events) <- offers]
              sequence_ [writeTVar tvw (Just $ wx ++ [0]) | (tvw, wx, _, _) <- offers]
              writeTVar tv PoisonItem
              return PoisonItem
      
-- Passed: True if allowed to commit to waiting
-- Returns: True if committed, False otherwise
enableEvents :: forall a. TVar (Maybe [Int]) -> ProcessId -> [(a, [Int], STM
  (), Event)] -> Bool -> STM (Maybe (a, [ProcessId], [Int]))
enableEvents tvNotify pid events canCommitToWait
  = do x <- checkAll
       case (x, canCommitToWait) of
         (Just (labels, pids, ns, act, Event (_,tv)), _) ->
            act >> completeEvent False tv >>= \b ->
              return $ Just (labels, pids, case b of {PoisonItem -> ns ++ [0]; _ -> ns})
         (Nothing, False) -> return Nothing
         (Nothing, True) ->
           do sequence_ [do NoPoison (count, otherOffers) <- readTVar ab
                            writeTVar ab $ NoPoison (count,(tvNotify, ns, pid,
                              map fourth events):otherOffers)
                        | (_, ns, _, Event (_,ab)) <- events]
              return Nothing
  where
    fourth (_,_,_,c) = c
    
    checkAll :: STM (Maybe (a, [ProcessId], [Int], STM (), Event))
    checkAll = do xs <- sequence [do x <- readTVar tv
                                     return (x, evt)
                                 | evt@(_,_,_,Event (_,tv)) <- events]
                  return $ fmap get $ find (ready . fst) xs

      where
        get :: (WithPoison (Int, [OfferSet]), (a, [Int], STM (), Event))
          -> (a, [ProcessId], [Int], STM (), Event)
        get (PoisonItem,(l,ns,act,e)) = (l,[pid],ns,act,e)
        get (NoPoison (_,offers),(l,ns,act,e)) = (l,pid : [p | (_,_,p,_) <- offers],ns,act,e)

    -- Sees if the barrier is ready *if* we commit to it too
    ready :: WithPoison (Int, [OfferSet]) -> Bool
    ready PoisonItem = True
    ready (NoPoison (count, offers)) = count == 1 + length offers

disableEvents :: TVar (Maybe [Int]) -> [Event] -> STM (Maybe [Int])
disableEvents tv events
  = do x <- readTVar tv
       -- Since the transaction will be atomic, we know
       -- now that we can disable the barriers and nothing fired:
       when (isNothing x) $ retractOffers [(tv, events)]
       return x

checkEventForPoison :: Event -> STM (WithPoison ())
checkEventForPoison (Event (_, tv))
  = do x <- readTVar tv
       case x of
         PoisonItem -> return PoisonItem
         _ -> return (NoPoison ())

poisonEvent :: Event -> STM ()
poisonEvent (Event (_,tv)) = completeEvent True tv >> return ()

--TODO document how if it's poisoned, 0 will be appended to the list