diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2012 Edward Kmett, Runar Bjarnason, Paul Chiusano +Copyright 2012-2015 Edward Kmett, Runar Bjarnason, Paul Chiusano All rights reserved. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -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* diff --git a/machines.cabal b/machines.cabal --- a/machines.cabal +++ b/machines.cabal @@ -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 diff --git a/src/Data/Machine/Fanout.hs b/src/Data/Machine/Fanout.hs --- a/src/Data/Machine/Fanout.hs +++ b/src/Data/Machine/Fanout.hs @@ -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 diff --git a/src/Data/Machine/Group.hs b/src/Data/Machine/Group.hs --- a/src/Data/Machine/Group.hs +++ b/src/Data/Machine/Group.hs @@ -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. diff --git a/src/Data/Machine/Lift.hs b/src/Data/Machine/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Data/Machine/Lift.hs @@ -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) diff --git a/src/Data/Machine/Mealy.hs b/src/Data/Machine/Mealy.hs --- a/src/Data/Machine/Mealy.hs +++ b/src/Data/Machine/Mealy.hs @@ -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) diff --git a/src/Data/Machine/Moore.hs b/src/Data/Machine/Moore.hs --- a/src/Data/Machine/Moore.hs +++ b/src/Data/Machine/Moore.hs @@ -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) diff --git a/src/Data/Machine/Pipe.hs b/src/Data/Machine/Pipe.hs --- a/src/Data/Machine/Pipe.hs +++ b/src/Data/Machine/Pipe.hs @@ -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 diff --git a/src/Data/Machine/Plan.hs b/src/Data/Machine/Plan.hs --- a/src/Data/Machine/Plan.hs +++ b/src/Data/Machine/Plan.hs @@ -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 (>>=) #-} diff --git a/src/Data/Machine/Process.hs b/src/Data/Machine/Process.hs --- a/src/Data/Machine/Process.hs +++ b/src/Data/Machine/Process.hs @@ -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 diff --git a/src/Data/Machine/Runner.hs b/src/Data/Machine/Runner.hs new file mode 100644 --- /dev/null +++ b/src/Data/Machine/Runner.hs @@ -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' diff --git a/src/Data/Machine/Tee.hs b/src/Data/Machine/Tee.hs --- a/src/Data/Machine/Tee.hs +++ b/src/Data/Machine/Tee.hs @@ -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 #-} diff --git a/src/Data/Machine/Type.hs b/src/Data/Machine/Type.hs --- a/src/Data/Machine/Type.hs +++ b/src/Data/Machine/Type.hs @@ -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