{-# LANGUAGE GADTs #-}

module Test.Credit.Deque.Streams (Stream(..), SLazyCon(..), smatch, credit, eval, c) where

import Prelude hiding (lookup, reverse)
import Control.Monad.Credit

c :: Int
c :: Int
c = Int
5

data Stream m a
  = SCons a (Stream m a)
  | SNil
  | SIndirect (SThunk m (Stream m a))

type SThunk m = Thunk m (SLazyCon m)

data SLazyCon m a where
  SAppend :: Stream m a -> Stream m a -> SLazyCon m (Stream m a)
  SRevDrop :: Int -> Stream m a -> Stream m a -> SLazyCon m (Stream m a)
  STake :: Int -> Stream m a -> SLazyCon m (Stream 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) = 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 (SRevDrop Int
n Stream m a
xs Stream m a
ys) = Int -> Stream m a -> Stream m a -> m (Stream m a)
forall (m :: * -> *) a.
MonadInherit m =>
Int -> Stream m a -> Stream m a -> m (Stream m a)
srevdrop Int
n Stream m a
xs Stream m a
ys
  step (STake Int
n Stream m a
xs) = Int -> Stream m a -> m (Stream m a)
forall (m :: * -> *) a.
MonadInherit m =>
Int -> Stream m a -> m (Stream m a)
stake Int
n Stream m a
xs

-- | Smart destructor for streams, consuming one credit
smatch :: MonadInherit m => Stream m a -- ^ Scrutinee
       -> (a -> Stream m a -> m b) -- ^ Cons case
       -> m b -- ^ Nil case
       -> m b
smatch :: forall (m :: * -> *) a b.
MonadInherit m =>
Stream m a -> (a -> Stream m a -> m b) -> m b -> m b
smatch Stream m a
x a -> Stream m a -> m b
cons m b
nil = m ()
forall (m :: * -> *). MonadCount m => m ()
tick m () -> m b -> m b
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 b
eval Stream m a
x
  where
    eval :: Stream m a -> m b
eval Stream m a
x = case Stream m a
x of
      SCons a
a Stream m a
as -> a -> Stream m a -> m b
cons a
a Stream m a
as
      Stream m a
SNil -> m b
nil
      SIndirect SThunk m (Stream m a)
i -> SThunk m (Stream m a) -> m (Stream 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 SThunk m (Stream m a)
i m (Stream m a) -> (Stream m a -> m b) -> m b
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 b
eval

-- | delay a computation, consuming all credits
taildelay :: MonadInherit m => SLazyCon m (Stream m a) -> m (Stream m a)
taildelay :: forall (m :: * -> *) a.
MonadInherit m =>
SLazyCon m (Stream m a) -> m (Stream m a)
taildelay 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
>>= \Thunk m (SLazyCon m) (Stream m a)
x -> Thunk m (SLazyCon m) (Stream m a) -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadInherit m =>
Thunk m t a -> m ()
forall (t :: * -> *) a. Thunk m t a -> m ()
creditAllTo Thunk m (SLazyCon m) (Stream m a)
x 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 (Thunk m (SLazyCon m) (Stream m a) -> Stream m a
forall (m :: * -> *) a. SThunk m (Stream m a) -> Stream m a
SIndirect Thunk m (SLazyCon m) (Stream m a)
x)

stake :: MonadInherit m => Int -> Stream m a -> m (Stream m a)
stake :: forall (m :: * -> *) a.
MonadInherit m =>
Int -> Stream m a -> m (Stream m a)
stake Int
0 Stream m a
xs = Stream m a -> m (Stream m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stream m a
forall (m :: * -> *) a. Stream m a
SNil
stake Int
n Stream m a
xs = Stream m a
-> (a -> Stream m a -> m (Stream m a))
-> m (Stream m a)
-> m (Stream m a)
forall (m :: * -> *) a b.
MonadInherit m =>
Stream m a -> (a -> Stream m a -> m b) -> m b -> m b
smatch Stream m a
xs
  (\a
x Stream m a
xs -> a -> Stream m a -> Stream m a
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons a
x (Stream m a -> Stream m a) -> m (Stream m a) -> m (Stream m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SLazyCon m (Stream m a) -> m (Stream m a)
forall (m :: * -> *) a.
MonadInherit m =>
SLazyCon m (Stream m a) -> m (Stream m a)
taildelay (Int -> Stream m a -> SLazyCon m (Stream m a)
forall (m :: * -> *) a.
Int -> Stream m a -> SLazyCon m (Stream m a)
STake (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Stream m a
xs))
  (Stream m a -> m (Stream m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stream m a
forall (m :: * -> *) a. Stream m a
SNil)

srevdrop :: MonadInherit m => Int -> Stream m a -> Stream m a -> m (Stream m a)
srevdrop :: forall (m :: * -> *) a.
MonadInherit m =>
Int -> Stream m a -> Stream m a -> m (Stream m a)
srevdrop Int
0 Stream m a
xs Stream m a
ys = Stream m a
-> (a -> Stream m a -> m (Stream m a))
-> m (Stream m a)
-> m (Stream m a)
forall (m :: * -> *) a b.
MonadInherit m =>
Stream m a -> (a -> Stream m a -> m b) -> m b -> m b
smatch Stream m a
xs
  (\a
x Stream m a
xs -> SLazyCon m (Stream m a) -> m (Stream m a)
forall (m :: * -> *) a.
MonadInherit m =>
SLazyCon m (Stream m a) -> m (Stream m a)
taildelay (Int -> Stream m a -> Stream m a -> SLazyCon m (Stream m a)
forall (m :: * -> *) a.
Int -> Stream m a -> Stream m a -> SLazyCon m (Stream m a)
SRevDrop Int
0 Stream m a
xs (a -> Stream m a -> Stream m a
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons a
x Stream m a
ys)))
  (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)
srevdrop Int
n Stream m a
xs Stream m a
ys = Stream m a
-> (a -> Stream m a -> m (Stream m a))
-> m (Stream m a)
-> m (Stream m a)
forall (m :: * -> *) a b.
MonadInherit m =>
Stream m a -> (a -> Stream m a -> m b) -> m b -> m b
smatch Stream m a
xs
  (\a
x Stream m a
xs -> SLazyCon m (Stream m a) -> m (Stream m a)
forall (m :: * -> *) a.
MonadInherit m =>
SLazyCon m (Stream m a) -> m (Stream m a)
taildelay (Int -> Stream m a -> Stream m a -> SLazyCon m (Stream m a)
forall (m :: * -> *) a.
Int -> Stream m a -> Stream m a -> SLazyCon m (Stream m a)
SRevDrop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Stream m a
xs Stream m a
ys))
  (String -> m (Stream m a)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"drop: empty stream")

credit :: MonadInherit m => Credit -> Stream m a -> m ()
credit :: forall (m :: * -> *) a.
MonadInherit m =>
Credit -> Stream m a -> m ()
credit Credit
n (SIndirect SThunk m (Stream m a)
i) = SThunk m (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 SThunk m (Stream m a)
i Credit
n
credit Credit
_ Stream m a
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

evalone :: MonadInherit m => Stream m a -> m ()
evalone :: forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
evalone (SIndirect SThunk m (Stream m a)
i) = SThunk m (Stream m a) -> m (Stream 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 SThunk m (Stream m a)
i m (Stream m a) -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
evalone Stream m a
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

eval :: MonadInherit m => Int -> Stream m a -> m ()
eval :: forall (m :: * -> *) a. MonadInherit m => Int -> Stream m a -> m ()
eval Int
0 Stream m a
s = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
eval Int
n Stream m a
s = Stream m a -> m ()
forall (m :: * -> *) a. MonadInherit m => Stream m a -> m ()
evalone 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
>> Int -> Stream m a -> m ()
forall (m :: * -> *) a. MonadInherit m => Int -> Stream m a -> m ()
eval (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Stream m a
s

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 = Credit -> Stream m a -> m ()
forall (m :: * -> *) a.
MonadInherit m =>
Credit -> Stream m a -> m ()
credit (Int -> Credit
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c) Stream m a
ys m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Stream m a -> m ()
forall (m :: * -> *) a. MonadInherit m => Int -> Stream m a -> m ()
eval Int
c 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
-> (a -> Stream m a -> m (Stream m a))
-> m (Stream m a)
-> m (Stream m a)
forall (m :: * -> *) a b.
MonadInherit m =>
Stream m a -> (a -> Stream m a -> m b) -> m b -> m b
smatch Stream m a
xs
  (\a
x Stream m a
xs -> a -> Stream m a -> Stream m a
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons a
x (Stream m a -> Stream m a) -> m (Stream m a) -> m (Stream m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SLazyCon m (Stream m a) -> m (Stream m a)
forall (m :: * -> *) a.
MonadInherit m =>
SLazyCon m (Stream m a) -> m (Stream m a)
taildelay (Stream m a -> Stream m a -> SLazyCon m (Stream m a)
forall (m :: * -> *) a.
Stream m a -> Stream m a -> SLazyCon m (Stream m a)
SAppend Stream m a
xs Stream m a
ys))
  (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)

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 (SRevDrop Int
n Stream m a
xs Stream m a
ys) = do
    Memory
n' <- Int -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Int
n
    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
"SRevDrop" [Memory
n', Memory
xs', Memory
ys']
  prettyCell (STake Int
n Stream m a
xs) = do
    Memory
n' <- Int -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Int
n
    Memory
xs' <- Stream m a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Stream m a
xs
    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
"STake" [Memory
n', Memory
xs']

instance (MonadMemory m, MemoryCell m a) => MemoryCell m (Stream m a) where
  prettyCell :: Stream m a -> m Memory
prettyCell Stream 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
<$> Stream m a -> m [Memory]
forall {f :: * -> *} {a} {m :: * -> *}.
MemoryCell f a =>
Stream m a -> f [Memory]
toList Stream 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
<*> Stream m a -> m (Maybe Memory)
forall {f :: * -> *} {m :: * -> *} {a}.
MemoryCell f (SThunk m (Stream m a)) =>
Stream m a -> f (Maybe Memory)
toHole Stream m a
xs
    where
      toList :: Stream m a -> f [Memory]
toList Stream m 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 m 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 m a -> f [Memory]
toList Stream m a
xs
      toList (SIndirect SThunk m (Stream m a)
t) = [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
$ []

      toHole :: Stream m a -> f (Maybe Memory)
toHole Stream m 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 m a
xs) = Stream m a -> f (Maybe Memory)
toHole Stream m a
xs
      toHole (SIndirect SThunk m (Stream m a)
t) = 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
<$> SThunk m (Stream m a) -> f Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell SThunk m (Stream m a)
t