module Test.Credit.Queue.Realtime where

import Prelude hiding (lookup, reverse)

import Prettyprinter (Pretty)
import Control.Monad.Credit
import Test.Credit.Queue.Base
import Test.Credit.Queue.Streams

-- | Delay a computation, but do not consume any credits
indirect :: MonadInherit m => SLazyCon m (Stream m a) -> m (Stream m a)
indirect :: forall (m :: * -> *) a.
MonadInherit m =>
SLazyCon m (Stream m a) -> m (Stream m a)
indirect SLazyCon m (Stream m a)
t = SLazyCon m (Stream m a) -> m (Thunk m (SLazyCon m) (Stream m a))
forall (m :: * -> *) (t :: * -> *) a.
MonadLazy m =>
t a -> m (Thunk m t a)
forall (t :: * -> *) a. t a -> m (Thunk m t a)
delay SLazyCon m (Stream m a)
t m (Thunk m (SLazyCon m) (Stream m a))
-> (Thunk m (SLazyCon m) (Stream m a) -> m (Stream m a))
-> m (Stream m a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stream m a -> m (Stream m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stream m a -> m (Stream m a))
-> (Thunk m (SLazyCon m) (Stream m a) -> Stream m a)
-> Thunk m (SLazyCon m) (Stream m a)
-> m (Stream m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Thunk m (SLazyCon m) (Stream m a) -> Stream m a
forall (m :: * -> *) a. SThunk m (Stream m a) -> Stream m a
SIndirect

data RQueue a m = RQueue
  { forall a (m :: * -> *). RQueue a m -> Stream m a
front :: Stream m a
  , forall a (m :: * -> *). RQueue a m -> Stream m a
rear :: Stream m a
  , forall a (m :: * -> *). RQueue a m -> Stream m a
schedule :: Stream m a
  }

rqueue :: MonadInherit m => RQueue a m -> m (RQueue a m)
rqueue :: forall (m :: * -> *) a.
MonadInherit m =>
RQueue a m -> m (RQueue a m)
rqueue (RQueue Stream m a
f Stream m a
r Stream m a
s) = Stream m a -> m ()
forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
credit Stream m a
s m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream m a -> m ()
forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
credit Stream m a
s m () -> m (RQueue a m) -> m (RQueue a m)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream m a
-> (a -> Stream m a -> m (RQueue a m))
-> m (RQueue a m)
-> m (RQueue a m)
forall (m :: * -> *) a b.
MonadInherit m =>
Stream m a -> (a -> Stream m a -> m b) -> m b -> m b
smatch Stream m a
s
  (\a
x Stream m a
s -> RQueue a m -> m (RQueue a m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RQueue a m -> m (RQueue a m)) -> RQueue a m -> m (RQueue a m)
forall a b. (a -> b) -> a -> b
$ Stream m a -> Stream m a -> Stream m a -> RQueue a m
forall a (m :: * -> *).
Stream m a -> Stream m a -> Stream m a -> RQueue a m
RQueue Stream m a
f Stream m a
r Stream m a
s)
  (do
    Stream m a
r' <- SLazyCon m (Stream m a) -> m (Stream m a)
forall (m :: * -> *) a.
MonadInherit m =>
SLazyCon m (Stream m a) -> m (Stream m a)
indirect (Stream m a -> Stream m a -> SLazyCon m (Stream m a)
forall (m :: * -> *) a1.
Stream m a1 -> Stream m a1 -> SLazyCon m (Stream m a1)
SReverse Stream m a
r Stream m a
forall (m :: * -> *) a. Stream m a
SNil)
    Stream m a
f' <- SLazyCon m (Stream m a) -> m (Stream m a)
forall (m :: * -> *) a.
MonadInherit m =>
SLazyCon m (Stream m a) -> m (Stream m a)
indirect (Stream m a -> Stream m a -> SLazyCon m (Stream m a)
forall (m :: * -> *) a1.
Stream m a1 -> Stream m a1 -> SLazyCon m (Stream m a1)
SAppend Stream m a
f Stream m a
r')
    Stream m a -> m ()
forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
credit Stream m a
r' m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream m a -> m ()
forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
evalone Stream m a
r'
    RQueue a m -> m (RQueue a m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RQueue a m -> m (RQueue a m)) -> RQueue a m -> m (RQueue a m)
forall a b. (a -> b) -> a -> b
$ Stream m a -> Stream m a -> Stream m a -> RQueue a m
forall a (m :: * -> *).
Stream m a -> Stream m a -> Stream m a -> RQueue a m
RQueue Stream m a
f' Stream m a
forall (m :: * -> *) a. Stream m a
SNil Stream m a
f')

instance Queue RQueue where
  empty :: forall (m :: * -> *) a. MonadInherit m => m (RQueue a m)
empty = RQueue a m -> m (RQueue a m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RQueue a m -> m (RQueue a m)) -> RQueue a m -> m (RQueue a m)
forall a b. (a -> b) -> a -> b
$ Stream m a -> Stream m a -> Stream m a -> RQueue a m
forall a (m :: * -> *).
Stream m a -> Stream m a -> Stream m a -> RQueue a m
RQueue Stream m a
forall (m :: * -> *) a. Stream m a
SNil Stream m a
forall (m :: * -> *) a. Stream m a
SNil Stream m a
forall (m :: * -> *) a. Stream m a
SNil
  snoc :: forall (m :: * -> *) a.
MonadInherit m =>
RQueue a m -> a -> m (RQueue a m)
snoc (RQueue Stream m a
f Stream m a
r Stream m a
s) a
x = RQueue a m -> m (RQueue a m)
forall (m :: * -> *) a.
MonadInherit m =>
RQueue a m -> m (RQueue a m)
rqueue (Stream m a -> Stream m a -> Stream m a -> RQueue a m
forall a (m :: * -> *).
Stream m a -> Stream m a -> Stream m a -> RQueue a m
RQueue Stream m a
f (a -> Stream m a -> Stream m a
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons a
x Stream m a
r) Stream m a
s)
  uncons :: forall (m :: * -> *) a.
MonadInherit m =>
RQueue a m -> m (Maybe (a, RQueue a m))
uncons (RQueue Stream m a
f Stream m a
r Stream m a
s) = Stream m a -> m ()
forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
credit Stream m a
f m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream m a -> m ()
forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
credit Stream m a
f m () -> m (Maybe (a, RQueue a m)) -> m (Maybe (a, RQueue a m))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream m a
-> (a -> Stream m a -> m (Maybe (a, RQueue a m)))
-> m (Maybe (a, RQueue a m))
-> m (Maybe (a, RQueue a m))
forall (m :: * -> *) a b.
MonadInherit m =>
Stream m a -> (a -> Stream m a -> m b) -> m b -> m b
smatch Stream m a
f
    (\a
x Stream m a
f -> RQueue a m -> m (RQueue a m)
forall (m :: * -> *) a.
MonadInherit m =>
RQueue a m -> m (RQueue a m)
rqueue (Stream m a -> Stream m a -> Stream m a -> RQueue a m
forall a (m :: * -> *).
Stream m a -> Stream m a -> Stream m a -> RQueue a m
RQueue Stream m a
f Stream m a
r Stream m a
s) m (RQueue a m)
-> (RQueue a m -> m (Maybe (a, RQueue a m)))
-> m (Maybe (a, RQueue a m))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RQueue a m
q -> Maybe (a, RQueue a m) -> m (Maybe (a, RQueue a m))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (a, RQueue a m) -> m (Maybe (a, RQueue a m)))
-> Maybe (a, RQueue a m) -> m (Maybe (a, RQueue a m))
forall a b. (a -> b) -> a -> b
$ (a, RQueue a m) -> Maybe (a, RQueue a m)
forall a. a -> Maybe a
Just (a
x, RQueue a m
q))
    (Maybe (a, RQueue a m) -> m (Maybe (a, RQueue a m))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (a, RQueue a m)
forall a. Maybe a
Nothing)

instance BoundedQueue RQueue where
  qcost :: forall a. Size -> QueueOp a -> Credit
qcost Size
_ (Snoc a
_) = Credit
4
  qcost Size
_ QueueOp a
Uncons = Credit
7

instance (MonadMemory m, MemoryCell m a) => MemoryCell m (RQueue a m) where
  prettyCell :: RQueue a m -> m Memory
prettyCell (RQueue Stream m a
f Stream m a
r Stream m a
s) = do
    Memory
f' <- Stream m a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Stream m a
f
    Memory
r' <- Stream m a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Stream m a
r
    Memory
s' <- Stream m a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Stream m a
s
    Memory -> m Memory
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Memory -> m Memory) -> Memory -> m Memory
forall a b. (a -> b) -> a -> b
$ String -> [Memory] -> Memory
mkMCell String
"Queue" [Memory
f', Memory
r', Memory
s']

instance Pretty a => MemoryStructure (RQueue (PrettyCell a)) where
  prettyStructure :: forall (m :: * -> *).
MonadMemory m =>
RQueue (PrettyCell a) m -> m Memory
prettyStructure = RQueue (PrettyCell a) m -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell