{-# LANGUAGE GADTs, LambdaCase #-}

module Test.Credit.Queue.Streams (Stream, StreamCell(..), SLazyCon(..), cons, nil, slength, toList, test) where

import Control.Monad
import Control.Monad.Credit

type Stream m a = Thunk m (SLazyCon m) (StreamCell m a)

data StreamCell m a
  = SCons a (Stream m a)
  | SNil

data SLazyCon m a where
  SAppend  :: Stream m a -> Stream m a -> SLazyCon m (StreamCell m a)
  SReverse :: Stream m a -> Stream m a -> SLazyCon m (StreamCell m a)

instance MonadInherit m => HasStep (SLazyCon m) m where
  step :: forall a. SLazyCon m a -> m a
step (SAppend  Stream m a
xs Stream m a
ys) = Thunk m (SLazyCon m) a -> 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 (Thunk m (SLazyCon m) a -> m a)
-> m (Thunk m (SLazyCon m) a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stream m a -> Stream m a -> m (Stream m a)
forall (m :: * -> *) a.
MonadInherit m =>
Stream m a -> Stream m a -> m (Stream m a)
sappend  Stream m a
xs Stream m a
ys 
  step (SReverse Stream m a
xs Stream m a
ys) = Thunk m (SLazyCon m) a -> 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 (Thunk m (SLazyCon m) a -> m a)
-> m (Thunk m (SLazyCon m) a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stream m a -> Stream m a -> m (Stream m a)
forall (m :: * -> *) a.
MonadInherit m =>
Stream m a -> Stream m a -> m (Stream m a)
sreverse Stream m a
xs Stream m a
ys

cons :: MonadLazy m => a -> Stream m a -> m (Stream m a)
cons :: forall (m :: * -> *) a.
MonadLazy m =>
a -> Stream m a -> m (Stream m a)
cons a
x Stream m a
xs = StreamCell m a -> m (Stream m a)
forall a (t :: * -> *). a -> m (Thunk m t a)
forall (m :: * -> *) a (t :: * -> *).
MonadLazy m =>
a -> m (Thunk m t a)
value (StreamCell m a -> m (Stream m a))
-> StreamCell m a -> m (Stream m a)
forall a b. (a -> b) -> a -> b
$ a -> Stream m a -> StreamCell m a
forall (m :: * -> *) a. a -> Stream m a -> StreamCell m a
SCons a
x Stream m a
xs

nil :: MonadLazy m => m (Stream m a)
nil :: forall (m :: * -> *) a. MonadLazy m => m (Stream m a)
nil = StreamCell m a -> m (Thunk m (SLazyCon m) (StreamCell m a))
forall a (t :: * -> *). a -> m (Thunk m t a)
forall (m :: * -> *) a (t :: * -> *).
MonadLazy m =>
a -> m (Thunk m t a)
value StreamCell m a
forall (m :: * -> *) a. StreamCell m a
SNil

sreverse :: MonadInherit m
          => Stream m a -> Stream m a -> m (Stream m a)
sreverse :: forall (m :: * -> *) a.
MonadInherit m =>
Stream m a -> Stream m a -> m (Stream m a)
sreverse Stream m a
xs Stream m a
ys = m ()
forall (m :: * -> *). MonadCount m => m ()
tick m () -> m (StreamCell m a) -> m (StreamCell m a)
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 (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
xs m (StreamCell m a)
-> (StreamCell 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
>>= \case
  SCons a
x Stream m a
xs -> Stream m a -> Stream m a -> m (Stream m a)
forall (m :: * -> *) a.
MonadInherit m =>
Stream m a -> Stream m a -> m (Stream m a)
sreverse Stream m a
xs (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
=<< 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
ys
  StreamCell m a
SNil -> Stream m a -> m (Stream m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stream m a
ys

sappend :: MonadInherit m
         => Stream m a -> Stream m a -> m (Stream m a)
sappend :: forall (m :: * -> *) a.
MonadInherit m =>
Stream m a -> Stream m a -> m (Stream m a)
sappend Stream m a
xs Stream m a
ys = do
  m ()
forall (m :: * -> *). MonadCount m => m ()
tick
  Stream m a
ys 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 -> 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
xs m (StreamCell m a)
-> (StreamCell 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
>>= \case
    SCons a
x Stream m a
xs' -> do
      Stream m a
xs'ys <- 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 :: * -> *) a.
Stream m a -> Stream m a -> SLazyCon m (StreamCell m a)
SAppend Stream m a
xs' Stream m a
ys
      Stream m a -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadInherit m =>
Thunk m t a -> m ()
forall (t :: * -> *) a. Thunk m t a -> m ()
creditAllTo Stream m a
xs'ys
      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
xs'ys
    StreamCell m a
SNil -> Stream m a -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadInherit m =>
Thunk m t a -> m ()
forall (t :: * -> *) a. Thunk m t a -> m ()
creditAllTo Stream m a
ys m () -> m (Stream m a) -> m (Stream m a)
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 (Stream m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stream m a
ys

cellToList :: MonadLazy m => StreamCell m a -> m [a]
cellToList :: forall (m :: * -> *) a. MonadLazy m => StreamCell m a -> m [a]
cellToList StreamCell m a
SNil = [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
cellToList (SCons a
x Stream m a
xs) = (a
x :) ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stream m a -> m [a]
forall (m :: * -> *) a. MonadLazy m => Stream m a -> m [a]
toList Stream m a
xs

toList :: MonadLazy m => Stream m a -> m [a]
toList :: forall (m :: * -> *) a. MonadLazy m => Stream m a -> m [a]
toList Stream m a
t = do
  Stream m a
-> (StreamCell m a -> m [a])
-> (SLazyCon m (StreamCell m a) -> m [a])
-> m [a]
forall (m :: * -> *) (t :: * -> *) a b.
MonadLazy m =>
Thunk m t a -> (a -> m b) -> (t a -> m b) -> m b
forall (t :: * -> *) a b.
Thunk m t a -> (a -> m b) -> (t a -> m b) -> m b
lazymatch Stream m a
t StreamCell m a -> m [a]
forall (m :: * -> *) a. MonadLazy m => StreamCell m a -> m [a]
cellToList ((SLazyCon m (StreamCell m a) -> m [a]) -> m [a])
-> (SLazyCon m (StreamCell m a) -> m [a]) -> m [a]
forall a b. (a -> b) -> a -> b
$ \case
      SAppend Stream m a
xs Stream m a
ys -> do
        [a]
xs' <- Stream m a -> m [a]
forall (m :: * -> *) a. MonadLazy m => Stream m a -> m [a]
toList Stream m a
xs
        [a]
ys' <- Stream m a -> m [a]
forall (m :: * -> *) a. MonadLazy m => Stream m a -> m [a]
toList Stream m a
ys
        [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ [a]
[a]
xs' [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
[a]
ys'
      SReverse Stream m a
xs Stream m a
ys -> do
        [a]
xs' <- Stream m a -> m [a]
forall (m :: * -> *) a. MonadLazy m => Stream m a -> m [a]
toList Stream m a
xs
        [a]
ys' <- Stream m a -> m [a]
forall (m :: * -> *) a. MonadLazy m => Stream m a -> m [a]
toList Stream m a
ys
        [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
[a]
xs' [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
[a]
ys'

slength :: MonadLazy m => Stream m a -> m Int
slength :: forall (m :: * -> *) a. MonadLazy m => Stream m a -> m Int
slength Stream m a
s = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> m [a] -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stream m a -> m [a]
forall (m :: * -> *) a. MonadLazy m => Stream m a -> m [a]
toList Stream m a
s

walk :: MonadInherit m => Stream m a -> m ()
walk :: forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
walk Stream m a
s = 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 ()) -> 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
xs -> Stream m a -> m ()
forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
walk Stream m a
xs
  StreamCell m a
SNil -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

foo :: MonadInherit m => Stream m a -> m ()
foo :: forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
foo Stream m a
s = m (StreamCell m a) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (StreamCell m a) -> m ()) -> m (StreamCell m a) -> m ()
forall a b. (a -> b) -> a -> b
$ 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

test :: MonadInherit m => m ()
test :: forall (m :: * -> *). MonadInherit m => m ()
test = do
  Thunk m (SLazyCon m) (StreamCell m Integer)
nil <- StreamCell m Integer
-> m (Thunk m (SLazyCon m) (StreamCell m Integer))
forall a (t :: * -> *). a -> m (Thunk m t a)
forall (m :: * -> *) a (t :: * -> *).
MonadLazy m =>
a -> m (Thunk m t a)
value StreamCell m Integer
forall (m :: * -> *) a. StreamCell m a
SNil
  Thunk m (SLazyCon m) (StreamCell m Integer)
one <- StreamCell m Integer
-> m (Thunk m (SLazyCon m) (StreamCell m Integer))
forall a (t :: * -> *). a -> m (Thunk m t a)
forall (m :: * -> *) a (t :: * -> *).
MonadLazy m =>
a -> m (Thunk m t a)
value (Integer
-> Thunk m (SLazyCon m) (StreamCell m Integer)
-> StreamCell m Integer
forall (m :: * -> *) a. a -> Stream m a -> StreamCell m a
SCons Integer
1 Thunk m (SLazyCon m) (StreamCell m Integer)
nil)
  Thunk m (SLazyCon m) (StreamCell m Integer)
two <- StreamCell m Integer
-> m (Thunk m (SLazyCon m) (StreamCell m Integer))
forall a (t :: * -> *). a -> m (Thunk m t a)
forall (m :: * -> *) a (t :: * -> *).
MonadLazy m =>
a -> m (Thunk m t a)
value (Integer
-> Thunk m (SLazyCon m) (StreamCell m Integer)
-> StreamCell m Integer
forall (m :: * -> *) a. a -> Stream m a -> StreamCell m a
SCons Integer
2 Thunk m (SLazyCon m) (StreamCell m Integer)
nil)
  Thunk m (SLazyCon m) (StreamCell m Integer)
s <- Thunk m (SLazyCon m) (StreamCell m Integer)
-> Thunk m (SLazyCon m) (StreamCell m Integer)
-> m (Thunk m (SLazyCon m) (StreamCell m Integer))
forall (m :: * -> *) a.
MonadInherit m =>
Stream m a -> Stream m a -> m (Stream m a)
sappend Thunk m (SLazyCon m) (StreamCell m Integer)
one Thunk m (SLazyCon m) (StreamCell m Integer)
two
  Thunk m (SLazyCon m) (StreamCell m Integer) -> Credit -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadCredit m =>
Thunk m t a -> Credit -> m ()
forall (t :: * -> *) a. Thunk m t a -> Credit -> m ()
creditWith Thunk m (SLazyCon m) (StreamCell m Integer)
s Credit
2
  Thunk m (SLazyCon m) (StreamCell m Integer) -> m ()
forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
foo Thunk m (SLazyCon m) (StreamCell m Integer)
s
  Thunk m (SLazyCon m) (StreamCell m Integer) -> Credit -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadCredit m =>
Thunk m t a -> Credit -> m ()
forall (t :: * -> *) a. Thunk m t a -> Credit -> m ()
creditWith Thunk m (SLazyCon m) (StreamCell m Integer)
s Credit
1
  Thunk m (SLazyCon m) (StreamCell m Integer) -> m ()
forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
walk Thunk m (SLazyCon m) (StreamCell m Integer)
s

instance (MonadMemory m, MemoryCell m a) => MemoryCell m (SLazyCon m a) where
  prettyCell :: SLazyCon m a -> m Memory
prettyCell (SAppend Stream m a
xs Stream m a
ys) = do
    Memory
xs' <- Stream m a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Stream m a
xs
    Memory
ys' <- Stream m a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Stream m a
ys
    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
"SAppend" [Memory
xs', Memory
ys']
  prettyCell (SReverse Stream m a
xs Stream m a
ys) = do
    Memory
xs' <- Stream m a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Stream m a
xs
    Memory
ys' <- Stream m a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Stream m a
ys
    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
"SReverse" [Memory
xs', Memory
ys']

instance (MonadMemory m, MemoryCell m a) => MemoryCell m (StreamCell m a) where
  prettyCell :: StreamCell m a -> m Memory
prettyCell StreamCell m a
xs = [Memory] -> Maybe Memory -> Memory
mkMList ([Memory] -> Maybe Memory -> Memory)
-> m [Memory] -> m (Maybe Memory -> Memory)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StreamCell m a -> m [Memory]
forall {f :: * -> *} {a}.
(MemoryCell f a, MonadLazy f) =>
StreamCell f a -> f [Memory]
toList StreamCell m a
xs m (Maybe Memory -> Memory) -> m (Maybe Memory) -> m Memory
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StreamCell m a -> m (Maybe Memory)
forall {f :: * -> *} {a}.
(MonadMemory f, MemoryCell f a) =>
StreamCell f a -> f (Maybe Memory)
toHole StreamCell m a
xs
    where
      toList :: StreamCell f a -> f [Memory]
toList StreamCell f a
SNil = [Memory] -> f [Memory]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Memory] -> f [Memory]) -> [Memory] -> f [Memory]
forall a b. (a -> b) -> a -> b
$ []
      toList (SCons a
x Stream f a
xs) = (:) (Memory -> [Memory] -> [Memory])
-> f Memory -> f ([Memory] -> [Memory])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell a
x f ([Memory] -> [Memory]) -> f [Memory] -> f [Memory]
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stream f a
-> (StreamCell f a -> f [Memory])
-> (SLazyCon f (StreamCell f a) -> f [Memory])
-> f [Memory]
forall (m :: * -> *) (t :: * -> *) a b.
MonadLazy m =>
Thunk m t a -> (a -> m b) -> (t a -> m b) -> m b
forall (t :: * -> *) a b.
Thunk f t a -> (a -> f b) -> (t a -> f b) -> f b
lazymatch Stream f a
xs StreamCell f a -> f [Memory]
toList (\SLazyCon f (StreamCell f a)
_ -> [Memory] -> f [Memory]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])

      toHole :: StreamCell f a -> f (Maybe Memory)
toHole StreamCell f a
SNil = Maybe Memory -> f (Maybe Memory)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Memory -> f (Maybe Memory))
-> Maybe Memory -> f (Maybe Memory)
forall a b. (a -> b) -> a -> b
$ Maybe Memory
forall a. Maybe a
Nothing
      toHole (SCons a
x Stream f a
xs) = Stream f a
-> (StreamCell f a -> f (Maybe Memory))
-> (SLazyCon f (StreamCell f a) -> f (Maybe Memory))
-> f (Maybe Memory)
forall (m :: * -> *) (t :: * -> *) a b.
MonadLazy m =>
Thunk m t a -> (a -> m b) -> (t a -> m b) -> m b
forall (t :: * -> *) a b.
Thunk f t a -> (a -> f b) -> (t a -> f b) -> f b
lazymatch Stream f a
xs StreamCell f a -> f (Maybe Memory)
toHole (\SLazyCon f (StreamCell f a)
_ -> Memory -> Maybe Memory
forall a. a -> Maybe a
Just (Memory -> Maybe Memory) -> f Memory -> f (Maybe Memory)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stream f a -> f Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Stream f a
xs)