{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- | 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 Events.EqGuard(
   EqGuardedChannel, -- the channel
   EqMatch(..), -- the guard.
   newEqGuardedChannel, -- construct a channel
   ) where

import Util.Computation

import Events.GuardedEvents
import Events.GuardedChannels
import Events.DeleteQueue
import Events.FMQueue

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

newEqGuardedChannel :: Ord key => IO (EqGuardedChannel key value)
newEqGuardedChannel :: IO (EqGuardedChannel key value)
newEqGuardedChannel =
   key -> value -> IO (EqGuardedChannel key value)
forall key value.
Ord key =>
key -> value -> IO (EqGuardedChannel key value)
newEqGuardedChannelPrim ([Char] -> key
forall a. HasCallStack => [Char] -> a
error [Char]
"EqGuard.1") ([Char] -> value
forall a. HasCallStack => [Char] -> a
error [Char]
"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 -> IO (EqGuardedChannel key value)
newEqGuardedChannelPrim (key
_::key) (value
_ ::value) =
   GQ (EqGuardQueue key) (key, value)
-> VQ (EqValueQueue key value) -> IO (EqGuardedChannel key value)
forall (guardQueue :: * -> *) (valueQueue :: * -> *) guard value.
HasGuardedChannel guardQueue valueQueue guard value =>
GQ guardQueue value
-> VQ valueQueue -> IO (GuardedChannel guard value)
newGuardedChannel ([Char] -> GQ (EqGuardQueue key) (key, value)
forall a. HasCallStack => [Char] -> a
error [Char]
"newEq1" :: (GQ (EqGuardQueue key) (key,value)))
      ([Char] -> VQ (EqValueQueue key value)
forall a. HasCallStack => [Char] -> a
error [Char]
"newEq2" :: (VQ (EqValueQueue key value)))

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

data EqMatch key =
      Eq !key
   |  EqMatchAny
   |  EqMatchNone

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

   andGuard :: EqMatch key -> EqMatch key -> EqMatch key
andGuard EqMatch key
EqMatchAny EqMatch key
x = EqMatch key
x
   andGuard EqMatch key
EqMatchNone EqMatch key
x = EqMatch key
forall key. EqMatch key
EqMatchNone
   andGuard EqMatch key
x EqMatch key
EqMatchAny = EqMatch key
x
   andGuard EqMatch key
x EqMatch key
EqMatchNone = EqMatch key
forall key. EqMatch key
EqMatchNone
   andGuard (Eq key
key1) (Eq key
key2) =
      if key
key1 key -> key -> Bool
forall a. Eq a => a -> a -> Bool
== key
key2 then key -> EqMatch key
forall key. key -> EqMatch key
Eq key
key1 else EqMatch key
forall key. EqMatch key
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 :: IO (EqValueQueue key value xData)
newEmpty = EqValueQueue key value xData -> IO (EqValueQueue key value xData)
forall (m :: * -> *) a. Monad m => a -> m a
return (FMQueue key ((key, value), xData) -> EqValueQueue key value xData
forall key value valueCont.
FMQueue key ((key, value), valueCont)
-> EqValueQueue key value valueCont
EqValueQueue FMQueue key ((key, value), xData)
forall key contents. Ord key => FMQueue key contents
emptyFMQueue)

instance Ord key => HasAdd (EqValueQueue key value) (key,value) where
   add :: EqValueQueue key value xData
-> (key, value)
-> xData
-> IO (EqValueQueue key value xData, IO ())
add (EqValueQueue FMQueue key ((key, value), xData)
fmQueue) keyValue :: (key, value)
keyValue@(key
key,value
value) xData
valueCont =
      do
         (FMQueue key ((key, value), xData)
fmQueue2,IO ()
invalidate) <- FMQueue key ((key, value), xData)
-> key
-> ((key, value), xData)
-> IO (FMQueue key ((key, value), xData), IO ())
forall key contents.
Ord key =>
FMQueue key contents
-> key -> contents -> IO (FMQueue key contents, IO ())
addFMQueue FMQueue key ((key, value), xData)
fmQueue key
key ((key, value)
keyValue,xData
valueCont)
         (EqValueQueue key value xData, IO ())
-> IO (EqValueQueue key value xData, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (FMQueue key ((key, value), xData) -> EqValueQueue key value xData
forall key value valueCont.
FMQueue key ((key, value), valueCont)
-> EqValueQueue key value valueCont
EqValueQueue FMQueue key ((key, value), xData)
fmQueue2,IO ()
invalidate)

instance Ord key => HasRemove (EqValueQueue key value) (EqMatch key)
      (key,value) where
   remove :: EqValueQueue key value yData
-> EqMatch key
-> IO
     (Maybe ((key, value), yData, IO (EqValueQueue key value yData)),
      EqValueQueue key value yData)
remove (EqValueQueue FMQueue key ((key, value), yData)
fmQueue) EqMatch key
EqMatchAny =
      do
         (Maybe
  (key, ((key, value), yData), FMQueue key ((key, value), yData))
removed,FMQueue key ((key, value), yData)
fmQueue0) <- FMQueue key ((key, value), yData)
-> IO
     (Maybe
        (key, ((key, value), yData), FMQueue key ((key, value), yData)),
      FMQueue key ((key, value), yData))
forall key contents.
Ord key =>
FMQueue key contents
-> IO
     (Maybe (key, contents, FMQueue key contents), FMQueue key contents)
removeFMQueueAny FMQueue key ((key, value), yData)
fmQueue
         case Maybe
  (key, ((key, value), yData), FMQueue key ((key, value), yData))
removed of
            Maybe
  (key, ((key, value), yData), FMQueue key ((key, value), yData))
Nothing -> (Maybe ((key, value), yData, IO (EqValueQueue key value yData)),
 EqValueQueue key value yData)
-> IO
     (Maybe ((key, value), yData, IO (EqValueQueue key value yData)),
      EqValueQueue key value yData)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ((key, value), yData, IO (EqValueQueue key value yData))
forall a. Maybe a
Nothing,FMQueue key ((key, value), yData) -> EqValueQueue key value yData
forall key value valueCont.
FMQueue key ((key, value), valueCont)
-> EqValueQueue key value valueCont
EqValueQueue FMQueue key ((key, value), yData)
fmQueue0)
            (Just (key
_,((key, value)
keyValue,yData
valueCont),FMQueue key ((key, value), yData)
fmQueue2)) ->
               (Maybe ((key, value), yData, IO (EqValueQueue key value yData)),
 EqValueQueue key value yData)
-> IO
     (Maybe ((key, value), yData, IO (EqValueQueue key value yData)),
      EqValueQueue key value yData)
forall (m :: * -> *) a. Monad m => a -> m a
return (((key, value), yData, IO (EqValueQueue key value yData))
-> Maybe ((key, value), yData, IO (EqValueQueue key value yData))
forall a. a -> Maybe a
Just((key, value)
keyValue,yData
valueCont,
                     EqValueQueue key value yData -> IO (EqValueQueue key value yData)
forall (m :: * -> *) a. Monad m => a -> m a
return (FMQueue key ((key, value), yData) -> EqValueQueue key value yData
forall key value valueCont.
FMQueue key ((key, value), valueCont)
-> EqValueQueue key value valueCont
EqValueQueue FMQueue key ((key, value), yData)
fmQueue0)),
                  FMQueue key ((key, value), yData) -> EqValueQueue key value yData
forall key value valueCont.
FMQueue key ((key, value), valueCont)
-> EqValueQueue key value valueCont
EqValueQueue FMQueue key ((key, value), yData)
fmQueue2)
   remove (EqValueQueue FMQueue key ((key, value), yData)
fmQueue) (Eq key
key) =
      do
         (Maybe (((key, value), yData), FMQueue key ((key, value), yData))
removed,FMQueue key ((key, value), yData)
fmQueue0) <- FMQueue key ((key, value), yData)
-> key
-> IO
     (Maybe (((key, value), yData), FMQueue key ((key, value), yData)),
      FMQueue key ((key, value), yData))
forall key contents.
Ord key =>
FMQueue key contents
-> key
-> IO
     (Maybe (contents, FMQueue key contents), FMQueue key contents)
removeFMQueue FMQueue key ((key, value), yData)
fmQueue key
key
         case Maybe (((key, value), yData), FMQueue key ((key, value), yData))
removed of
            Maybe (((key, value), yData), FMQueue key ((key, value), yData))
Nothing -> (Maybe ((key, value), yData, IO (EqValueQueue key value yData)),
 EqValueQueue key value yData)
-> IO
     (Maybe ((key, value), yData, IO (EqValueQueue key value yData)),
      EqValueQueue key value yData)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ((key, value), yData, IO (EqValueQueue key value yData))
forall a. Maybe a
Nothing,FMQueue key ((key, value), yData) -> EqValueQueue key value yData
forall key value valueCont.
FMQueue key ((key, value), valueCont)
-> EqValueQueue key value valueCont
EqValueQueue FMQueue key ((key, value), yData)
fmQueue0)
            (Just (((key, value)
keyValue,yData
valueCont),FMQueue key ((key, value), yData)
fmQueue2)) ->
               (Maybe ((key, value), yData, IO (EqValueQueue key value yData)),
 EqValueQueue key value yData)
-> IO
     (Maybe ((key, value), yData, IO (EqValueQueue key value yData)),
      EqValueQueue key value yData)
forall (m :: * -> *) a. Monad m => a -> m a
return (((key, value), yData, IO (EqValueQueue key value yData))
-> Maybe ((key, value), yData, IO (EqValueQueue key value yData))
forall a. a -> Maybe a
Just((key, value)
keyValue,yData
valueCont,
                     EqValueQueue key value yData -> IO (EqValueQueue key value yData)
forall (m :: * -> *) a. Monad m => a -> m a
return (FMQueue key ((key, value), yData) -> EqValueQueue key value yData
forall key value valueCont.
FMQueue key ((key, value), valueCont)
-> EqValueQueue key value valueCont
EqValueQueue FMQueue key ((key, value), yData)
fmQueue0)),
                  FMQueue key ((key, value), yData) -> EqValueQueue key value yData
forall key value valueCont.
FMQueue key ((key, value), valueCont)
-> EqValueQueue key value valueCont
EqValueQueue FMQueue key ((key, value), yData)
fmQueue2)

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

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

instance Ord key => HasEmpty (EqGuardQueue key) where
   newEmpty :: IO (EqGuardQueue key xData)
newEmpty = EqGuardQueue key xData -> IO (EqGuardQueue key xData)
forall (m :: * -> *) a. Monad m => a -> m a
return (EqGuardQueue :: forall key guardCont.
DeleteQueue guardCont
-> FMQueue key guardCont -> EqGuardQueue key guardCont
EqGuardQueue {
      matchAnys :: DeleteQueue xData
matchAnys = DeleteQueue xData
forall v. DeleteQueue v
emptyQueue,
      eqs :: FMQueue key xData
eqs = FMQueue key xData
forall key contents. Ord key => FMQueue key contents
emptyFMQueue
      })

instance Ord key => HasAdd (EqGuardQueue key) (EqMatch key) where
   add :: EqGuardQueue key xData
-> EqMatch key -> xData -> IO (EqGuardQueue key xData, IO ())
add EqGuardQueue key xData
guardQueue EqMatch key
guard xData
guardCont =
      case EqMatch key
guard of
         Eq key
key ->
            do
               let fmQueue :: FMQueue key xData
fmQueue = EqGuardQueue key xData -> FMQueue key xData
forall key guardCont.
Ord key =>
EqGuardQueue key guardCont -> FMQueue key guardCont
eqs EqGuardQueue key xData
guardQueue
               (FMQueue key xData
fmQueue2,IO ()
invalidate) <- FMQueue key xData -> key -> xData -> IO (FMQueue key xData, IO ())
forall key contents.
Ord key =>
FMQueue key contents
-> key -> contents -> IO (FMQueue key contents, IO ())
addFMQueue FMQueue key xData
fmQueue key
key xData
guardCont
               (EqGuardQueue key xData, IO ())
-> IO (EqGuardQueue key xData, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (EqGuardQueue key xData
guardQueue {eqs :: FMQueue key xData
eqs = FMQueue key xData
fmQueue2},IO ()
invalidate)
         EqMatch key
EqMatchAny ->
            do
               let deleteQueue :: DeleteQueue xData
deleteQueue = EqGuardQueue key xData -> DeleteQueue xData
forall key guardCont.
Ord key =>
EqGuardQueue key guardCont -> DeleteQueue guardCont
matchAnys EqGuardQueue key xData
guardQueue
               (DeleteQueue xData
deleteQueue2,IO ()
invalidate) <- DeleteQueue xData -> xData -> IO (DeleteQueue xData, IO ())
forall v. DeleteQueue v -> v -> IO (DeleteQueue v, IO ())
addQueue DeleteQueue xData
deleteQueue xData
guardCont
               DeleteQueue xData
deleteQueue3 <- DeleteQueue xData -> IO (DeleteQueue xData)
forall v. DeleteQueue v -> IO (DeleteQueue v)
cleanQueue DeleteQueue xData
deleteQueue2
               (EqGuardQueue key xData, IO ())
-> IO (EqGuardQueue key xData, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (EqGuardQueue key xData
guardQueue {matchAnys :: DeleteQueue xData
matchAnys = DeleteQueue xData
deleteQueue2},IO ()
invalidate)
         EqMatch key
EqMatchNone -> (EqGuardQueue key xData, IO ())
-> IO (EqGuardQueue key xData, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (EqGuardQueue key xData
guardQueue,IO ()
forall (m :: * -> *). Monad m => m ()
done)

instance Ord key => HasRemove (EqGuardQueue key) (key,value) (EqMatch key) where
   remove :: EqGuardQueue key yData
-> (key, value)
-> IO
     (Maybe (EqMatch key, yData, IO (EqGuardQueue key yData)),
      EqGuardQueue key yData)
remove EqGuardQueue key yData
guardQueue (key
key,value
_) =
      do
         (Maybe (yData, FMQueue key yData), FMQueue key yData)
removed <- FMQueue key yData
-> key -> IO (Maybe (yData, FMQueue key yData), FMQueue key yData)
forall key contents.
Ord key =>
FMQueue key contents
-> key
-> IO
     (Maybe (contents, FMQueue key contents), FMQueue key contents)
removeFMQueue (EqGuardQueue key yData -> FMQueue key yData
forall key guardCont.
Ord key =>
EqGuardQueue key guardCont -> FMQueue key guardCont
eqs EqGuardQueue key yData
guardQueue) key
key
         case (Maybe (yData, FMQueue key yData), FMQueue key yData)
removed of
            (Just (yData
guardCont,FMQueue key yData
fmQueue2),FMQueue key yData
fmQueue0) ->
               do
                  let gq :: FMQueue key yData -> EqGuardQueue key yData
gq FMQueue key yData
fmq = EqGuardQueue key yData
guardQueue {eqs :: FMQueue key yData
eqs = FMQueue key yData
fmq}
                  (Maybe (EqMatch key, yData, IO (EqGuardQueue key yData)),
 EqGuardQueue key yData)
-> IO
     (Maybe (EqMatch key, yData, IO (EqGuardQueue key yData)),
      EqGuardQueue key yData)
forall (m :: * -> *) a. Monad m => a -> m a
return ((EqMatch key, yData, IO (EqGuardQueue key yData))
-> Maybe (EqMatch key, yData, IO (EqGuardQueue key yData))
forall a. a -> Maybe a
Just(key -> EqMatch key
forall key. key -> EqMatch key
Eq key
key,yData
guardCont,EqGuardQueue key yData -> IO (EqGuardQueue key yData)
forall (m :: * -> *) a. Monad m => a -> m a
return(FMQueue key yData -> EqGuardQueue key yData
forall key. FMQueue key yData -> EqGuardQueue key yData
gq FMQueue key yData
fmQueue0)),
                     FMQueue key yData -> EqGuardQueue key yData
forall key. FMQueue key yData -> EqGuardQueue key yData
gq FMQueue key yData
fmQueue2)
            (Maybe (yData, FMQueue key yData)
Nothing,FMQueue key yData
fmQueue0) ->
               do
                  let
                     mAs :: DeleteQueue yData
mAs = EqGuardQueue key yData -> DeleteQueue yData
forall key guardCont.
Ord key =>
EqGuardQueue key guardCont -> DeleteQueue guardCont
matchAnys EqGuardQueue key yData
guardQueue
                     gq :: DeleteQueue yData -> EqGuardQueue key yData
gq DeleteQueue yData
dq = EqGuardQueue :: forall key guardCont.
DeleteQueue guardCont
-> FMQueue key guardCont -> EqGuardQueue key guardCont
EqGuardQueue {matchAnys :: DeleteQueue yData
matchAnys = DeleteQueue yData
dq,eqs :: FMQueue key yData
eqs = FMQueue key yData
fmQueue0}
                  Maybe (yData, DeleteQueue yData, DeleteQueue yData)
removed2 <- DeleteQueue yData
-> IO (Maybe (yData, DeleteQueue yData, DeleteQueue yData))
forall v.
DeleteQueue v -> IO (Maybe (v, DeleteQueue v, DeleteQueue v))
removeQueue DeleteQueue yData
mAs
                  case Maybe (yData, DeleteQueue yData, DeleteQueue yData)
removed2 of
                     Just (yData
guardCont,DeleteQueue yData
dqueue2,DeleteQueue yData
dqueue0) ->
                        (Maybe (EqMatch key, yData, IO (EqGuardQueue key yData)),
 EqGuardQueue key yData)
-> IO
     (Maybe (EqMatch key, yData, IO (EqGuardQueue key yData)),
      EqGuardQueue key yData)
forall (m :: * -> *) a. Monad m => a -> m a
return ((EqMatch key, yData, IO (EqGuardQueue key yData))
-> Maybe (EqMatch key, yData, IO (EqGuardQueue key yData))
forall a. a -> Maybe a
Just (EqMatch key
forall key. EqMatch key
EqMatchAny,yData
guardCont,
                              EqGuardQueue key yData -> IO (EqGuardQueue key yData)
forall (m :: * -> *) a. Monad m => a -> m a
return (DeleteQueue yData -> EqGuardQueue key yData
gq DeleteQueue yData
dqueue0)),
                           DeleteQueue yData -> EqGuardQueue key yData
gq DeleteQueue yData
dqueue2)
                     Maybe (yData, DeleteQueue yData, DeleteQueue yData)
Nothing ->
                        (Maybe (EqMatch key, yData, IO (EqGuardQueue key yData)),
 EqGuardQueue key yData)
-> IO
     (Maybe (EqMatch key, yData, IO (EqGuardQueue key yData)),
      EqGuardQueue key yData)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (EqMatch key, yData, IO (EqGuardQueue key yData))
forall a. Maybe a
Nothing,DeleteQueue yData -> EqGuardQueue key yData
gq DeleteQueue yData
mAs)