packages feed

machines 0.2.3.1 → 0.2.4

raw patch · 9 files changed

+166/−12 lines, 9 filesdep +void

Dependencies added: void

Files

.gitignore view
@@ -11,3 +11,4 @@ *.hi *~ *#+.cabal-sandbox
README.markdown view
@@ -21,7 +21,7 @@ There is a lot of flexibility when building a machine in choosing between empowering the machine to run its own monadic effects or delegating that responsibility to a custom driver. -A port of this design to scala is available from runarorama/machines+A port of this design to scala is available from runarorama/scala-machines  Runar's slides are also available from https://dl.dropbox.com/u/4588997/Machines.pdf
machines.cabal view
@@ -1,6 +1,6 @@ name:          machines category:      Control, Enumerator-version:       0.2.3.1+version:       0.2.4 license:       BSD3 cabal-version: >= 1.10 license-file:  LICENSE@@ -41,11 +41,13 @@     profunctors  >= 3,     semigroups   >= 0.8.3,     transformers == 0.3.*,-    mtl          >= 2 && < 2.2+    mtl          >= 2 && < 2.2,+    void         >= 0.6.1 && < 0.7    exposed-modules:     Data.Machine     Data.Machine.Is+    Data.Machine.Fanout     Data.Machine.Mealy     Data.Machine.Moore     Data.Machine.Process
+ src/Data/Machine/Fanout.hs view
@@ -0,0 +1,72 @@+{-# 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((:|)))++-- | 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++-- | 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++-- | 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)++-- | 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)++-- | Share inputs with each of a list of processes in lockstep. If+-- none of the processes yields a value, the composite process will+-- itself yield 'mempty'. The idea is to provide a handle on steps+-- only executed for their side effects. For instance, if you want to+-- run a collection of 'ProcessT's that await but don't yield some+-- number of times, you can use 'fanOutSteps . map (fmap (const ()))'+-- 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)
src/Data/Machine/Mealy.hs view
@@ -129,6 +129,15 @@     Right b -> case runMealy n b of       (d, n') -> (d, m ||| n') +#if MIN_VERSION_profunctors(3,2,0)+instance Strong Mealy where+  first' = first++instance Choice Mealy where+  left' = left+  right' = right+#endif+ -- | Fast forward a mealy machine forward driveMealy :: Mealy a b -> Seq a -> a -> (b, Mealy a b) driveMealy m xs z = case viewl xs of
src/Data/Machine/Moore.hs view
@@ -23,7 +23,6 @@  import Control.Applicative import Control.Comonad-import Control.Monad import Data.Copointed import Data.Machine.Plan import Data.Machine.Type@@ -90,8 +89,8 @@ instance Monad (Moore a) where   return a = r where r = Moore a (const r)   {-# INLINE return #-}-  Moore a k >>= f = case f a of-    Moore b _ -> Moore b (k >=> f)+  k >>= f = j (fmap f k) where+    j (Moore a g) = Moore (extract a) (\x -> j $ fmap (\(Moore _ h) -> h x) (g x))   _ >> m = m  instance Copointed (Moore a) where
src/Data/Machine/Plan.hs view
@@ -52,7 +52,7 @@   { runPlanT :: forall r.       (a -> m r) ->                                     -- Done a       (o -> m r -> m r) ->                              -- Yield o (Plan k o a)-      (forall z. (z -> m r) -> k z -> m r -> m r) ->  -- forall z. Await (z -> Plan o a) (k z) (Plan k o a)+      (forall z. (z -> m r) -> k z -> m r -> m r) ->    -- forall z. Await (z -> Plan k o a) (k z) (Plan k o a)       m r ->                                            -- Fail       m r   }@@ -130,20 +130,20 @@   {-# INLINE get #-}   put = lift . put   {-# INLINE put #-}-#ifdef MIN_VERSION_mtl(2,1,0)+#if MIN_VERSION_mtl(2,1,0)   state f = PlanT $ \kp _ _ _ -> state f >>= kp   {-# INLINE state #-} #endif  instance MonadReader e m => MonadReader e (PlanT k o m) where   ask = lift ask-#ifdef MIN_VERSION_mtl(2,1,0)+#if MIN_VERSION_mtl(2,1,0)   reader = lift . reader #endif   local f m = PlanT $ \kp ke kr kf -> local f (runPlanT m kp ke kr kf)  instance MonadWriter w m  => MonadWriter w (PlanT k o m) where-#ifdef MIN_VERSION_mtl(2,1,0)+#if MIN_VERSION_mtl(2,1,0)   writer = lift . writer #endif   tell   = lift . tell
src/Data/Machine/Process.hs view
@@ -30,16 +30,23 @@   , droppingWhile   , takingWhile   , buffered+  , fold+  , scan+  , asParts+  , sinkPart_+  , autoM   ) where  import Control.Applicative import Control.Category import Control.Monad (liftM, when, replicateM_)-import Data.Foldable+import Control.Monad.Trans.Class+import Data.Foldable hiding (fold) import Data.Machine.Is import Data.Machine.Plan import Data.Machine.Type-import Prelude hiding ((.),id)+import Data.Void+import Prelude hiding ((.), id, mapM_)  infixr 9 <~ infixl 9 ~>@@ -155,3 +162,57 @@   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)++-- | +-- Construct a 'Process' from a left-scanning operation.+--+-- Like 'fold', but yielding intermediate values.+--+-- @+-- 'scan' :: (a -> b -> a) -> a -> Process b a+-- @  +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++-- | +-- Construct a 'Process' from a left-folding operation.+--+-- Like 'scan', but only yielding the final value.+--+-- @+-- 'fold' :: (a -> b -> a) -> a -> Process b a+-- @+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)++-- | Break each input into pieces that are fed downstream+-- individually.+asParts :: Foldable f => Process (f a) a+asParts = repeatedly $ await >>= mapM_ yield++-- | @sinkPart_ toParts sink@ creates a process that uses the+-- @toParts@ function to break input into a tuple of @(passAlong,+-- sinkPart)@ for which the second projection is given to the supplied+-- @sink@ 'ProcessT' (that produces no output) while the first+-- projection is passed down the pipeline.+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)++-- | Apply a monadic function to each element of a 'ProcessT'.+autoM :: Monad m => (a -> m b) -> ProcessT m a b+autoM f = repeatedly $ await >>= lift . f >>= yield
src/Data/Machine/Type.hs view
@@ -32,6 +32,7 @@    -- * Reshaping machines   , fit+  , fitM   , pass    , stopped@@ -169,6 +170,15 @@   f' (Yield o k)     = Yield o (fit f k)   f' Stop            = Stop   f' (Await g kir h) = Await (fit f . g) (f kir) (fit f h)++--- | Connect machine transformers over different monads using a monad+--- morphism.+fitM :: (Monad m, Monad m')+     => (forall a. m a -> m' a) -> MachineT m k o -> MachineT m' k o+fitM f (MachineT m) = MachineT $ f (liftM aux m)+  where aux Stop = Stop+        aux (Yield o k) = Yield o (fitM f k)+        aux (Await g kg gg) = Await (fitM f . g) kg (fitM f gg)  -- | Compile a machine to a model. construct :: Monad m => PlanT k o m a -> MachineT m k o