machines 0.4.1 → 0.5.1

raw patch · 14 files changed

+272/−23 lines, 14 filesdep +conduit-combinatorsdep −hastachedep −statisticsdep ~conduitdep ~criteriondep ~mtl

Dependencies added: conduit-combinators

Dependencies removed: hastache, statistics

Dependency ranges changed: conduit, criterion, mtl, pipes, profunctors

Files

• CHANGELOG.markdown +13/−0
• benchmarks/Benchmarks.hs +5/−1
• examples/Examples.hs +12/−0
• machines.cabal +11/−10
• src/Data/Machine/Fanout.hs +1/−0
• src/Data/Machine/Group.hs +64/−0
• src/Data/Machine/Is.hs +1/−0
• src/Data/Machine/Moore.hs +1/−0
• src/Data/Machine/Pipe.hs +136/−0
• src/Data/Machine/Plan.hs +2/−2
• src/Data/Machine/Process.hs +5/−5
• src/Data/Machine/Stack.hs +2/−4
• src/Data/Machine/Type.hs +18/−1
• tests/doctests.hs +1/−0

@@ -1,3 +1,16 @@+0.5.1+-----+* `profunctors` 5 support+* GHC 7.10 warnings have been cleaned up++0.5+---+* Major bug fix (and semantic change) for `Plan`'s `(<|>)`.++0.4.2+-----+* Add `Monoid` and `Semigroups` instances for `MachineT`+ 0.4.1 ----- * Support `void` 0.7, fixed upper bounds on dependencies going forward.

@@ -4,6 +4,7 @@ import Control.Monad.Identity import Criterion.Main import qualified Data.Conduit      as C+import qualified Data.Conduit.Combinators as CC import qualified Data.Conduit.List as C import qualified Data.Machine      as M import qualified Pipes             as P@@ -44,11 +45,12 @@   , bgroup "dropWhile"       [ bench "machines" $ whnf drainM (M.droppingWhile (<= value))       , bench "pipes" $ whnf drainP (P.dropWhile (<= value))+      , bench "conduit" $ whnf drainC (CC.dropWhile (<= value))       ]   , bgroup "scan"       [ bench "machines" $ whnf drainM (M.scan (+) 0)       , bench "pipes" $ whnf drainP (P.scan (+) 0 id)-      , bench "conduit" $ whnf drainC (C.scanl (\a s -> let b = a+s in (b,b)) 0)+      , bench "conduit" $ whnf drainC (CC.scanl (+) 0)       ]   , bgroup "take"       [ bench "machines" $ whnf drainM (M.taking value)@@ -58,9 +60,11 @@   , bgroup "takeWhile"       [ bench "machines" $ whnf drainM (M.takingWhile (<= value))       , bench "pipes" $ whnf drainP (P.takeWhile (<= value))+      , bench "conduit" $ whnf drainSC (CC.takeWhile (<= value) C.=$= C.sinkNull)       ]   , bgroup "fold"       [ bench "machines" $ whnf drainM (M.fold (+) 0)       , bench "pipes" $ whnf (P.fold (+) 0 id) sourceP+      , bench "conduit" $ whnf drainSC (C.fold (+) 0)       ]   ]

@@ -6,6 +6,7 @@ import Control.Exception import Control.Monad.Trans import Data.Machine+import Data.Machine.Group import System.IO  -- this slurp slurps until an eof exception is raised.@@ -89,6 +90,17 @@   t = tee (source [1..]) (getFileLines path echo) lineNumsT   lineNumsT :: MachineT IO (T Integer String) String   lineNumsT = repeatedly $ zipWithT $ \i s -> show i ++ ": " ++ s++uniq :: Bool+uniq = run (supply xs uniqMachine) == [1,2,3] where+  -- | Unix's "uniq" command using groupingOn+  -- (==)  means "groups are contiguous values"+  -- final means "run the 'final' machine over each group"+  uniqMachine :: (Monad m, Eq a) => ProcessT m a a+  uniqMachine = groupingOn (==) final ++  xs :: [Int]+  xs = [1,2,2,3,3,3]  {- def lineWordCount(fileName: String) =

@@ -1,6 +1,6 @@ name:          machines category:      Control, Enumerator-version:       0.4.1+version:       0.5.1 license:       BSD3 cabal-version: >= 1.10 license-file:  LICENSE@@ -41,7 +41,7 @@     containers   >= 0.3   && < 0.6,     free         >= 3.1.1 && < 5,     pointed      >= 3     && < 5,-    profunctors  >= 3     && < 5,+    profunctors  >= 3     && < 6,     semigroups   >= 0.8.3 && < 1,     transformers >= 0.3   && < 0.5,     mtl          >= 2     && < 2.3,@@ -60,6 +60,8 @@     Data.Machine.Tee     Data.Machine.Type     Data.Machine.Wye+    Data.Machine.Group+    Data.Machine.Pipe    default-language: Haskell2010   other-extensions:@@ -81,7 +83,7 @@     base == 4.*,     directory >= 1.0 && < 1.3,     doctest >= 0.8 && <= 0.10,-    filepath >= 1.3 && < 1.4+    filepath >= 1.3 && < 1.5   ghc-options: -Wall -Werror -threaded   hs-source-dirs: tests @@ -93,11 +95,10 @@   ghc-options:      -O2 -rtsopts -threaded    build-depends:-    base == 4.*,-    conduit == 1.0.17.1,-    criterion == 0.6.2.*,-    hastache < 0.6,+    base                == 4.*,+    conduit             >= 1.0   && < 1.3,+    conduit-combinators >= 0.2.5 && < 0.4,+    criterion           >= 0.6   && < 1.1,     machines,-    mtl == 2.1.2,-    pipes == 4.1.0,-    statistics < 0.11+    mtl                 >= 2     && < 2.3,+    pipes               >= 4     && < 4.2

@@ -10,6 +10,7 @@ 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

@@ -0,0 +1,64 @@+{-# LANGUAGE GADTs #-}+module Data.Machine.Group+  ( groupingOn+  , taggedBy+  , partitioning+  , starve+  , awaitUntil+  )where+import Data.Machine++isLeft :: Either a b -> Bool+isLeft = either (const True) (const False)++-- | Using a function to signal group changes, apply a machine independently over each group.+groupingOn :: Monad m => (a -> a -> Bool) -> ProcessT m a b -> ProcessT m a b+groupingOn f m = taggedBy f ~> partitioning m++-- | Mark a transition point between two groups as a function of adjacent elements.+-- @+-- 'runT' ('supply' [1,2,2] ('taggedBy' (==))) == [Right 1, Left (), Right 2, Right 2]+-- @+taggedBy :: Monad m => (a -> a -> Bool) -> ProcessT m a (Either () a)+taggedBy f = construct $ await >>= go+  where go x = do+          yield (Right x)+          y <- await+          if not (f x y) then (yield (Left ()) >> go y) else go y+++-- | Run a machine multiple times over partitions of the input stream specified by +-- Left () values.+partitioning :: Monad m => ProcessT m a b -> ProcessT m (Either () a) b+partitioning s = go s where+  go m = MachineT $ runMachineT m >>= \v -> case v of+    -- Machine stops (possibly before inputs)+    Stop            -> runMachineT $ awaitUntil isLeft (const $ go s)++    -- Machine yields a value+    Yield o r       -> return $ Yield o (go r)++    -- Machine waits for a value+    Await f Refl r  -> return $ Await g Refl (starve r $ encased Stop)+      where+        -- No change: unwrap input and give to underlying machine.+        g (Right a) = go (f a)+        -- New group: starve r, then wait for more input (restarting machine)+        -- NOTE: if Left () happens with no more input, this will be wrong-ish(?)+        -- Meaning of "Left ()" is "stop old machine and immediately start new one."+        -- 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.+-- | If await fails, stop.+awaitUntil :: Monad m => (a -> Bool) -> (a -> ProcessT m a b) -> ProcessT m a b+awaitUntil f cont = encased $ Await g Refl (encased Stop)+  where g a = if f a then cont a else awaitUntil f cont

@@ -16,6 +16,7 @@  import Control.Category import Data.Monoid+import Prelude  -- | Witnessed type equality data Is a b where

@@ -30,6 +30,7 @@ import Data.Monoid import Data.Pointed import Data.Profunctor+import Prelude  -- | 'Moore' machines data Moore a b = Moore b (a -> Moore a b)

@@ -0,0 +1,136 @@+{-# LANGUAGE GADTs      #-}+{-# LANGUAGE Rank2Types #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Machine.Pipe+-- Copyright   :  (C) 2015 Yorick Laupa, Gabriel Gonzalez+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Yorick Laupa <yo.eight@gmail.com>+-- Stability   :  provisional+-- Portability :  Rank-2 Types, GADTs+--+-- Allows bidirectional communication between two MachineT. Exposed the+-- same interface of Pipes library.+----------------------------------------------------------------------------+module Data.Machine.Pipe where++import Control.Monad++import Data.Void++import Data.Machine.Plan+import Data.Machine.Type++infixl 8 >~>+infixl 7 >+>+infixl 7 >>~+infixr 6 +>>++data Exchange a' a b' b c where+  Request :: a' -> Exchange a' a b' b a+  Respond :: b  -> Exchange a' a b' b b'++type Proxy a' a b' b m c = MachineT m (Exchange a' a b' b) c++-- | 'Effect's neither 'request' nor 'respond'+type Effect m r = Proxy Void () () Void m r++-- | @Client a' a@ sends requests of type @a'@ and receives responses of+--   type @a@. 'Client's only 'request' and never 'respond'.+type Client a' a m r = Proxy a' a () Void m r++-- | @Server b' b@ receives requests of type @b'@ and sends responses of type+--   @b@. 'Server's only 'respond' and never 'request'.+type Server b' b m r = Proxy Void () b' b m r++-- | Like 'Effect', but with a polymorphic type+type Effect' m r = forall x' x y' y . Proxy x' x y' y m r++-- | Like 'Server', but with a polymorphic type+type Server' b' b m r = forall x' x . Proxy x' x b' b m r++-- | Like 'Client', but with a polymorphic type+type Client' a' a m r = forall y' y . Proxy a' a y' y m r++-- | Send a value of type a' upstream and block waiting for a reply of type a.+--  'request' is the identity of the request category.+request :: a' -> PlanT (Exchange a' a y' y) o m a+request a = awaits (Request a)++-- | Send a value of type a downstream and block waiting for a reply of type a'+--  'respond' is the identity of the respond category.+respond :: a -> PlanT (Exchange x' x a' a) o m a'+respond a = awaits (Respond a)++-- | Forward responses followed by requests.+--   'push' is the identity of the push category.+push :: Monad m => a -> Proxy a' a a' a m r+push = construct . go+  where+    go = respond >=> request >=> go++-- | Compose two proxies blocked while 'request'ing data, creating a new proxy+--   blocked while 'request'ing data.+--   ('>~>') is the composition operator of the push category.+(>~>) :: Monad m+      => (_a -> Proxy a' a b' b m r)+      -> (b -> Proxy b' b c' c m r)+      -> _a -> Proxy a' a c' c m r+(fa >~> fb) a = fa a >>~ fb++-- | (p >>~ f) pairs each 'respond' in p with an 'request' in f.+(>>~) :: Monad m+      => Proxy a' a b' b m r+      -> (b -> Proxy b' b c' c m r)+      -> Proxy a' a c' c m r+pm >>~ fb = MachineT $ runMachineT pm >>= \p ->+  case p of+    Stop                    -> return Stop+    Yield r n               -> return $ Yield r (n >>~ fb)+    Await k (Request a') ff -> return $ Await (\a -> k a >>~ fb) (Request a') (ff >>~ fb)+    Await k (Respond b) _   -> runMachineT (k +>> fb b)++-- | Forward requests followed by responses.+--   'pull' is the identity of the pull category.+pull :: Monad m => a' -> Proxy a' a a' a m r+pull = construct . go+  where+    go = request >=> respond >=> go++-- | Compose two proxies blocked in the middle of 'respond'ing, creating a new+--   proxy blocked in the middle of 'respond'ing.+--   ('>+>') is the composition operator of the pull category.+(>+>) :: Monad m+      => (b' -> Proxy a' a b' b m r)+      -> (_c' -> Proxy b' b c' c m r)+      -> _c' -> Proxy a' a c' c m r+(fb' >+> fc') c' = fb' +>> fc' c'++-- | (f +>> p) pairs each 'request' in p with a 'respond' in f.+(+>>) :: Monad m+      => (b' -> Proxy a' a b' b m r)+      -> Proxy b' b c' c m r+      -> Proxy a' a c' c m r+fb' +>> pm = MachineT $ runMachineT pm >>= \p ->+  case p of+    Stop                   -> return Stop+    Yield r n              -> return $ Yield r (fb' +>> n)+    Await k (Request b') _ -> runMachineT (fb' b' >>~ k)+    Await k (Respond c) ff -> return $ Await (\c' -> fb' +>> k c') (Respond c) (fb' +>> ff)++-- | 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"++-- | Like 'runEffect' but discarding any produced value.+runEffect_ :: Monad m => Effect m o -> m ()+runEffect_ (MachineT m) = m >>= \v ->+  case v of+    Stop      -> return ()+    Yield _ n -> runEffect_ n+    _         -> error "Data.Machine.Pipe.runEffect_: impossible situation"

@@ -62,7 +62,7 @@ -- | A @'Plan' k o a@ is a specification for a pure 'Machine', that reads inputs selected by @k@ -- with types based on @i@, writes values of type @o@, and has intermediate results of type @a@. ----- A @'PlanT' k o a@ can be used as a @'PlanT' k o m a@ for any @'Monad' m@.+-- A @'Plan' k o a@ can be used as a @'PlanT' k o m a@ for any @'Monad' m@. -- -- It is perhaps easier to think of 'Plan' in its un-cps'ed form, which would -- look like:@@ -103,7 +103,7 @@ instance Alternative (PlanT k o m) where   empty = PlanT $ \_ _ _ kf -> kf   {-# INLINE empty #-}-  PlanT m <|> PlanT n = PlanT $ \kp ke kr kf -> m kp ke (\ks kir _ -> kr ks kir (n kp ke kr kf)) (n kp ke kr kf)+  PlanT m <|> PlanT n = PlanT $ \kp ke kr kf -> m kp ke kr (n kp ke kr kf)   {-# INLINE (<|>) #-}  instance Monad (PlanT k o m) where

@@ -50,16 +50,16 @@   ) where  import Control.Applicative-import Control.Category+import Control.Category (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.Monoid (Monoid(..))+import Data.Monoid import Data.Void-import Prelude hiding ((.), id, mapM_)+import Prelude  infixr 9 <~ infixl 9 ~>@@ -77,7 +77,7 @@ -- 'Monad' @m@. type ProcessT m a b = MachineT m (Is a) b --- | An 'Automaton' is can be automatically lifted into a 'Process'+-- | An 'Automaton' can be automatically lifted into a 'Process' class Automaton k where   auto :: k a b -> Process a b @@ -225,7 +225,7 @@ -- | Break each input into pieces that are fed downstream -- individually. asParts :: Foldable f => Process (f a) a-asParts = repeatedly $ await >>= mapM_ yield+asParts = repeatedly $ await >>= traverse_ yield  -- | @sinkPart_ toParts sink@ creates a process that uses the -- @toParts@ function to break input into a tuple of @(passAlong,

@@ -48,17 +48,15 @@ -- of pushing inputs back. stack :: Monad m => MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o stack up down =-  advance1 down $ \stepD     ->+  stepMachine down $ \stepD     ->   case stepD of     Stop                     -> stopped     Yield o down'            -> encased (Yield o (up `stack` down'))     Await down' (Push a) _   -> encased (Yield a up) `stack` down' ()     Await down' Pop ffD      ->-      advance1 up $ \stepU   ->+      stepMachine up $ \stepU   ->       case stepU of         Stop                 -> stopped `stack` ffD         Yield o up'          -> up'     `stack` down' o         Await up' req ffU    -> encased (Await (\a -> up' a `stack` encased stepD) req                                                (      ffU   `stack` encased stepD))-  where-  advance1 m f = MachineT (runMachineT m >>= runMachineT . f)

@@ -42,6 +42,8 @@    , stopped +  , stepMachine+   -- * Applicative Machines   , Appliance(..)   ) where@@ -52,8 +54,9 @@ import Data.Foldable import Data.Functor.Identity import Data.Machine.Plan-import Data.Monoid+import Data.Monoid hiding ((<>)) import Data.Pointed+import Data.Semigroup import Prelude hiding ((.),id)  -------------------------------------------------------------------------------@@ -90,6 +93,10 @@ encased :: Monad m => Step k o (MachineT m k o) -> MachineT m k o 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)+ instance Monad m => Functor (MachineT m k) where   fmap f (MachineT m) = MachineT (liftM f' m) where     f' (Yield o xs)    = Yield (f o) (f <$> xs)@@ -98,6 +105,16 @@  instance Monad m => Pointed (MachineT m k) where   point = repeatedly . yield++instance Monad m => Semigroup (MachineT m k o) where+  a <> b = stepMachine a $ \step -> case step of+    Yield o a'    -> encased (Yield o (mappend a' b))+    Await k kir e -> encased (Await (\x -> k x <> b) kir (e <> b))+    Stop          -> b++instance Monad m => Monoid (MachineT m k o) where+  mempty        = stopped+  mappend       = (<>)  -- | An input type that supports merging requests from multiple machines. class Appliance k where

@@ -7,6 +7,7 @@ import System.Directory import System.FilePath import Test.DocTest+import Prelude  main :: IO () main = getSources >>= \sources -> doctest $