packages feed

machines 0.5.1 → 0.6

raw patch · 15 files changed

+385/−85 lines, 15 filesdep +adjunctionsdep +distributivedep +semigroupoidsdep ~basedep ~doctest

Dependencies added: adjunctions, distributive, semigroupoids, transformers-compat

Dependency ranges changed: base, doctest

Files

CHANGELOG.markdown view
@@ -1,3 +1,13 @@+0.6+---+* Added better fanout combinators. `Data.Machine.Fanout`+* Added a module for lifting machines that run in transformed monads. `Data.Machine.Lift`+* Added instances for `Mealy` and `Moore`.+* Explicitly implemented `(<*>)` `(*>)` and `(<*)` for `PlanT`.+* Added `Data.Machine.Runner` with various tools for running machines.+* Added `teeT`.+* Added `unfoldPlan` and `preplan`+ 0.5.1 ----- * `profunctors` 5 support
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2012 Edward Kmett, Runar Bjarnason, Paul Chiusano+Copyright 2012-2015 Edward Kmett, Runar Bjarnason, Paul Chiusano  All rights reserved.
README.markdown view
@@ -1,7 +1,7 @@ machines ======== -[![Build Status](https://secure.travis-ci.org/ekmett/machines.png?branch=master)](http://travis-ci.org/ekmett/machines)+[![Hackage](https://img.shields.io/hackage/v/machines.svg)](https://hackage.haskell.org/package/machines) [![Build Status](https://secure.travis-ci.org/ekmett/machines.png?branch=master)](http://travis-ci.org/ekmett/machines)  *Ceci n'est pas une pipe*
machines.cabal view
@@ -1,6 +1,6 @@ name:          machines category:      Control, Enumerator-version:       0.5.1+version:       0.6 license:       BSD3 cabal-version: >= 1.10 license-file:  LICENSE@@ -9,7 +9,7 @@ stability:     provisional homepage:      http://github.com/ekmett/machines/ bug-reports:   http://github.com/ekmett/machines/issues-copyright:     Copyright (C) 2012 Edward A. Kmett+copyright:     Copyright (C) 2012-2015 Edward A. Kmett synopsis:      Networked stream transducers description:   Networked stream transducers@@ -36,14 +36,18 @@  library   build-depends:-    base         == 4.*,+    adjunctions  >= 4.2   && < 5,+    base         >= 4.5   && < 5,     comonad      >= 3     && < 5,     containers   >= 0.3   && < 0.6,+    distributive             < 0.5,     free         >= 3.1.1 && < 5,     pointed      >= 3     && < 5,     profunctors  >= 3     && < 6,+    semigroupoids >= 5    && < 6,     semigroups   >= 0.8.3 && < 1,     transformers >= 0.3   && < 0.5,+    transformers-compat >= 0.3,     mtl          >= 2     && < 2.3,     void         >= 0.6.1 && < 1 @@ -51,10 +55,12 @@     Data.Machine     Data.Machine.Is     Data.Machine.Fanout+    Data.Machine.Lift     Data.Machine.Mealy     Data.Machine.Moore     Data.Machine.Process     Data.Machine.Plan+    Data.Machine.Runner     Data.Machine.Source     Data.Machine.Stack     Data.Machine.Tee@@ -82,9 +88,9 @@   build-depends:     base == 4.*,     directory >= 1.0 && < 1.3,-    doctest >= 0.8 && <= 0.10,+    doctest >= 0.8 && < 0.11,     filepath >= 1.3 && < 1.5-  ghc-options: -Wall -Werror -threaded+  ghc-options: -Wall -threaded   hs-source-dirs: tests  benchmark benchmarks
src/Data/Machine/Fanout.hs view
@@ -1,57 +1,41 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+ -- | Provide a notion of fanout wherein a single input is passed to -- several consumers. module Data.Machine.Fanout (fanout, fanoutSteps) where-import Control.Applicative-import Control.Arrow-import Control.Monad (foldM)-import Data.Machine-import Data.Maybe (catMaybes)-import Data.Monoid-import Data.Semigroup (Semigroup(sconcat))-import Data.List.NonEmpty (NonEmpty((:|)))-import Prelude --- | Feed a value to a 'ProcessT' at an 'Await' 'Step'. If the--- 'ProcessT' is awaiting a value, then its next step is--- returned. Otherwise, the original process is returned.-feed :: Monad m => a -> ProcessT m a b -> m (Step (Is a) b (ProcessT m a b))-feed x m = runMachineT m >>= \v ->-            case v of-              Await f Refl _ -> runMachineT (f x)-              s -> return s+import           Data.List.NonEmpty (NonEmpty (..))+import           Data.Machine+import           Data.Semigroup     (Semigroup (sconcat))+#if __GLASGOW_HASKELL__  < 710+import           Data.Monoid        (Monoid (..))+import           Data.Traversable   (traverse)+#endif --- | Like 'Data.List.mapAccumL' but with a monadic accumulating--- function.-mapAccumLM :: (Functor m, Monad m)-           => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])-mapAccumLM f z = fmap (second ($ [])) . foldM aux (z,id)-  where aux (acc,ys) x = second ((. ys) . (:)) <$> f acc x+continue :: ([b] -> r) -> [(a -> b, b)] -> Step (Is a) o r+continue _ [] = Stop+continue f ws = Await (f . traverse fst ws) Refl (f $ map snd ws) --- | Exhaust a sequence of all successive 'Yield' steps taken by a--- 'MachineT'. Returns the list of yielded values and the next--- (non-Yield) step of the machine.-flushYields :: Monad m-            => Step k o (MachineT m k o) -> m ([o], Maybe (MachineT m k o))-flushYields = go id-  where go rs (Yield o s) = runMachineT s >>= go ((o:) . rs)-        go rs Stop = return (rs [], Nothing)-        go rs s = return (rs [], Just $ encased s)+semigroupDlist :: Semigroup a => ([a] -> [a]) -> Maybe a+semigroupDlist f = case f [] of+  [] -> Nothing+  x:xs -> Just $ sconcat (x:|xs)  -- | Share inputs with each of a list of processes in lockstep. Any -- values yielded by the processes are combined into a single yield -- from the composite process. fanout :: (Functor m, Monad m, Semigroup r)        => [ProcessT m a r] -> ProcessT m a r-fanout xs = encased $ Await (MachineT . aux) Refl (fanout xs)-  where aux y = do (rs,xs') <- mapM (feed y) xs >>= mapAccumLM yields []-                   let nxt = fanout $ catMaybes xs'-                   case rs of-                     [] -> runMachineT nxt-                     (r:rs') -> return $ Yield (sconcat $ r :| rs') nxt-        yields rs Stop = return (rs,Nothing)-        yields rs y@(Yield _ _) = first (++ rs) <$> flushYields y-        yields rs a@(Await _ _ _) = return (rs, Just $ encased a)+fanout = MachineT . go id id+  where+    go waiting acc [] = case waiting [] of+      ws -> return . maybe k (\x -> Yield x $ encased k) $ semigroupDlist acc+        where k = continue fanout ws+    go waiting acc (m:ms) = runMachineT m >>= \v -> case v of+      Stop           -> go waiting acc ms+      Yield x k      -> go waiting (acc . (x:)) (k:ms)+      Await f Refl k -> go (waiting . ((f, k):)) acc ms  -- | Share inputs with each of a list of processes in lockstep. If -- none of the processes yields a value, the composite process will@@ -62,12 +46,11 @@ -- followed by a 'taking' process. fanoutSteps :: (Functor m, Monad m, Monoid r)             => [ProcessT m a r] -> ProcessT m a r-fanoutSteps xs = encased $ Await (MachineT . aux) Refl (fanoutSteps xs)-  where aux y = do (rs,xs') <- mapM (feed y) xs >>= mapAccumLM yields []-                   let nxt = fanoutSteps $ catMaybes xs'-                   if null rs-                   then return $ Yield mempty nxt-                   else return $ Yield (mconcat rs) nxt-        yields rs Stop = return (rs,Nothing)-        yields rs y@(Yield _ _) = first (++rs) <$> flushYields y-        yields rs a@(Await _ _ _) = return (rs, Just $ encased a)+fanoutSteps = MachineT . go id id+  where+    go waiting acc [] = case (waiting [], mconcat (acc [])) of+      (ws, xs) -> return . Yield xs $ encased (continue fanoutSteps ws)+    go waiting acc (m:ms) = runMachineT m >>= \v -> case v of+      Stop           -> go waiting acc ms+      Yield x k      -> go waiting (acc . (x:)) (k:ms)+      Await f Refl k -> go (waiting . ((f, k):)) acc ms
src/Data/Machine/Group.hs view
@@ -49,12 +49,6 @@         -- That means input [Right 1, Left ()] is different to [Right 1]         g (Left  ()) = starve r $ go s --- | Run a machine with no input until it stops, then behave as another machine..-starve :: Monad m => ProcessT m a b -> MachineT m k b -> MachineT m k b-starve m cont = MachineT $ runMachineT m >>= \v -> case v of-  Stop            -> runMachineT cont -- Continue with cont instead of stopping-  Yield o r       -> return $ Yield o (starve r cont)-  Await _ Refl r  -> runMachineT (starve r cont)  -- | Read inputs until a condition is met, then behave as cont with -- | input matching condition as first input of cont.
+ src/Data/Machine/Lift.hs view
@@ -0,0 +1,36 @@+-- | Utilities for working with machines that run in transformed monads,+-- inspired by @Pipes.Lift@.+module Data.Machine.Lift (execStateM, catchExcept, runReaderM) where++import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Except+import Data.Machine.Type++-- | Given an initial state and a 'MachineT' that runs in @'StateT' s m@,+-- produce a 'MachineT' that runs in @m@.+execStateM :: Monad m => s -> MachineT (StateT s m) k o -> MachineT m k o+execStateM s m = MachineT $ do+  (stp, s') <- runStateT (runMachineT m) s+  case stp of+    Stop -> return Stop+    Yield o m' -> return $ Yield o (execStateM s' m')+    Await f k q -> return $ Await (execStateM s' . f) k (execStateM s' q)++-- | 'catchExcept' allows a broken machine to be replaced without stopping the+-- assembly line.+catchExcept :: Monad m+               => MachineT (ExceptT e m) k o+               -> (e -> MachineT (ExceptT e m) k o)+               -> MachineT (ExceptT e m) k o+catchExcept m c = MachineT $ do+  step <- runMachineT m `catchE` \e -> runMachineT (catchExcept (c e) c)+  case step of+    Stop -> return Stop+    Yield o m' -> return $ Yield o (catchExcept m' c)+    Await f k m' -> return $ Await (flip catchExcept c . f) k (catchExcept m' c)++-- | Given an environment and a 'MachineT' that runs in @'ReaderT' e m@,+-- produce a 'MachineT' that runs in @m@.+runReaderM :: Monad m => e -> MachineT (ReaderT e m) k o -> MachineT m k o+runReaderM e = fitM (flip runReaderT e)
src/Data/Machine/Mealy.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}  #ifndef MIN_VERSION_profunctors #define MIN_VERSION_profunctors(x,y,z) 0@@ -24,10 +26,20 @@ import Control.Applicative import Control.Arrow import Control.Category+import Control.Monad.Fix+import Control.Monad.Reader.Class+import Control.Monad.Zip+import Data.Distributive+import Data.Functor.Extend+import Data.Functor.Rep as Functor+import Data.List.NonEmpty as NonEmpty import Data.Machine.Plan import Data.Machine.Type import Data.Machine.Process+import Data.Profunctor.Closed import Data.Profunctor+import Data.Profunctor.Sieve+import Data.Profunctor.Rep as Profunctor import Data.Pointed import Data.Semigroup import Data.Sequence as Seq@@ -58,6 +70,10 @@   point b = r where r = Mealy (const (b, r))   {-# INLINE point #-} +instance Extend (Mealy a) where+  duplicated (Mealy m) = Mealy $ \a -> case m a of+    (_, b) -> (b, duplicated b)+ -- | A 'Mealy' machine modeled with explicit state. unfoldMealy :: (s -> a -> (b, s)) -> s -> Mealy a b unfoldMealy f = go where@@ -156,3 +172,44 @@     go xs = Mealy $ \(m,x) -> case driveMealy m xs x of       (c, _) -> (c, go (xs |> x))   {-# INLINE app #-}++instance Distributive (Mealy a) where+  distribute fm = Mealy $ \a -> let fp = fmap (`runMealy` a) fm in+     (fmap fst fp, collect snd fp)+  collect k fa = Mealy $ \a -> let fp = fmap (\x -> runMealy (k x) a) fa in+     (fmap fst fp, collect snd fp)++instance Functor.Representable (Mealy a) where+  type Rep (Mealy a) = NonEmpty a+  index = cosieve+  tabulate = cotabulate++instance Cosieve Mealy NonEmpty where+  cosieve m0 (a0 :| as0) = go m0 a0 as0 where+    go (Mealy m) a as = case m a of+      (b, m') -> case as of+        [] -> b+        a':as' -> go m' a' as'++instance Costrong Mealy where+  unfirst = unfirstCorep+  unsecond = unsecondCorep++instance Profunctor.Corepresentable Mealy where+  type Corep Mealy = NonEmpty+  cotabulate f0 = Mealy $ \a -> go [a] f0 where+     go as f = (f (NonEmpty.fromList (Prelude.reverse as)), Mealy $ \b -> go (b:as) f)++instance MonadFix (Mealy a) where+  mfix = mfixRep++instance MonadZip (Mealy a) where+  mzipWith = mzipWithRep+  munzip m = (fmap fst m, fmap snd m)++instance MonadReader (NonEmpty a) (Mealy a) where+  ask = askRep+  local = localRep++instance Closed Mealy where+  closed m = cotabulate $ \fs x -> cosieve m (fmap ($x) fs)
src/Data/Machine/Moore.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}  #ifndef MIN_VERSION_profunctors #define MIN_VERSION_profunctors(x,y,z) 0@@ -23,13 +25,21 @@  import Control.Applicative import Control.Comonad+import Control.Monad.Fix+import Control.Monad.Reader.Class+import Control.Monad.Zip import Data.Copointed+import Data.Distributive+import Data.Functor.Rep as Functor import Data.Machine.Plan import Data.Machine.Type import Data.Machine.Process import Data.Monoid import Data.Pointed+import Data.Profunctor.Closed import Data.Profunctor+import Data.Profunctor.Sieve+import Data.Profunctor.Rep as Profunctor import Prelude  -- | 'Moore' machines@@ -109,3 +119,39 @@   {-# INLINE (<@) #-}   _ @> n = n   {-# INLINE (@>) #-}++instance Distributive (Moore a) where+  distribute m = Moore (fmap extract m) (distribute . collect (\(Moore _ k) -> k) m)++instance Functor.Representable (Moore a) where+  type Rep (Moore a) = [a]+  index = cosieve+  tabulate = cotabulate+  {-# INLINE tabulate #-}++instance Cosieve Moore [] where+  cosieve (Moore b _) [] = b+  cosieve (Moore _ k) (a:as) = cosieve (k a) as++instance Costrong Moore where+  unfirst = unfirstCorep+  unsecond = unsecondCorep++instance Profunctor.Corepresentable Moore where+  type Corep Moore = []+  cotabulate f0 = go (f0 . reverse) where+    go f = Moore (f []) $ \a -> go (f.(a:))++instance MonadFix (Moore a) where+  mfix = mfixRep++instance MonadZip (Moore a) where+  mzipWith = mzipWithRep+  munzip m = (fmap fst m, fmap snd m)++instance MonadReader [a] (Moore a) where+  ask = askRep+  local = localRep++instance Closed Moore where+  closed m = cotabulate $ \fs x -> cosieve m (fmap ($x) fs)
src/Data/Machine/Pipe.hs view
@@ -119,13 +119,18 @@     Await k (Request b') _ -> runMachineT (fb' b' >>~ k)     Await k (Respond c) ff -> return $ Await (\c' -> fb' +>> k c') (Respond c) (fb' +>> ff) +-- | It is impossible for an `Exchange` to hold a `Void` value.+absurdExchange :: Exchange Void a b Void t -> c+absurdExchange (Request z) = absurd z+absurdExchange (Respond z) = absurd z+                               -- | Run a self-contained 'Effect', converting it back to the base monad. runEffect :: Monad m => Effect m o -> m [o] runEffect (MachineT m) = m >>= \v ->   case v of     Stop      -> return []     Yield o n -> liftM (o:) (runEffect n)-    _         -> error "Data.Machine.Pipe.runEffect: impossible situation"+    Await _ y _  -> absurdExchange y  -- | Like 'runEffect' but discarding any produced value. runEffect_ :: Monad m => Effect m o -> m ()@@ -133,4 +138,4 @@   case v of     Stop      -> return ()     Yield _ n -> runEffect_ n-    _         -> error "Data.Machine.Pipe.runEffect_: impossible situation"+    Await _ y _   -> absurdExchange y
src/Data/Machine/Plan.hs view
@@ -33,7 +33,7 @@  import Control.Applicative import Control.Category-import Control.Monad (ap, MonadPlus(..))+import Control.Monad (MonadPlus(..)) import Control.Monad.Trans.Class import Control.Monad.IO.Class import Control.Monad.State.Class@@ -97,8 +97,12 @@ instance Applicative (PlanT k o m) where   pure a = PlanT (\kp _ _ _ -> kp a)   {-# INLINE pure #-}-  (<*>) = ap+  m <*> n = PlanT $ \kp ke kr kf -> runPlanT m (\f -> runPlanT n (\a -> kp (f a)) ke kr kf) ke kr kf   {-# INLINE (<*>) #-}+  m *> n = PlanT $ \kp ke kr kf -> runPlanT m (\_ -> runPlanT n kp ke kr kf) ke kr kf+  {-# INLINE (*>) #-}+  m <* n = PlanT $ \kp ke kr kf -> runPlanT m (\a -> runPlanT n (\_ -> kp a) ke kr kf) ke kr kf+  {-# INLINE (<*) #-}  instance Alternative (PlanT k o m) where   empty = PlanT $ \_ _ _ kf -> kf@@ -107,9 +111,11 @@   {-# INLINE (<|>) #-}  instance Monad (PlanT k o m) where-  return a = PlanT (\kp _ _ _ -> kp a)+  return = pure   {-# INLINE return #-}   PlanT m >>= f = PlanT (\kp ke kr kf -> m (\a -> runPlanT (f a) kp ke kr kf) ke kr kf)+  (>>) = (*>)+  {-# INLINE (>>) #-}   fail _ = PlanT (\_ _ _ kf -> kf)   {-# INLINE (>>=) #-}
src/Data/Machine/Process.hs view
@@ -1,6 +1,11 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 0+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.Machine.Process@@ -60,6 +65,9 @@ import Data.Monoid import Data.Void import Prelude+#if !(MIN_VERSION_base(4,8,0))+  hiding (foldr)+#endif  infixr 9 <~ infixl 9 ~>@@ -155,12 +163,19 @@ ma ~> mp = mp <~ ma  -- | Feed a 'Process' some input.-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)+supply :: forall f m a b . (Foldable f, Monad m) => f a -> ProcessT m a b -> ProcessT m a b+supply xs = foldr go id xs+    where+      go :: a ->+            (ProcessT m a b -> ProcessT m a b) ->+            ProcessT m a b ->+            ProcessT m a b+      go x r m = MachineT $ do+         v <- runMachineT m+         case v of+           Stop -> return Stop+           Await f Refl _ -> runMachineT $ r (f x)+           Yield o k -> return $ Yield o (go x r k)  -- | -- Convert a machine into a process, with a little bit of help.@@ -215,12 +230,18 @@ -- 'fold' :: (a -> b -> a) -> a -> Process b a -- @ fold :: Category k => (a -> b -> a) -> a -> Machine (k b) a-fold func seed = scan func seed ~> final+fold func seed = construct $ go seed where+  go cur = do+    next <- await <|> yield cur *> stop+    go $! func cur next  -- | -- 'fold1' is a variant of 'fold' that has no starting value argument fold1 :: Category k => (a -> a -> a) -> Machine (k a) a-fold1 func = scan1 func ~> final+fold1 func = construct $ await >>= go where+  go cur = do+    next <- await <|> yield cur *> stop+    go $! func cur next  -- | Break each input into pieces that are fed downstream -- individually.@@ -281,8 +302,8 @@ intersperse :: Category k => a -> Machine (k a) a intersperse sep = construct $ await >>= go where   go cur = do-    next <- await <|> yield cur *> stop     yield cur+    next <- await     yield sep     go next
+ src/Data/Machine/Runner.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 0+#endif+module Data.Machine.Runner+    ( foldrT+    , foldlT+    , foldMapT+    , foldT+    , runT1++    -- Re-exports+    , runT+    , runT_ ) where++import Data.Machine.Type+import Control.Monad (liftM)+#if !MIN_VERSION_base (4,8,0)+import Data.Monoid (Monoid (..))+#endif++-- | Right fold over a stream. This will be lazy if the underlying+-- monad is.+--+-- @runT = foldrT (:) []@+foldrT :: Monad m => (o -> b -> b) -> b -> MachineT m k o -> m b+foldrT c n = go+    where+      go m = do+        step <- runMachineT m+        case step of+          Stop -> return n+          Yield o m' -> c o `liftM` go m'+          Await _ _ m' -> go m'++-- | Strict left fold over a stream.+foldlT :: Monad m => (b -> o -> b) -> b -> MachineT m k o -> m b+foldlT f = go+    where+      go !b m = do+        step <- runMachineT m+        case step of+          Stop -> return b+          Yield o m' -> go (f b o) m'+          Await _ _ m' -> go b m'++-- | Strict fold over a stream. Items are accumulated on the right:+--+-- @... ((f o1 <> f o2) <> f o3) ...@+--+-- Where this is expensive, use the dual monoid instead.+foldMapT :: (Monad m, Monoid r) => (o -> r) -> MachineT m k o -> m r+foldMapT f = foldlT (\b o -> mappend b (f o)) mempty++-- | Strict fold over a monoid stream. Items are accumulated on the+-- right:+--+-- @... ((o1 <> o2) <> o3) ...@+--+-- Where this is expensive, use the dual monoid instead.+--+-- @foldT = foldMapT id@+foldT :: (Monad m, Monoid o) => MachineT m k o -> m o+foldT = foldlT mappend mempty++-- | Run a machine with no input until it yields for the first time,+-- then stop it. This is intended primarily for use with accumulating+-- machines, such as the ones produced by 'fold' or 'fold1'+--+-- @runT1 m = getFirst <$> foldMapT (First . Just) (m ~> taking 1)@+runT1 :: Monad m => MachineT m k o -> m (Maybe o)+runT1 m = do+  step <- runMachineT m+  case step of+    Stop -> return Nothing+    Yield o _ -> return $ Just o+    Await _ _ m' -> runT1 m'
src/Data/Machine/Tee.hs view
@@ -15,10 +15,11 @@   ( -- * Tees     Tee, TeeT   , T(..)-  , tee+  , tee, teeT   , addL, addR   , capL, capR   , zipWithT+  , zipWith   ) where  import Data.Machine.Is@@ -26,7 +27,7 @@ import Data.Machine.Process import Data.Machine.Type import Data.Machine.Source-import Prelude hiding ((.),id)+import Prelude hiding ((.),id, zipWith)  ------------------------------------------------------------------------------- -- Tees@@ -59,6 +60,23 @@     Await g Refl fg ->       return $ Await (\b -> tee ma (g b) $ encased v) R $ tee ma fg $ encased v +-- | `teeT mt ma mb` Use a `Tee` to interleave or combine the outputs of `ma`+--   and `mb`+teeT :: Monad m => TeeT m a b c -> MachineT m k a -> MachineT m k b -> MachineT m k c+teeT mt ma mb = MachineT $ runMachineT mt >>= \v -> case v of+  Stop         -> return Stop+  Yield o k    -> return $ Yield o $ teeT k ma mb+  Await f L ff -> runMachineT ma >>= \u -> case u of+    Stop          -> runMachineT $ teeT ff stopped mb+    Yield a k     -> runMachineT $ teeT (f a) k mb+    Await g rq fg ->+      return $ Await (\r -> teeT mt (g r) mb) rq $ teeT mt fg mb+  Await f R ff -> runMachineT mb >>= \u -> case u of+    Stop          -> runMachineT $ teeT ff ma stopped+    Yield a k     -> runMachineT $ teeT (f a) ma k+    Await g rq fg ->+      return $ Await (\r -> teeT mt ma (g r)) rq $ teeT mt ma fg+ -- | Precompose a pipe onto the left input of a tee. addL :: Monad m => ProcessT m a b -> TeeT m b c d -> TeeT m a c d addL p = tee p echo@@ -89,3 +107,13 @@ zipWithT :: Monad m => (a -> b -> c) -> PlanT (T a b) c m () zipWithT f = do { a <- awaits L; b <- awaits R; yield $ f a b } {-# INLINE zipWithT #-}++-- | Zip together two inputs, then apply the given function,+--   halting as soon as either input is exhausted.+--   This implementation reads from the left, then the right+zipWith :: (a -> b -> c) -> Tee a b c+zipWith f = repeatedly $ do+  a <- awaits L+  b <- awaits R+  yield (f a b)+{-# INLINE zipWith #-}
src/Data/Machine/Type.hs view
@@ -27,7 +27,9 @@   -- ** Building machines from plans   , construct   , repeatedly+  , unfoldPlan   , before+  , preplan --  , sink    -- ** Deconstructing machines back into plans@@ -40,6 +42,8 @@   , fitM   , pass +  , starve+   , stopped    , stepMachine@@ -56,6 +60,7 @@ import Data.Machine.Plan import Data.Monoid hiding ((<>)) import Data.Pointed+import Data.Profunctor.Unsafe ((#.)) import Data.Semigroup import Prelude hiding ((.),id) @@ -91,11 +96,11 @@  -- | Pack a 'Step' of a 'Machine' into a 'Machine'. encased :: Monad m => Step k o (MachineT m k o) -> MachineT m k o-encased = MachineT . return+encased = MachineT #. return  -- | Transform a 'Machine' by looking at a single step of that machine. stepMachine :: Monad m => MachineT m k o -> (Step k o (MachineT m k o) -> MachineT m k' o') -> MachineT m k' o'-stepMachine m f = MachineT (runMachineT . f =<< runMachineT m)+stepMachine m f = MachineT (runMachineT #. f =<< runMachineT m)  instance Monad m => Functor (MachineT m k) where   fmap f (MachineT m) = MachineT (liftM f' m) where@@ -207,7 +212,7 @@ construct m = MachineT $ runPlanT m   (const (return Stop))   (\o k -> return (Yield o (MachineT k)))-  (\f k g -> return (Await (MachineT . f) k (MachineT g)))+  (\f k g -> return (Await (MachineT #. f) k (MachineT g)))   (return Stop)  -- | Generates a model that runs a machine until it stops, then start it up again.@@ -218,17 +223,34 @@   r = MachineT $ runPlanT m     (const (runMachineT r))     (\o k -> return (Yield o (MachineT k)))-    (\f k g -> return (Await (MachineT . f) k (MachineT g)))+    (\f k g -> return (Await (MachineT #. f) k (MachineT g)))     (return Stop) +-- | Unfold a stateful PlanT into a MachineT.+unfoldPlan :: Monad m => s -> (s -> PlanT k o m s) -> MachineT m k o+unfoldPlan s0 sp = r s0 where+  r s = MachineT $ runPlanT (sp s)+      (\sx -> runMachineT $ r sx)+      (\o k -> return (Yield o (MachineT k)))+      (\f k g -> return (Await (MachineT #. f) k (MachineT g)))+      (return Stop)+ -- | Evaluate a machine until it stops, and then yield answers according to the supplied model. before :: Monad m => MachineT m k o -> PlanT k o m a -> MachineT m k o before (MachineT n) m = MachineT $ runPlanT m   (const n)   (\o k -> return (Yield o (MachineT k)))-  (\f k g -> return (Await (MachineT . f) k (MachineT g)))+  (\f k g -> return (Await (MachineT #. f) k (MachineT g)))   (return Stop) +-- | Incorporate a 'Plan' into the resulting machine.+preplan :: Monad m => PlanT k o m (MachineT m k o) -> MachineT m k o+preplan m = MachineT $ runPlanT m+  runMachineT+  (\o k -> return (Yield o (MachineT k)))+  (\f k g -> return (Await (MachineT #. f) k (MachineT g)))+  (return Stop)+ -- | Given a handle, ignore all other inputs and just stream input from that handle. -- -- @@@ -244,6 +266,14 @@   a <- awaits k   yield a ++-- | Run a machine with no input until it stops, then behave as another machine.+starve :: Monad m => MachineT m k0 b -> MachineT m k b -> MachineT m k b+starve m cont = MachineT $ runMachineT m >>= \v -> case v of+  Stop            -> runMachineT cont -- Continue with cont instead of stopping+  Yield o r       -> return $ Yield o (starve r cont)+  Await _ _ r     -> runMachineT (starve r cont)+ -- | This is a stopped 'Machine' stopped :: Machine k b stopped = encased Stop@@ -259,7 +289,7 @@ --- result 'Plan'. This may be used when monadic binding of results is --- required. deconstruct :: Monad m => MachineT m k (Either a o) -> PlanT k o m a-deconstruct m = PlanT $ \r y a f -> +deconstruct m = PlanT $ \r y a f ->   let aux k = runPlanT (deconstruct k) r y a f   in runMachineT m >>= \v -> case v of        Stop -> f