module Data.Machine.Process
(
Process
, ProcessT
, Automaton(..)
, process
, (<~), (~>)
, echo
, supply
, prepended
, filtered
, dropping
, taking
, droppingWhile
, takingWhile
, buffered
, fold
, scan
, asParts
, sinkPart_
, autoM
) where
import Control.Applicative
import Control.Category
import Control.Monad (liftM, when, replicateM_)
import Control.Monad.Trans.Class
import Data.Foldable hiding (fold)
import Data.Machine.Is
import Data.Machine.Plan
import Data.Machine.Type
import Data.Void
import Prelude hiding ((.), id, mapM_)
infixr 9 <~
infixl 9 ~>
type Process a b = Machine (Is a) b
type ProcessT m a b = MachineT m (Is a) b
class Automaton k where
auto :: k a b -> Process a b
instance Automaton (->) where
auto f = repeatedly $ do
i <- await
yield (f i)
instance Automaton Is where
auto Refl = echo
echo :: Process a a
echo = repeatedly $ do
i <- await
yield i
prepended :: Foldable f => f a -> Process a a
prepended = before echo . traverse_ yield
filtered :: (a -> Bool) -> Process a a
filtered p = repeatedly $ do
i <- await
when (p i) $ yield i
dropping :: Int -> Process a a
dropping n = before echo $ replicateM_ n await
taking :: Int -> Process a a
taking n = construct . replicateM_ n $ await >>= yield
takingWhile :: (a -> Bool) -> Process a a
takingWhile p = repeatedly $ await >>= \v -> if p v then yield v else stop
droppingWhile :: (a -> Bool) -> Process a a
droppingWhile p = before echo loop where
loop = await >>= \v -> if p v then loop else yield v
buffered :: Int -> Process a [a]
buffered = repeatedly . go [] where
go [] 0 = stop
go acc 0 = yield (reverse acc)
go acc n = do
i <- await <|> yield (reverse acc) *> stop
go (i:acc) $! n1
(<~) :: Monad m => ProcessT m b c -> MachineT m k b -> MachineT m k c
mp <~ ma = MachineT $ runMachineT mp >>= \v -> case v of
Stop -> return Stop
Yield o k -> return $ Yield o (k <~ ma)
Await f Refl ff -> runMachineT ma >>= \u -> case u of
Stop -> runMachineT $ ff <~ stopped
Yield o k -> runMachineT $ f o <~ k
Await g kg fg -> return $ Await (\a -> MachineT (return v) <~ g a) kg (MachineT (return v) <~ fg)
(~>) :: Monad m => MachineT m k b -> ProcessT m b c -> MachineT m k c
ma ~> mp = mp <~ ma
supply :: Monad m => [a] -> ProcessT m a b -> ProcessT m a b
supply [] m = m
supply xxs@(x:xs) m = MachineT $ runMachineT m >>= \v -> case v of
Stop -> return Stop
Await f Refl _ -> runMachineT $ supply xs (f x)
Yield o k -> return $ Yield o (supply xxs k)
process :: Monad m => (forall a. k a -> i -> a) -> MachineT m k o -> ProcessT m i o
process f (MachineT m) = MachineT (liftM f' m) where
f' (Yield o k) = Yield o (process f k)
f' Stop = Stop
f' (Await g kir h) = Await (process f . g . f kir) Refl (process f h)
scan :: Category k => (a -> b -> a) -> a -> Machine (k b) a
scan func seed = construct $ go seed where
go cur = do
next <- await
yield $ func cur next
go $ func cur next
fold :: Category k => (a -> b -> a) -> a -> Machine (k b) a
fold func seed = construct $ go seed where
go cur = do
next <- await <|> yield cur *> stop
go (func cur next)
asParts :: Foldable f => Process (f a) a
asParts = repeatedly $ await >>= mapM_ yield
sinkPart_ :: Monad m => (a -> (b,c)) -> ProcessT m c Void -> ProcessT m a b
sinkPart_ p = go
where go m = MachineT $ runMachineT m >>= \v -> case v of
Stop -> return Stop
Yield _ k -> runMachineT $ go k
Await f Refl ff -> return $
Await (\x -> let (keep,sink) = p x
in encased . Yield keep $ go (f sink))
Refl
(go ff)
autoM :: Monad m => (a -> m b) -> ProcessT m a b
autoM f = repeatedly $ await >>= lift . f >>= yield