machines (empty) → 0.1

raw patch · 21 files changed

+1237/−0 lines, 21 filesdep +basedep +comonaddep +containerssetup-changed

Dependencies added: base, comonad, containers, directory, doctest, filepath, free, mtl, profunctors, semigroups, transformers

Files

• .ghci +1/−0
• .gitignore +4/−0
• .travis.yml +8/−0
• .vim.custom +21/−0
• CHANGELOG.markdown +3/−0
• LICENSE +30/−0
• README.markdown +30/−0
• Setup.lhs +7/−0
• config +16/−0
• machines.cabal +74/−0
• src/Data/Machine.hs +32/−0
• src/Data/Machine/Is.hs +42/−0
• src/Data/Machine/Mealy.hs +116/−0
• src/Data/Machine/Moore.hs +75/−0
• src/Data/Machine/Plan.hs +147/−0
• src/Data/Machine/Process.hs +149/−0
• src/Data/Machine/Tee.hs +80/−0
• src/Data/Machine/Type.hs +234/−0
• src/Data/Machine/Unread.hs +37/−0
• src/Data/Machine/Wye.hs +103/−0
• tests/doctests.hs +28/−0

@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h

@@ -0,0 +1,4 @@+dist+TAGS+tags+docs

@@ -0,0 +1,8 @@+language: haskell+# Use this when hackage is down.+# before_install:+#   - mkdir -p ~/.cabal+#   - cp config ~/.cabal/config+#   - cabal update+notifications:+  irc: "irc.freenode.org#haskell-lens"

@@ -0,0 +1,21 @@+" Add the following to your .vimrc to automatically load this on startup+" if filereadable(".vim.custom")+"     so .vim.custom+" endif++function StripTrailingWhitespace()+  let myline=line(".")+  let mycolumn = col(".")+  silent %s/  *$//+  call cursor(myline, mycolumn)+endfunction++syntax on+set tags=TAGS;/+set listchars=tab:‗‗,trail:‗+set list++map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"

@@ -0,0 +1,3 @@+0.1+---+* Initial release

@@ -0,0 +1,30 @@+Copyright 2012 Edward Kmett, Runar Bjarnason, Paul Chiusano++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,30 @@+machines+========++[![Build Status](https://secure.travis-ci.org/ekmett/machines.png?branch=master)](http://travis-ci.org/ekmett/machines)++Machines are demand driven input sources like pipes or conduits, but can support multiple inputs.++You design a `Machine` by writing a `Plan`. You then `construct` the machine.++Simple machines that take one input are called a `Process` and processes form a `Category`. More generally you can attach a+`Process` to the output of any type of `Machine`, yielding a new `Machine`.++More complicated machines provide other ways of connecting to them.++Typically the use of machines proceeds by using simple plans into machine `Tee`s and `Wye`s, capping many of the inputs to+those with possibly monadic sources, feeding the rest input (possibly repeatedly) and calling `run` or `runT` to get the+answers out.++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.+++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett

@@ -0,0 +1,7 @@+#!/usr/bin/runhaskell+> module Main (main) where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain

@@ -0,0 +1,16 @@+-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix+--+-- This is particularly useful for travis-ci to get it to stop complaining+-- about a broken build when everything is still correct on our end.+--+-- This uses Luite Stegman's mirror of hackage provided by his 'hdiff' site instead+--+-- To enable this, uncomment the before_script in .travis.yml++remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive+remote-repo-cache: ~/.cabal/packages+world-file: ~/.cabal/world+build-summary: ~/.cabal/logs/build.log+remote-build-reporting: anonymous+install-dirs user+install-dirs global

@@ -0,0 +1,74 @@+name:          machines+category:      Control, Enumerator+version:       0.1+license:       BSD3+cabal-version: >= 1.10+license-file:  LICENSE+author:        Edward A. Kmett, Rúnar Bjarnason+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     provisional+homepage:      http://github.com/ekmett/machines/+bug-reports:   http://github.com/ekmett/machines/issues+copyright:     Copyright (C) 2012 Edward A. Kmett+synopsis:      Networked stream transducers+description:   Networked stream transducers+build-type:    Simple+tested-with:   GHC == 7.4.1+extra-source-files:+  .travis.yml+  .ghci+  .gitignore+  .vim.custom+  config+  README.markdown+  CHANGELOG.markdown++source-repository head+  type: git+  location: git://github.com/ekmett/machines.git++library+  build-depends:+    base         == 4.*,+    comonad      == 3.0.*,+    containers   >= 0.3   && < 0.6,+    free         >= 3.1.1 && < 3.2,+    profunctors  == 3.0.*,+    semigroups   >= 0.8.3 && < 0.9,+    transformers == 0.3.*,+    mtl          >= 2.1.1 && < 2.2++  exposed-modules:+    Data.Machine+    Data.Machine.Is+    Data.Machine.Mealy+    Data.Machine.Moore+    Data.Machine.Process+    Data.Machine.Plan+    Data.Machine.Tee+    Data.Machine.Type+    Data.Machine.Unread+    Data.Machine.Wye++  default-language: Haskell2010+  other-extensions:+    FlexibleInstances+    GADTs+    MultiParamTypeClasses+    Rank2Types+    UndecidableInstances++  ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields+  hs-source-dirs: src++-- Verify the results of the examples+test-suite doctests+  type:    exitcode-stdio-1.0+  main-is: doctests.hs+  build-depends:+    base == 4.*,+    directory >= 1.0 && < 1.2,+    doctest >= 0.8 && <= 0.9,+    filepath >= 1.3 && < 1.4+  ghc-options: -Wall -Werror -threaded+  hs-source-dirs: tests

@@ -0,0 +1,32 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Machine+-- Copyright   :  (C) 2012 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  non-portable+--+----------------------------------------------------------------------------+module Data.Machine+  ( module Data.Machine.Is+  , module Data.Machine.Moore+  , module Data.Machine.Mealy+  , module Data.Machine.Plan+  , module Data.Machine.Process+  , module Data.Machine.Source+  , module Data.Machine.Tee+  , module Data.Machine.Type+  , module Data.Machine.Wye+  ) where++import Data.Machine.Is+import Data.Machine.Mealy+import Data.Machine.Moore+import Data.Machine.Plan+import Data.Machine.Process+import Data.Machine.Source+import Data.Machine.Tee+import Data.Machine.Type+import Data.Machine.Wye

@@ -0,0 +1,42 @@+{-# LANGUAGE GADTs, TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Machine.Is+-- Copyright   :  (C) 2012 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  GADTs, Type Families+--+----------------------------------------------------------------------------+module Data.Machine.Is+  ( Is(..)+  ) where++import Control.Category+import Data.Monoid++-- | Witnessed type equality+data Is a b where+  Refl :: Is a a++instance Show (Is a b) where+  showsPrec _ Refl = showString "Refl"++instance Eq (Is a b) where+  Refl == Refl = True++instance Ord (Is a b) where+  Refl `compare` Refl = EQ++instance (a ~ b) => Monoid (Is a b) where+  mempty = Refl+  mappend Refl Refl = Refl++instance (a ~ b) => Read (Is a b) where+  readsPrec d = readParen (d > 10) (\r -> [(Refl,s) | ("Refl",s) <- lex r ])++instance Category Is where+  id = Refl+  Refl . Refl = Refl

@@ -0,0 +1,116 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Machine.Mealy+-- Copyright   :  (C) 2012 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- <http://en.wikipedia.org/wiki/Mealy_machine>+----------------------------------------------------------------------------+module Data.Machine.Mealy+  ( Mealy(..)+  , unfoldMealy+  , logMealy+  ) where++import Control.Applicative+import Control.Arrow+import Control.Category+import Data.Machine.Plan+import Data.Machine.Type+import Data.Machine.Process+import Data.Profunctor+import Data.Semigroup+import Data.Sequence as Seq+import Prelude hiding ((.),id)++-- | 'Mealy' machines+newtype Mealy a b = Mealy { runMealy :: a -> (b, Mealy a b) }++instance Functor (Mealy a) where+  fmap f (Mealy m) = Mealy $ \a -> case m a of+    (b, n) -> (f b, fmap f n)++instance Applicative (Mealy a) where+  pure b = r where r = Mealy (const (b, r))+  Mealy m <*> Mealy n = Mealy $ \a -> case m a of+    (f, m') -> case n a of+       (b, n') -> (f b, m' <*> n')+  m <* _ = m+  _ *> n = n++-- | A 'Mealy' machine modeled with explicit state.+unfoldMealy :: (s -> a -> (b, s)) -> s -> Mealy a b+unfoldMealy f = go where+  go s = Mealy $ \a -> case f s a of+    (b, t) -> (b, go t)++-- | slow diagonalization+instance Monad (Mealy a) where+  return b = r where r = Mealy (const (b, r))+  m >>= f = Mealy $ \a -> case runMealy m a of+    (b, m') -> (fst (runMealy (f b) a), snd (runMealy (m' >>= f) a))+  _ >> n = n++instance Profunctor Mealy where+  rmap = fmap+  lmap f (Mealy m) = Mealy $ \a -> case m (f a) of+    (b, n) -> (b, lmap f n)++instance Automaton Mealy where+  auto = construct . go where+    go (Mealy f) = await >>= \a -> case f a of+      (b, m) -> do+         yield b+         go m++instance Category Mealy where+  id = Mealy (\a -> (a, id))+  Mealy bc . Mealy ab = Mealy $ \ a -> case ab a of+    (b, nab) -> case bc b of+      (c, nbc) -> (c, nbc . nab)++instance Arrow Mealy where+  arr f = r where r = Mealy (\a -> (f a, r))+  first (Mealy m) = Mealy $ \(a,c) -> case m a of+    (b, n) -> ((b, c), first n)++instance ArrowChoice Mealy where+  left m = Mealy $ \a -> case a of+    Left l  -> case runMealy m l of+      (b, m') -> (Left b, left m')+    Right r -> (Right r, left m)+  right m = Mealy $ \a -> case a of+    Left l -> (Left l, right m)+    Right r -> case runMealy m r of+      (b, m') -> (Right b, right m')+  m +++ n = Mealy $ \a -> case a of+    Left b -> case runMealy m b of+      (c, m') -> (Left c, m' +++ n)+    Right b -> case runMealy n b of+      (c, n') -> (Right c, m +++ n')+  m ||| n = Mealy $ \a -> case a of+    Left b -> case runMealy m b of+      (d, m') -> (d, m' ||| n)+    Right b -> case runMealy n b of+      (d, n') -> (d, m ||| n')++-- | 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+  y :< ys -> case runMealy m y of+    (_, n) -> driveMealy n ys z+  EmptyL  -> runMealy m z++-- | Accumulate history.+logMealy :: Semigroup a => Mealy a a+logMealy = Mealy $ \a -> (a, h a) where+  h a = Mealy $ \b -> let c = a <> b in (c, h c)++instance ArrowApply Mealy where+  app = go Seq.empty where+    go xs = Mealy $ \(m,x) -> case driveMealy m xs x of+      (c, _) -> (c, go (xs |> x))

@@ -0,0 +1,75 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Machine.Moore+-- Copyright   :  (C) 2012 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- <http://en.wikipedia.org/wiki/Moore_machine>+----------------------------------------------------------------------------+module Data.Machine.Moore+  ( Moore(..)+  , logMoore+  , unfoldMoore+  ) where++import Control.Applicative+import Control.Comonad+import Control.Monad+import Data.Machine.Plan+import Data.Machine.Type+import Data.Machine.Process+import Data.Monoid+import Data.Profunctor++-- | 'Moore' machines+data Moore a b = Moore b (a -> Moore a b)++-- | Accumulate the input as a sequence.+logMoore :: Monoid m => Moore m m+logMoore = h mempty where+  h m = Moore m (\a -> h (m <> a))++-- | Construct a Moore machine from a state valuation and transition function+unfoldMoore :: (s -> (b, a -> s)) -> s -> Moore a b+unfoldMoore f = go where+  go s = case f s of+    (b, g) -> Moore b (go . g)++instance Automaton Moore where+  auto = construct . go where+    go (Moore b f) = do+      yield b+      await >>= go . f++instance Functor (Moore a) where+  fmap f (Moore b g) = Moore (f b) (fmap f . g)++instance Profunctor Moore where+  rmap = fmap+  lmap f (Moore b g) = Moore b (lmap f . g . f)++instance Applicative (Moore a) where+  pure a = r where r = Moore a (const r)+  Moore f ff <*> Moore a fa  = Moore (f a) (\i -> ff i <*> fa i)+  m <* _ = m+  _ *> n = n++-- | slow diagonalization+instance Monad (Moore a) where+  return a = r where r = Moore a (const r)+  Moore a k >>= f = case f a of+    Moore b _ -> Moore b (k >=> f)+  _ >> m = m++instance Comonad (Moore a) where+  extract (Moore b _) = b+  extend f w@(Moore _ g) = Moore (f w) (extend f . g)++instance ComonadApply (Moore a) where+  Moore f ff <@> Moore a fa = Moore (f a) (\i -> ff i <*> fa i)+  m <@ _ = m+  _ @> n = n

@@ -0,0 +1,147 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Machine.Plan+-- Copyright   :  (C) 2012 Edward Kmett, Rúnar Bjarnason+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  Rank-N Types, MPTCs+--+----------------------------------------------------------------------------+module Data.Machine.Plan+  (+  -- * Plans+    Plan+  , runPlan+  , PlanT(..)+  , yield+  , await+  , stop+  , awaits+  ) where++import Control.Applicative+import Control.Category+import Control.Monad (ap, MonadPlus(..))+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Control.Monad.State.Class+import Control.Monad.Reader.Class+import Control.Monad.Error.Class+import Data.Functor.Identity+import Prelude hiding ((.),id)++-------------------------------------------------------------------------------+-- Plans+-------------------------------------------------------------------------------++-- | You can 'construct' a 'Plan' (or 'PlanT'), turning it into a+-- 'Data.Machine.Type.Machine' (or 'Data.Machine.Type.MachineT').+--+newtype PlanT k i o m a = PlanT+  { runPlanT :: forall r.+      (a -> m r) ->                                     -- Done a+      (o -> m r -> m r) ->                              -- Yield o (Plan k i o a)+      (forall z. (z -> m r) -> k i z -> m r -> m r) ->  -- forall z. Await (z -> Plan i o a) (k i z) (Plan k i o a)+      m r ->                                            -- Fail+      m r+  }++-- | A @'Plan' k i 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 i o a@ can be used as a @'PlanT' k i 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:+--+-- @+-- data 'Plan' k i o a+--   = Done a+--   | Yield o (Plan k i o a)+--   | forall z. Await (z -> Plan k i o a) (k i z) (Plan k i o a)+--   | Fail+-- @+type Plan k i o a = forall m. PlanT k i o m a++-- | Deconstruct a 'Plan' without reference to a 'Monad'.+runPlan :: PlanT k i o Identity a+        -> (a -> r)+        -> (o -> r -> r)+        -> (forall z. (z -> r) -> k i z -> r -> r)+        -> r+        -> r+runPlan m kp ke kr kf = runIdentity $ runPlanT m+  (Identity . kp)+  (\o (Identity r) -> Identity (ke o r))+  (\f k (Identity r) -> Identity (kr (runIdentity . f) k r))+  (Identity kf)++instance Functor (PlanT k i o m) where+  fmap f (PlanT m) = PlanT $ \k -> m (k . f)++instance Applicative (PlanT k i o m) where+  pure a = PlanT (\kp _ _ _ -> kp a)+  (<*>) = ap++instance Alternative (PlanT k i o m) where+  empty = PlanT $ \_ _ _ kf -> kf+  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)++instance Monad (PlanT k i o m) where+  return a = PlanT (\kp _ _ _ -> kp a)+  PlanT m >>= f = PlanT (\kp ke kr kf -> m (\a -> runPlanT (f a) kp ke kr kf) ke kr kf)+  fail _ = PlanT (\_ _ _ kf -> kf)++instance MonadPlus (PlanT k i o m) where+  mzero = empty+  mplus = (<|>)++instance MonadTrans (PlanT k i o) where+  lift m = PlanT (\kp _ _ _ -> m >>= kp)++instance MonadIO m => MonadIO (PlanT k i o m) where+  liftIO m = PlanT (\kp _ _ _ -> liftIO m >>= kp)++instance MonadState s m => MonadState s (PlanT k i o m) where+  get = lift get+  put = lift . put+  state f = PlanT $ \kp _ _ _ -> state f >>= kp++instance MonadReader e m => MonadReader e (PlanT k i o m) where+  ask = lift ask+  reader = lift . reader+  local f m = PlanT $ \kp ke kr kf -> local f (runPlanT m kp ke kr kf)++instance MonadError e m => MonadError e (PlanT k i o m) where+  throwError = lift . throwError+  catchError m k = PlanT $ \kp ke kr kf -> runPlanT m kp ke kr kf `catchError` \e -> runPlanT (k e) kp ke kr kf++-- | Output a result.+yield :: o -> Plan k i o ()+yield o = PlanT (\kp ke _ _ -> ke o (kp ()))++-- | Wait for input.+--+-- @'await' = 'awaits' 'id'@+await :: Category k => Plan k i o i+await = PlanT (\kp _ kr kf -> kr kp id kf)++-- | Wait for a particular input.+--+-- @+-- awaits 'L'  :: 'Plan' 'T' (a, b) o a+-- awaits 'R'  :: 'Plan' 'T' (a, b) o b+-- awaits 'id' :: 'Plan' 'Data.Machine.Is.Is' i o i+-- @+awaits :: k i j -> Plan k i o j+awaits h = PlanT $ \kp _ kr -> kr kp h++-- | @'stop' = 'empty'@+stop :: Plan k i o a+stop = empty

@@ -0,0 +1,149 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Machine.Process+-- Copyright   :  (C) 2012 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  Rank 2 Types, GADTs+--+----------------------------------------------------------------------------+module Data.Machine.Process+  (+  -- * Processes+    Process+  , ProcessT+  , Automaton(..)+  , process+  -- ** Common Processes+  , after+  , supply+  , prepended+  , filtered+  , dropping+  , taking+  , droppingWhile+  , takingWhile+  , buffered+  ) where++import Control.Applicative+import Control.Category+import Control.Monad (liftM, when, replicateM_)+import Data.Foldable+import Data.Machine.Is+import Data.Machine.Plan+import Data.Machine.Type+import Prelude hiding ((.),id)++-------------------------------------------------------------------------------+-- Processes+-------------------------------------------------------------------------------++-- | A @'Process' a b@ is a stream transducer that can consume values of type @a@+-- from its input, and produce values of type @b@ for its output.+type Process a b = Machine Is a b++-- | A @'ProcessT' m a b@ is a stream transducer that can consume values of type @a@+-- from its input, and produce values of type @b@ and has side-effects in the+-- 'Monad' @m@.+type ProcessT m a b = MachineT m Is a b++-- | An 'Automaton' is can be automatically lifted into a 'Process'+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 = repeatedly $ do+    i <- await+    yield i++-- | A 'Process' that prepends the elements of a 'Foldable' onto its input, then repeats its input from there.+prepended :: Foldable f => f a -> Process a a+prepended = before id . traverse_ yield++-- | A 'Process' that only passes through inputs that match a predicate.+filtered :: (a -> Bool) -> Process a a+filtered p = repeatedly $ do+  i <- await+  when (p i) $ yield i++-- | A 'Process' that drops the first @n@, then repeats the rest.+dropping :: Int -> Process a a+dropping n = before id $ replicateM_ n await++-- | A 'Process' that passes through the first @n@ elements from its input then stops+taking :: Int -> Process a a+taking n = construct . replicateM_ n $ await >>= yield++-- | A 'Process' that passes through elements until a predicate ceases to hold, then stops+takingWhile :: (a -> Bool) -> Process a a+takingWhile p = repeatedly $ await >>= \v -> if p v then yield v else stop++-- | A 'Process' that drops elements while a predicate holds+droppingWhile :: (a -> Bool) -> Process a a+droppingWhile p = before id loop where+  loop = await >>= \v -> if p v then loop else yield v++-- | Chunk up the input into `n` element lists.+--+-- Avoids returning empty lists and deals with the truncation of the last group.+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) $! n-1++-- | Build a new 'Machine' by adding a 'Process' to the output of an old 'Machine'+--+-- @+-- after :: 'Process' a b   -> 'Process' b c -> 'Process' a c+-- after :: 'Data.Machine.Tee.Tee' a b c     -> 'Process' c d -> 'Data.Machine.Tee.Tee' a b d+-- after :: 'Machine' k a b -> 'Process' b c -> 'Machine' k a c+-- @+after :: Monad m => MachineT m k a b -> ProcessT m b c -> MachineT m k a c+after ma mp = MachineT $ runMachineT mp >>= \v -> case v of+  Stop          -> return Stop+  Yield o k     -> return $ Yield o (after ma k)+  Await f Refl ff -> runMachineT ma >>= \u -> case u of+    Stop          -> runMachineT $ after stopped ff+    Yield o k     -> runMachineT . after k $ f o+    Await g kg fg -> let mv = MachineT (return v) in+      return $ Await (\a -> after (g a) mv) kg (after fg mv)++-- | 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)++-- |+-- Convert a machine into a process, with a little bit of help.+--+-- @'process' 'id' = 'id'@+--+-- @+-- 'process' 'Data.Machine.Tee.L' :: 'Data.Machine.Process.Process' a c -> 'Data.Machine.Tee.Tee' a b c+-- 'process' 'Data.Machine.Tee.R' :: 'Data.Machine.Process.Process' b c -> 'Data.Machine.Tee.Tee' a b c+-- 'process' 'id' :: 'Data.Machine.Process.Process' a b -> 'Data.Machine.Process.Process' a b+-- @+process :: Monad m => (forall a. k i a -> i' -> a) -> MachineT m k i 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)++

@@ -0,0 +1,80 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Machine.Tee+-- Copyright   :  (C) 2012 Edward Kmett, Rúnar Bjarnason, Paul Chiusano+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  Rank-2 Types, GADTs+--+----------------------------------------------------------------------------+module Data.Machine.Tee+  ( -- * Tees+    Tee, TeeT+  , T(..)+  , tee+  , addL, addR+  , capL, capR+  ) where++import Control.Category+import Data.Machine.Is+import Data.Machine.Process+import Data.Machine.Type+import Data.Machine.Source+import Prelude hiding ((.),id)++-------------------------------------------------------------------------------+-- Tees+-------------------------------------------------------------------------------++-- | The input descriptor for a 'Tee' or 'TeeT'+data T i c where+  L :: T (a, b) a+  R :: T (a, b) b++-- | A 'Machine' that can read from two input stream in a deterministic manner.+type Tee a b c = Machine T (a, b) c++-- | A 'Machine' that can read from two input stream in a deterministic manner with monadic side-effects.+type TeeT m a b c = MachineT m T (a, b) c++-- | Compose a pair of pipes onto the front of a Tee.+tee :: Monad m => ProcessT m a a' -> ProcessT m b b' -> TeeT m a' b' c -> TeeT m a b c+tee ma mb m = MachineT $ runMachineT m >>= \v -> case v of+  Stop         -> return Stop+  Yield o k    -> return $ Yield o $ tee ma mb k+  Await f L ff -> runMachineT ma >>= \u -> case u of+    Stop            -> runMachineT $ tee stopped mb ff+    Yield a k       -> runMachineT $ tee k mb $ f a+    Await g Refl fg ->+      return $ Await (\a -> tee (g a) mb $ encased v) L $ tee fg mb $ encased v+  Await f R ff -> runMachineT mb >>= \u -> case u of+    Stop            -> runMachineT $ tee ma stopped ff+    Yield b k       -> runMachineT $ tee ma k $ f b+    Await g Refl fg ->+      return $ Await (\b -> tee ma (g b) $ encased v) R $ tee ma fg $ encased v++-- | 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 id++-- | Precompose a pipe onto the right input of a tee.+addR :: Monad m => ProcessT m b c -> TeeT m a c d -> TeeT m a b d+addR = tee id++-- | Tie off one input of a tee by connecting it to a known source.+capL :: Monad m => SourceT m a -> TeeT m a b c -> ProcessT m b c+capL s t = fit cappedT $ addL s t++-- | Tie off one input of a tee by connecting it to a known source.+capR :: Monad m => SourceT m b -> TeeT m a b c -> ProcessT m a c+capR s t = fit cappedT $ addR s t++-- | Natural transformation used by 'capL' and 'capR'.+cappedT :: T (a, a) b -> Is a b+cappedT R = Refl+cappedT L = Refl

@@ -0,0 +1,234 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Machine.Type+-- Copyright   :  (C) 2012 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  rank-2, GADTs+--+----------------------------------------------------------------------------+module Data.Machine.Type+  (+  -- * Machines+    MachineT(..)+  , Step(..)+  , Machine+  , runT_+  , runT+  , run+  , runMachine+  , encased++  -- ** Building machines from plans+  , construct+  , repeatedly+  , before+--  , sink++  -- * Reshaping machines+  , fit+  , pass++  , stopped+  ) where++import Control.Applicative+import Control.Category+import Control.Monad (liftM)+import Data.Foldable+import Data.Functor.Identity+import Data.Machine.Is+import Data.Machine.Plan+import Data.Monoid+import Data.Profunctor+import Prelude hiding ((.),id)++-------------------------------------------------------------------------------+-- Transduction Machines+-------------------------------------------------------------------------------++-- | This is the base functor for a 'Machine' or 'MachineT'.+--+-- Note: Machines are usually constructed from 'Plan', so this does not need to be CPS'd.+data Step k i o r+  = Stop+  | Yield o r+  | forall t. Await (t -> r) (k i t) r++instance Functor (Step k i o) where+  fmap _ Stop = Stop+  fmap f (Yield o k) = Yield o (f k)+  fmap f (Await g kg fg) = Await (f . g) kg (f fg)++-- | A 'MachineT' reads from a number of inputs and may yield results before stopping+-- with monadic side-effects.+newtype MachineT m k i o = MachineT { runMachineT :: m (Step k i o (MachineT m k i o)) }++-- | A 'Machine' reads from a number of inputs and may yield results before stopping.+--+-- A 'Machine' can be used as a @'MachineT' m@ for any @'Monad' m@.+type Machine k i o = forall m. Monad m => MachineT m k i o++-- | @'runMachine' = 'runIdentity' . 'runMachineT'@+runMachine :: MachineT Identity k i o -> Step k i o (MachineT Identity k i o)+runMachine = runIdentity . runMachineT++-- | Pack a Step of a Machine into a Machine.+encased :: Monad m => Step k i o (MachineT m k i o) -> MachineT m k i o+encased = MachineT . return++instance Monad m => Functor (MachineT m k i) where+  fmap f (MachineT m) = MachineT (liftM f' m) where+    f' (Yield o xs)    = Yield (f o) (f <$> xs)+    f' (Await k kir e) = Await (fmap f . k) kir (f <$> e)+    f' Stop            = Stop++{-+apMachines :: Maybe (Seq i) -> Seq a -> MachineT m k i (a -> b) -> MachineT m k i a -> MachineT m k i b+apMachines is as m n = MachineT $ runMachineT m >>= \u -> case u of+  Stop -> return Stop+  Yield f m' -> case viewl as of+    a :< as' -> return $ Yield (f a) (apMachines is as' m' n)+    EmptyL   -> paMachines is (Seq.singleton f) m' n+  Await k Refl kf -> case is of+    Nothing ->++paMachines :: Maybe (Seq i) -> Seq (a -> b) -> MachineT m k i (a -> b) -> MachineT m k i a -> MachineT m k i b+paMachines is fs m n = MachineT $ runMachineT n >>= \v -> case v of+  Stop -> return Stop+  Yield a n' -> case viewl fs of+    f :< fs' -> return $ Yield (f a) (paMachines is fs' m n')+    EmptyL   -> apMachines is (Seq.singleton a) m n'++instance (k ~ Is, Monad m) => Applicative (MachineT m k i) where+  pure = repeatedly . yield+  m <*>  n = runMachineT m >>= \u -> case u of+    Stop       -> return stopped+    Yield f xs ->+    Await f Refl ff ->+-}++instance (Monad m, Profunctor k) => Profunctor (MachineT m k) where+  rmap = fmap+  lmap f (MachineT m) = MachineT (liftM f' m) where+    f' (Yield o xs)    = Yield o (lmap f xs)+    f' (Await k kir e) = Await (lmap f . k) (lmap f kir) (lmap f e)+    f' Stop            = Stop++-- | Stop feeding input into model, taking only the effects.+runT_ :: Monad m => MachineT m k a b -> m ()+runT_ (MachineT m) = m >>= \v -> case v of+  Stop        -> return ()+  Yield _ k   -> runT_ k+  Await _ _ e -> runT_ e++-- | Stop feeding input into model and extract an answer+runT :: Monad m => MachineT m k a b -> m [b]+runT (MachineT m) = m >>= \v -> case v of+  Stop        -> return []+  Yield o k   -> liftM (o:) (runT k)+  Await _ _ e -> runT e++-- | Run a pure machine and extract an answer.+run :: MachineT Identity k a b -> [b]+run = runIdentity . runT++-- | This permits toList to be used on a Machine.+instance (m ~ Identity) => Foldable (MachineT m k i) where+  foldMap f (MachineT (Identity m)) = go m where+    go Stop = mempty+    go (Yield o k) = f o `mappend` foldMap f k+    go (Await _ _ fg) = foldMap f fg++-- |+-- Connect different kinds of machines.+--+-- @'fit' 'id' = 'id'@+--+-- @+-- 'fit' 'id' :: 'Data.Machine.Process.Process' a b -> 'Data.Machine.Process.Process' a b+-- @+fit :: Monad m => (forall a. k i a -> k' i' a) -> MachineT m k i o -> MachineT m k' i' o+fit f (MachineT m) = MachineT (liftM f' m) where+  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)++-- | Compile a machine to a model.+construct :: Monad m => PlanT k i o m a -> MachineT m k i o+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)))+  (return Stop)++-- | Generates a model that runs a machine until it stops, then start it up again.+--+-- @'repeatedly' m = 'construct' ('Control.Monad.forever' m)@+repeatedly :: Monad m => PlanT k i o m a -> MachineT m k i o+repeatedly m = r where+  r = MachineT $ runPlanT m+    (const (runMachineT r))+    (\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 i o -> PlanT k i o m a -> MachineT m k i 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)))+  (return Stop)++-- | Given a handle, ignore all other inputs and just stream input from that handle.+--+-- @+-- 'pass' 'id' :: 'Data.Machine.Process.Process' a a+-- 'pass' 'Data.Machine.Tee.L'  :: 'Data.Machine.Tee.Tee' a b a+-- 'pass' 'Data.Machine.Tee.R'  :: 'Data.Machine.Tee.Tee' a b b+-- 'pass' 'Data.Machine.Wye.X'  :: 'Data.Machine.Wye.Wye' a b a+-- 'pass' 'Data.Machine.Wye.Y'  :: 'Data.Machine.Wye.Wye' a b b+-- 'pass' 'Data.Machine.Wye.Z'  :: 'Data.Machine.Wye.Wye' a b (Either a b)+-- @+pass :: k i o -> Machine k i o+pass input = repeatedly $ do+  a <- awaits input+  yield a++-- | Eventually this will probably revert to @instance 'Monad' m => 'Category' ('MachineT' m 'Is')@+instance (k ~ Is, Monad m) => Category (MachineT m k) where+  id = repeatedly $ do+    i <- await+    yield i++  m . n = MachineT $ runMachineT m >>= \v -> case v of+    Stop          -> return Stop+    Yield a as    -> return $ Yield a (as . n)+    Await f Refl k -> runMachineT n >>= \u -> case u of+      Stop          -> runMachineT $ k . stopped+      Yield b bs    -> runMachineT $ f b . bs+      Await g Refl fg -> return $ Await (\a -> encased v . g a) Refl (encased v . fg)++-- | This is a stopped 'Machine'+stopped :: Machine k a b+stopped = encased Stop++-------------------------------------------------------------------------------+-- Sink+-------------------------------------------------------------------------------++{-+-- |+-- A Sink in this model is a 'Data.Machine.Process.Process'+-- (or 'Data.Machine.Tee.Tee', etc) that produces a single answer.+--+-- \"Is that your final answer?\"+sink :: Monad m => (forall o. PlanT k i o m a) -> MachineT m k i a+sink m = runPlanT m (\a -> Yield a Stop) id (Await id) Stop+-}

@@ -0,0 +1,37 @@+{-# LANGUAGE GADTs #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Machine.Unread+-- Copyright   :  (C) 2012 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  GADTs+--+----------------------------------------------------------------------------+module Data.Machine.Unread+  ( Unread(..)+  , peek+  , unread+  ) where++import Data.Machine.Plan++-- | This is a simple process type that knows how to push back input.+data Unread a r where+  Unread :: a -> Unread a ()+  Read   :: Unread a a++-- | Peek at the next value in the input stream without consuming it+peek :: Plan Unread a b a+peek = do+  a <- awaits Read+  awaits (Unread a)+  return a++-- | Push back into the input stream+unread :: a -> Plan Unread a b ()+unread a = awaits (Unread a)++-- TODO: make this a class?

@@ -0,0 +1,103 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Machine.Wye+-- Copyright   :  (C) 2012 Edward Kmett, Rúnar Bjarnason, Paul Chiusano+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  Rank-2 Types, GADTs+--+----------------------------------------------------------------------------+module Data.Machine.Wye+  (+  -- * Wyes+    Wye, WyeT+  , Y(..)+  , wye+  , addX, addY+  , capX, capY+  ) where++import Control.Category+import Data.Machine.Process+import Data.Machine.Type+import Data.Machine.Is+import Data.Machine.Source+import Prelude hiding ((.),id)++-------------------------------------------------------------------------------+-- Wyes+-------------------------------------------------------------------------------++-- | The input descriptor for a 'Wye' or 'WyeT'+data Y i c where+  X :: Y (a, b) a            -- block waiting on the left input+  Y :: Y (a, b) b            -- block waiting on the right input+  Z :: Y (a, b) (Either a b) -- block waiting on either input++-- | A 'Machine' that can read from two input stream in a non-deterministic manner.+type Wye a b c = Machine Y (a, b) c++-- | A 'Machine' that can read from two input stream in a non-deterministic manner with monadic side-effects.+type WyeT m a b c = MachineT m Y (a, b) c++-- | Compose a pair of pipes onto the front of a 'Wye'.++-- | Precompose a 'Process' onto each input of a 'Wye' (or 'WyeT').+--+-- This is left biased in that it tries to draw values from the 'X' input whenever they are+-- available, and only draws from the 'Y' input when 'X' would block.+wye :: Monad m => ProcessT m a a' -> ProcessT m b b' -> WyeT m a' b' c -> WyeT m a b c+wye ma mb m = MachineT $ runMachineT m >>= \v -> case v of+  Yield o k           -> return $ Yield o (wye ma mb k)+  Stop                -> return Stop+  Await f X ff        -> runMachineT ma >>= \u -> case u of+    Yield a k           -> runMachineT . wye k mb $ f a+    Stop                -> runMachineT $ wye stopped mb ff+    Await g Refl fg     -> return . Await (\a -> wye (g a) mb $ encased v) X+                                  . wye fg mb $ encased v+  Await f Y ff        -> runMachineT mb >>= \u -> case u of+    Yield b k           -> runMachineT . wye ma k $ f b+    Stop                -> runMachineT $ wye ma stopped ff+    Await g Refl fg     -> return . Await (\b -> wye ma (g b) $ encased v) Y+                                  . wye ma fg $ encased v+  Await f Z ff        -> runMachineT ma >>= \u -> case u of+    Yield a k           -> runMachineT . wye k mb . f $ Left a+    Stop                -> runMachineT mb >>= \w -> case w of+      Yield b k           -> runMachineT . wye stopped k . f $ Right b+      Stop                -> runMachineT $ wye stopped stopped ff+      Await g Refl fg     -> return . Await (\b -> wye stopped (g b) $ encased v) Y+                                    . wye stopped fg $ encased v+    Await g Refl fg     -> runMachineT mb >>= \w -> case w of+      Yield b k           -> runMachineT . wye (encased u) k . f $ Right b+      Stop                -> return . Await (\a -> wye (g a) stopped $ encased v) X+                                    . wye fg stopped $ encased v+      Await h Refl fh     -> return . Await (\c -> case c of+                                                  Left a  -> wye (g a) (encased w) $ encased v+                                                  Right b -> wye (encased u) (h b) $ encased v) Z+                                    . wye fg fh $ encased v++-- | Precompose a pipe onto the left input of a wye.+addX :: Monad m => ProcessT m a b -> WyeT m b c d -> WyeT m a c d+addX p = wye p id++-- | Precompose a pipe onto the right input of a tee.+addY :: Monad m => ProcessT m b c -> WyeT m a c d -> WyeT m a b d+addY = wye id++-- | Tie off one input of a tee by connecting it to a known source.+capX :: Monad m => SourceT m a -> WyeT m a b c -> ProcessT m b c+capX s t = process (capped Right) (addX s t)++-- | Tie off one input of a tee by connecting it to a known source.+capY :: Monad m => SourceT m b -> WyeT m a b c -> ProcessT m a c+capY s t = process (capped Left) (addY s t)++-- | Natural transformation used by 'capX' and 'capY'+capped :: (a -> Either a a) -> Y (a, a) b -> a -> b+capped _ X = id+capped _ Y = id+capped f Z = f

@@ -0,0 +1,28 @@+module Main where++import Test.DocTest+import System.Directory+import System.FilePath+import Control.Applicative+import Control.Monad+import Data.List++main :: IO ()+main = getSources >>= \sources -> doctest $+    "-isrc"+  : "-idist/build/autogen"+  : "-optP-include"+  : "-optPdist/build/autogen/cabal_macros.h"+  : sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c