Permalink
Browse files

Add leftovers as a type parameter

  • Loading branch information...
1 parent 133f947 commit 865dadadf62d93147e0d15e7cd089d539a208fb4 @cdsmith committed Jun 9, 2012
Showing with 85 additions and 108 deletions.
  1. +85 −108 Pipes.hs
View
193 Pipes.hs
@@ -1,11 +1,14 @@
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE Rank2Types #-}
module Pipes (
- MonadStream,
- tryAwait,
- yield,
+ MonadStream(..),
+ MonadUnStream(..),
+ Leftovers,
+ NoLeftovers,
Pipe,
(>+>),
simulatePipe,
@@ -17,26 +20,29 @@ module Pipes (
concatMapP,
filterP,
idP,
+ foldP,
+ takeP,
+ dropP,
+ fromList,
consume,
consumeToo,
+ peek,
leftP,
rightP,
- PutbackPipe,
- putback,
- toPutback,
- runPutback,
- discardPutback,
- (>++>)
+ collectLeftovers,
+ discardLeftovers
) where
import Prelude hiding (id, (.))
-import Control.Arrow (first)
import Control.Applicative
+import Control.Arrow (first)
+import Control.Category
+import Control.Exception
import Control.Monad
-import Control.Monad.Trans
import Control.Monad.State
-import Control.Category
+import Control.Monad.Trans
import Data.Monoid
+import Data.Typeable
import Data.Void
class Monad m => MonadStream m where
@@ -47,51 +53,67 @@ class Monad m => MonadStream m where
tryAwait :: m (Either (StreamResult m) (Upstream m))
yield :: Downstream m -> m ()
-data Pipe a b r m s = Yield b (Pipe a b r m s)
- | Await (Either r a -> Pipe a b r m s)
- | Do (m (Pipe a b r m s))
- | Done s
+class MonadStream m => MonadUnStream m where
+ unawait :: Upstream m -> m ()
+
+data Leftovers
+data NoLeftovers
+
+data Pipe lo a b u m r where
+ Yield :: b -> Pipe lo a b u m r -> Pipe lo a b u m r
+ Await :: (Either u a -> Pipe lo a b u m r) -> Pipe lo a b u m r
+ UnAwait :: a -> Pipe Leftovers a b u m r -> Pipe Leftovers a b u m r
+ Do :: m (Pipe lo a b u m r) -> Pipe lo a b u m r
+ Done :: r -> Pipe lo a b u m r
-instance Monad m => Monad (Pipe a b r m) where
+instance Monad m => Monad (Pipe lo a b u m) where
return = Done
- Yield x p >>= f = Yield x (p >>= f)
- Await g >>= f = Await ((>>= f) . g)
- Do m >>= f = Do (liftM (>>= f) m)
- Done r >>= f = f r
+ Yield x p >>= f = Yield x (p >>= f)
+ Await g >>= f = Await ((>>= f) . g)
+ UnAwait x p >>= f = UnAwait x (p >>= f)
+ Do m >>= f = Do (liftM (>>= f) m)
+ Done r >>= f = f r
-instance Monad m => Functor (Pipe a b r m) where fmap = liftM
-instance Monad m => Applicative (Pipe a b r m) where pure = return ; (<*>) = ap
-instance MonadTrans (Pipe a b r) where lift m = Do (liftM Done m)
-instance MonadIO m => MonadIO (Pipe a b r m) where liftIO = lift . liftIO
+instance Monad m => Functor (Pipe lo a b u m) where fmap = liftM
+instance Monad m => Applicative (Pipe lo a b u m) where pure = return ; (<*>) = ap
+instance MonadTrans (Pipe lo a b u) where lift m = Do (liftM Done m)
+instance MonadIO m => MonadIO (Pipe lo a b u m) where liftIO = lift . liftIO
-instance Monad m => MonadStream (Pipe a b r m) where
- type Upstream (Pipe a b r m) = a
- type Downstream (Pipe a b r m) = b
- type StreamResult (Pipe a b r m) = r
+instance Monad m => MonadStream (Pipe lo a b u m) where
+ type Upstream (Pipe lo a b u m) = a
+ type Downstream (Pipe lo a b u m) = b
+ type StreamResult (Pipe lo a b u m) = u
- tryAwait = Await Done
+ tryAwait = Await (either (Done . Left) (Done . Right))
yield x = Yield x (Done ())
-(>+>) :: Monad m => Pipe a b r m s -> Pipe b c s m t -> Pipe a c r m t
+instance Monad m => MonadUnStream (Pipe Leftovers a b u m) where
+ unawait x = UnAwait x (Done ())
+
+(>+>) :: Monad m => Pipe lo a b r m s -> Pipe NoLeftovers b c s m t -> Pipe lo a c r m t
p >+> Yield x q = Yield x (p >+> q)
p >+> Do m = Do (liftM (p >+>) m)
p >+> Done x = Done x
p >+> Await f = upstream p
- where upstream (Yield x q) = q >+> f (Right x)
- upstream (Done x ) = Done x >+> f (Left x)
- upstream (Do m ) = Do (liftM upstream m)
- upstream (Await g ) = Await (upstream . g)
+ where upstream (Yield x q) = q >+> f (Right x)
+ upstream (Done x ) = Done x >+> f (Left x)
+ upstream (Do m ) = Do (liftM upstream m)
+ upstream (Await g ) = Await (upstream . g)
+ upstream (UnAwait x q) = UnAwait x (upstream q)
simulatePipe :: (Monad m, MonadTrans t, Monad (t m))
- => t m (Either r a)
+ => t m (Either u a)
-> (b -> t m ())
- -> Pipe a b r m s
- -> t m s
-simulatePipe up down (Yield x p) = down x >> simulatePipe up down p
-simulatePipe up down (Await f) = simulatePipe up down . f =<< up
-simulatePipe up down (Do m) = lift m >>= simulatePipe up down
-simulatePipe up down (Done x) = return x
+ -> Pipe lo a b u m r
+ -> t m (r, [a])
+simulatePipe up down = go []
+ where go xs (Yield x p) = down x >> go xs p
+ go (x:xs) (Await f) = go xs (f (Right x))
+ go [] (Await f) = go [] . f =<< up
+ go xs (UnAwait x p) = go (x:xs) p
+ go xs (Do m) = lift m >>= go xs
+ go xs (Done x) = return (x, xs)
newtype IdentityT m a = IdentityT { runIdentityT :: m a }
@@ -100,17 +122,20 @@ instance Monad m => Monad (IdentityT m) where
IdentityT m >>= f = IdentityT $ m >>= runIdentityT . f
instance MonadTrans IdentityT where lift = IdentityT
+instance MonadIO m => MonadIO (IdentityT m) where liftIO = lift . liftIO
-runPipe :: Monad m => Pipe () Void r m s -> m s
-runPipe = runIdentityT . simulatePipe (return (Right ()))
- (error "runPipe: impossible yield of Void")
+runPipe :: Monad m => Pipe lo () Void u m r -> m r
+runPipe = liftM fst
+ . runIdentityT
+ . simulatePipe (return (Right ()))
+ (error "runPipe: impossible yield")
-newtype PipeC m r a b = PipeC (Pipe a b r m r)
+newtype PipeC m r a b = PipeC (Pipe NoLeftovers a b r m r)
instance Monad m => Category (PipeC m r) where
id = PipeC idP
(PipeC p) . (PipeC q) = PipeC (q >+> p)
-newtype FinalC a m r s = FinalC (Pipe a a r m s)
+newtype FinalC a m u r = FinalC (Pipe NoLeftovers a a u m r)
instance Monad m => Category (FinalC a m) where
id = FinalC idP
(FinalC p) . (FinalC q) = FinalC (q >+> p)
@@ -150,65 +175,17 @@ consume = tryAwait >>= either (const $ return []) (\x -> liftM (x:) consume)
consumeToo :: (MonadStream m, Downstream m ~ Void) => m ([Upstream m], StreamResult m)
consumeToo = tryAwait >>= either (return . ([],)) (\x -> liftM (first (x:)) consumeToo)
-leftP :: Monad m => Pipe a b r m s -> Pipe (Either a c) (Either b c) r m s
-leftP p = simulatePipe up down p
- where up = do x <- tryAwait
- case x of Left r -> return (Left r)
- Right (Left x) -> return (Right x)
- Right (Right x) -> yield (Right x) >> up
- down = yield . Left
-
-rightP :: Monad m => Pipe a b r m s -> Pipe (Either c a) (Either c b) r m s
-rightP p = simulatePipe up down p
- where up = do x <- tryAwait
- case x of Left r -> return (Left r)
- Right (Right x) -> return (Right x)
- Right (Left x) -> yield (Left x) >> up
- down = yield . Right
-
-newtype PutbackPipe a b r m s = PutbackPipe { unPutback :: Pipe a (Either a b) r m s }
-
-instance Monad m => Monad (PutbackPipe a b r m) where
- return = PutbackPipe . return
- PutbackPipe p >>= f = PutbackPipe (p >>= unPutback . f)
-
-instance Monad m => Functor (PutbackPipe a b r m) where fmap = liftM
-instance Monad m => Applicative (PutbackPipe a b r m) where pure = return ; (<*>) = ap
-instance MonadTrans (PutbackPipe a b r) where lift m = PutbackPipe (Do (liftM Done m))
-instance MonadIO m => MonadIO (PutbackPipe a b r m) where liftIO = lift . liftIO
-
-instance Monad m => MonadStream (PutbackPipe a b r m) where
- type Upstream (PutbackPipe a b r m) = a
- type Downstream (PutbackPipe a b r m) = b
- type StreamResult (PutbackPipe a b r m) = r
-
- tryAwait = PutbackPipe tryAwait
- yield = PutbackPipe . yield . Right
-
-putback :: Monad m => a -> PutbackPipe a b r m ()
-putback = PutbackPipe . yield . Left
-
-toPutback :: Monad m => Pipe a b r m s -> PutbackPipe a b r m s
-toPutback p = PutbackPipe (p >+> mapP Right)
-
-newtype PBWrapper a b r m s = PBWrap { unwrapPB :: StateT [a] (Pipe a b r m) s }
-
-instance Monad m => Monad (PBWrapper a b r m) where
- return = PBWrap . return
- (PBWrap m) >>= f = PBWrap (m >>= unwrapPB . f)
+peek :: MonadUnStream m => m (Either (StreamResult m) (Upstream m))
+peek = tryAwait >>= either (return . Left) (\x -> unawait x >> return (Right x))
-instance MonadTrans (PBWrapper a b r) where lift = PBWrap . lift . lift
+leftP :: Monad m => Pipe lo a b u m r -> Pipe lo (Either a c) (Either b c) u m r
+leftP p = undefined
-runPutback :: Monad m => PutbackPipe a b r m s -> Pipe a b r m (s, [a])
-runPutback (PutbackPipe p) = runStateT (unwrapPB (simulatePipe up down p)) []
- where up = PBWrap $ do lo <- get
- case lo of [] -> lift tryAwait
- x:xs -> put xs >> return (Right x)
- down (Left x) = PBWrap $ modify (x:)
- down (Right x) = PBWrap $ lift (yield x)
+rightP :: Monad m => Pipe lo a b r m s -> Pipe lo (Either c a) (Either c b) r m s
+rightP p = undefined
-discardPutback :: Monad m => PutbackPipe a b r m s -> Pipe a b r m s
-discardPutback p = liftM fst (runPutback p)
+collectLeftovers :: MonadIO m => Pipe Leftovers a b u m r -> Pipe NoLeftovers a b u m (r, [a])
+collectLeftovers = undefined
-(>++>) :: Monad m => PutbackPipe a b r m s -> Pipe b c s m t -> PutbackPipe a c r m t
-PutbackPipe p >++> q = PutbackPipe (p >+> rightP q)
+discardLeftovers :: MonadIO m => Pipe Leftovers a b u m r -> Pipe NoLeftovers a b u m r
+discardLeftovers = undefined

0 comments on commit 865dada

Please sign in to comment.