{-# LANGUAGE GADTs #-}
{-# LANGUAGE Rank2Types #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Machine.Stack
-- Copyright   :  (C) 2012 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  GADTs
--
----------------------------------------------------------------------------
module Data.Machine.Stack
  ( Stack(..)
  , stack
  , peek
  , pop
  , push
  ) where

import Data.Machine.Plan
import Data.Machine.Type

-- | This is a simple process type that knows how to push back input.
data Stack a r where
  Push :: a -> Stack a ()
  Pop  ::      Stack a a

-- | Peek at the next value in the input stream without consuming it
peek :: Plan (Stack a) b a
peek :: PlanT (Stack a) b m a
peek = do
  a
a <- PlanT (Stack a) b m a
forall a b. Plan (Stack a) b a
pop
  a -> Plan (Stack a) b ()
forall a b. a -> Plan (Stack a) b ()
push a
a
  a -> PlanT (Stack a) b m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
{-# INLINABLE peek #-}

-- | Push back into the input stream
push :: a -> Plan (Stack a) b ()
push :: a -> Plan (Stack a) b ()
push a
a = Stack a () -> Plan (Stack a) b ()
forall (k :: * -> *) i o. k i -> Plan k o i
awaits (a -> Stack a ()
forall a. a -> Stack a ()
Push a
a)
{-# INLINABLE push #-}

-- | Pop the next value in the input stream
pop :: Plan (Stack a) b a
pop :: PlanT (Stack a) b m a
pop = Stack a a -> Plan (Stack a) b a
forall (k :: * -> *) i o. k i -> Plan k o i
awaits Stack a a
forall a. Stack a a
Pop
{-# INLINABLE pop #-}

-- | Stream outputs from one 'Machine' into another with the possibility
-- of pushing inputs back.
stack :: Monad m => MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
stack :: MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
stack MachineT m k a
up MachineT m (Stack a) o
down =
  MachineT m (Stack a) o
-> (Step (Stack a) o (MachineT m (Stack a) o) -> MachineT m k o)
-> MachineT m k o
forall (m :: * -> *) (k :: * -> *) o (k' :: * -> *) o'.
Monad m =>
MachineT m k o
-> (Step k o (MachineT m k o) -> MachineT m k' o')
-> MachineT m k' o'
stepMachine MachineT m (Stack a) o
down ((Step (Stack a) o (MachineT m (Stack a) o) -> MachineT m k o)
 -> MachineT m k o)
-> (Step (Stack a) o (MachineT m (Stack a) o) -> MachineT m k o)
-> MachineT m k o
forall a b. (a -> b) -> a -> b
$ \Step (Stack a) o (MachineT m (Stack a) o)
stepD     ->
  case Step (Stack a) o (MachineT m (Stack a) o)
stepD of
    Step (Stack a) o (MachineT m (Stack a) o)
Stop                     -> MachineT m k o
forall (k :: * -> *) b. Machine k b
stopped
    Yield o
o MachineT m (Stack a) o
down'            -> Step k o (MachineT m k o) -> MachineT m k o
forall (m :: * -> *) (k :: * -> *) o.
Monad m =>
Step k o (MachineT m k o) -> MachineT m k o
encased (o -> MachineT m k o -> Step k o (MachineT m k o)
forall (k :: * -> *) o r. o -> r -> Step k o r
Yield o
o (MachineT m k a
up MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
forall (m :: * -> *) (k :: * -> *) a o.
Monad m =>
MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
`stack` MachineT m (Stack a) o
down'))
    Await t -> MachineT m (Stack a) o
down' (Push a
a) MachineT m (Stack a) o
_   -> Step k a (MachineT m k a) -> MachineT m k a
forall (m :: * -> *) (k :: * -> *) o.
Monad m =>
Step k o (MachineT m k o) -> MachineT m k o
encased (a -> MachineT m k a -> Step k a (MachineT m k a)
forall (k :: * -> *) o r. o -> r -> Step k o r
Yield a
a MachineT m k a
up) MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
forall (m :: * -> *) (k :: * -> *) a o.
Monad m =>
MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
`stack` t -> MachineT m (Stack a) o
down' ()
    Await t -> MachineT m (Stack a) o
down' Stack a t
Pop MachineT m (Stack a) o
ffD      ->
      MachineT m k a
-> (Step k a (MachineT m k a) -> MachineT m k o) -> MachineT m k o
forall (m :: * -> *) (k :: * -> *) o (k' :: * -> *) o'.
Monad m =>
MachineT m k o
-> (Step k o (MachineT m k o) -> MachineT m k' o')
-> MachineT m k' o'
stepMachine MachineT m k a
up ((Step k a (MachineT m k a) -> MachineT m k o) -> MachineT m k o)
-> (Step k a (MachineT m k a) -> MachineT m k o) -> MachineT m k o
forall a b. (a -> b) -> a -> b
$ \Step k a (MachineT m k a)
stepU   ->
      case Step k a (MachineT m k a)
stepU of
        Step k a (MachineT m k a)
Stop                 -> MachineT m k a
forall (k :: * -> *) b. Machine k b
stopped MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
forall (m :: * -> *) (k :: * -> *) a o.
Monad m =>
MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
`stack` MachineT m (Stack a) o
ffD
        Yield a
o MachineT m k a
up'          -> MachineT m k a
up'     MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
forall (m :: * -> *) (k :: * -> *) a o.
Monad m =>
MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
`stack` t -> MachineT m (Stack a) o
down' a
t
o
        Await t -> MachineT m k a
up' k t
req MachineT m k a
ffU    -> Step k o (MachineT m k o) -> MachineT m k o
forall (m :: * -> *) (k :: * -> *) o.
Monad m =>
Step k o (MachineT m k o) -> MachineT m k o
encased ((t -> MachineT m k o)
-> k t -> MachineT m k o -> Step k o (MachineT m k o)
forall (k :: * -> *) o r t. (t -> r) -> k t -> r -> Step k o r
Await (\t
a -> t -> MachineT m k a
up' t
a MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
forall (m :: * -> *) (k :: * -> *) a o.
Monad m =>
MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
`stack` Step (Stack a) o (MachineT m (Stack a) o) -> MachineT m (Stack a) o
forall (m :: * -> *) (k :: * -> *) o.
Monad m =>
Step k o (MachineT m k o) -> MachineT m k o
encased Step (Stack a) o (MachineT m (Stack a) o)
stepD) k t
req
                                               (      MachineT m k a
ffU   MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
forall (m :: * -> *) (k :: * -> *) a o.
Monad m =>
MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
`stack` Step (Stack a) o (MachineT m (Stack a) o) -> MachineT m (Stack a) o
forall (m :: * -> *) (k :: * -> *) o.
Monad m =>
Step k o (MachineT m k o) -> MachineT m k o
encased Step (Stack a) o (MachineT m (Stack a) o)
stepD))
{-# INLINABLE stack #-}