{-# LANGUAGE LambdaCase #-}

module Test.Credit.Queue.Realtime where

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

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) = do
  Stream m a
s Stream m a -> Credit -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadCredit m =>
Thunk m t a -> Credit -> m ()
forall (t :: * -> *) a. Thunk m t a -> Credit -> m ()
`creditWith` Credit
2
  Stream m a -> m (StreamCell m a)
forall (m :: * -> *) (t :: * -> *) a.
(MonadLazy m, HasStep t m) =>
Thunk m t a -> m a
forall (t :: * -> *) a. HasStep t m => Thunk m t a -> m a
force Stream m a
s m (StreamCell m a)
-> (StreamCell m a -> m (RQueue a m)) -> m (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
>>= \case
    SCons a
_ 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
    StreamCell m a
SNil -> do
      Stream m a
r' <- SLazyCon m (StreamCell m a) -> 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 (StreamCell m a) -> m (Stream m a))
-> (Stream m a -> SLazyCon m (StreamCell m a))
-> Stream m a
-> m (Stream m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream m a -> Stream m a -> SLazyCon m (StreamCell m a)
forall (m :: * -> *) a1.
Stream m a1 -> Stream m a1 -> SLazyCon m (StreamCell m a1)
SReverse Stream m a
r (Stream m a -> m (Stream m a)) -> m (Stream m a) -> m (Stream m a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Stream m a)
forall (m :: * -> *) a. MonadLazy m => m (Stream m a)
nil
      Stream m a
f' <- SLazyCon m (StreamCell m a) -> 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 (StreamCell m a) -> m (Stream m a))
-> SLazyCon m (StreamCell m a) -> m (Stream m a)
forall a b. (a -> b) -> a -> b
$ Stream m a -> Stream m a -> SLazyCon m (StreamCell m a)
forall (m :: * -> *) a1.
Stream m a1 -> Stream m a1 -> SLazyCon m (StreamCell m a1)
SAppend Stream m a
f Stream m a
r'
      Stream m a
r' Stream m a -> Credit -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadCredit m =>
Thunk m t a -> Credit -> m ()
forall (t :: * -> *) a. Thunk m t a -> Credit -> m ()
`creditWith` Credit
1
      Stream m a
n <- m (Stream m a)
forall (m :: * -> *) a. MonadLazy m => m (Stream m a)
nil
      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
n Stream m a
f'

instance Queue RQueue where
  empty :: forall (m :: * -> *) a. MonadLazy m => m (RQueue a m)
empty = do
    Stream m a
n <- m (Stream m a)
forall (m :: * -> *) a. MonadLazy m => m (Stream m a)
nil
    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
n Stream m a
n Stream m a
n
  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 = do
    Stream m a
r' <- a -> Stream m a -> m (Stream m a)
forall (m :: * -> *) a.
MonadLazy m =>
a -> Stream m a -> m (Stream m a)
cons a
x Stream m a
r
    RQueue a m -> m (RQueue a m)
forall (m :: * -> *) a.
MonadInherit m =>
RQueue a m -> m (RQueue a m)
rqueue (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
  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) = do
    Stream m a
f Stream m a -> Credit -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadCredit m =>
Thunk m t a -> Credit -> m ()
forall (t :: * -> *) a. Thunk m t a -> Credit -> m ()
`creditWith` Credit
2
    Stream m a -> m (StreamCell m a)
forall (m :: * -> *) (t :: * -> *) a.
(MonadLazy m, HasStep t m) =>
Thunk m t a -> m a
forall (t :: * -> *) a. HasStep t m => Thunk m t a -> m a
force Stream m a
f m (StreamCell m a)
-> (StreamCell m a -> 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
>>= \case
      SCons a
x Stream m a
f -> do
        RQueue a m
q <- RQueue a m -> m (RQueue a m)
forall (m :: * -> *) a.
MonadInherit m =>
RQueue a m -> m (RQueue a m)
rqueue (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
        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)
      StreamCell m a
SNil -> 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