{- Here we create a simple guarded queue which allows guarding by equality
   according to an ordered key.  Thus guards have three values,
   match anything, match nothing, and match this value.  

   To simplify the implementation, we specify that an Eq match has higher
   priority than a MatchAnything match, and when we must choose between
   values for MatchAnything, do not necessarily choose the first
   (more likely the one with the lowest key value).  But we do respect
   FIFO order when only Eq guards are involved.
   -}
module EqGuard(
   EqGuardedChannel, -- the channel
   EqMatch(..), -- the guard.
   newEqGuardedChannel, -- construct a channel
   ) where

import Computation

import GuardedEvents
import GuardedChannels
import DeleteQueue
import FMQueue

type EqGuardedChannel key value = GuardedChannel (EqMatch key) (key,value)

newEqGuardedChannel :: Ord key => IO (EqGuardedChannel key value)
newEqGuardedChannel = 
   newEqGuardedChannelPrim (error "EqGuard.1") (error "EqGuard.2")

newEqGuardedChannelPrim :: Ord key => key -> value 
   -> IO (EqGuardedChannel key value)
-- The arguments to newEqGuardedChannelPrim are not looked at, but
-- help us to avoid overloading woes.
newEqGuardedChannelPrim (_::key) (_ ::value) =
   newGuardedChannel (error "newEq1" :: (GQ (EqGuardQueue key) (key,value)))
      (error "newEq2" :: (VQ (EqValueQueue key value)))

-- --------------------------------------------------------------------
-- The Guard type
-- --------------------------------------------------------------------

data EqMatch key = 
      Eq !key
   |  EqMatchAny
   |  EqMatchNone

instance Ord key => Guard (EqMatch key) where
   nullGuard = EqMatchAny

   andGuard EqMatchAny x = x
   andGuard EqMatchNone x = EqMatchNone
   andGuard x EqMatchAny = x
   andGuard x EqMatchNone = EqMatchNone
   andGuard (Eq key1) (Eq key2) =
      if key1 == key2 then Eq key1 else EqMatchNone

-- --------------------------------------------------------------------
-- The value queue.
-- --------------------------------------------------------------------

newtype Ord key => EqValueQueue key value valueCont = 
   EqValueQueue (FMQueue key ((key,value),valueCont))

instance Ord key => HasEmpty (EqValueQueue key value) where
   newEmpty = return (EqValueQueue emptyFMQueue)

instance Ord key => HasAdd (EqValueQueue key value) (key,value) where
   add (EqValueQueue fmQueue) keyValue@(key,value) valueCont =
      do
         (fmQueue2,invalidate) <- addFMQueue fmQueue key (keyValue,valueCont)
         return (EqValueQueue fmQueue2,invalidate)

instance Ord key => HasRemove (EqValueQueue key value) (EqMatch key) 
      (key,value) where
   remove (EqValueQueue fmQueue) EqMatchAny =
      do
         (removed,fmQueue0) <- removeFMQueueAny fmQueue
         case removed of
            Nothing -> return (Nothing,EqValueQueue fmQueue0)
            (Just (_,(keyValue,valueCont),fmQueue2)) -> 
               return (Just(keyValue,valueCont,
                     return (EqValueQueue fmQueue0)),
                  EqValueQueue fmQueue2)
   remove (EqValueQueue fmQueue) (Eq key) =
      do
         (removed,fmQueue0) <- removeFMQueue fmQueue key 
         case removed of
            Nothing -> return (Nothing,EqValueQueue fmQueue0)
            (Just ((keyValue,valueCont),fmQueue2)) ->
               return (Just(keyValue,valueCont,
                     return (EqValueQueue fmQueue0)),
                  EqValueQueue fmQueue2)

-- --------------------------------------------------------------------
-- The Guard Queue
-- --------------------------------------------------------------------

data Ord key => EqGuardQueue key guardCont =
   EqGuardQueue {
      matchAnys :: DeleteQueue guardCont,
      eqs :: FMQueue key guardCont
      }

instance Ord key => HasEmpty (EqGuardQueue key) where
   newEmpty = return (EqGuardQueue {
      matchAnys = emptyQueue,
      eqs = emptyFMQueue
      })

instance Ord key => HasAdd (EqGuardQueue key) (EqMatch key) where
   add guardQueue guard guardCont =
      case guard of
         Eq key -> 
            do
               let fmQueue = eqs guardQueue
               (fmQueue2,invalidate) <- addFMQueue fmQueue key guardCont
               return (guardQueue {eqs = fmQueue2},invalidate)
         EqMatchAny ->
            do
               let deleteQueue = matchAnys guardQueue
               (deleteQueue2,invalidate) <- addQueue deleteQueue guardCont
               deleteQueue3 <- cleanQueue deleteQueue2
               return (guardQueue {matchAnys = deleteQueue2},invalidate)
         EqMatchNone -> return (guardQueue,done)
 
instance Ord key => HasRemove (EqGuardQueue key) (key,value) (EqMatch key) where
   remove guardQueue (key,_) =
      do
         removed <- removeFMQueue (eqs guardQueue) key 
         case removed of
            (Just (guardCont,fmQueue2),fmQueue0) ->
               do
                  let gq fmq = guardQueue {eqs = fmq}
                  return (Just(Eq key,guardCont,return(gq fmQueue0)),
                     gq fmQueue2)
            (Nothing,fmQueue0) ->
               do
                  let
                     mAs = matchAnys guardQueue
                     gq dq = EqGuardQueue {matchAnys = dq,eqs = fmQueue0} 
                  removed2 <- removeQueue mAs
                  case removed2 of
                     Just (guardCont,dqueue2,dqueue0) ->
                        return (Just (EqMatchAny,guardCont,
                              return (gq dqueue0)),
                           gq dqueue2)
                     Nothing ->
                        return (Nothing,gq mAs)