drinkery 0 → 0.1

raw patch · 11 files changed

+480/−423 lines, 11 filesdep +ListTdep +conduitdep +conduit-combinatorsdep −criterionPVP ok

version bump matches the API change (PVP)

Dependencies added: ListT, conduit, conduit-combinators, gauge, list-t, machines, pipes

Dependencies removed: criterion

API changes (from Hackage documentation)

Files

• README.md +17/−22
• benchmarks/benchmark.hs +81/−12
• drinkery.cabal +4/−4
• src/Data/Drinkery.hs +2/−2
• src/Data/Drinkery/Boozer.hs +0/−137
• src/Data/Drinkery/Class.hs +95/−47
• src/Data/Drinkery/Combinators.hs +50/−0
• src/Data/Drinkery/Distiller.hs +65/−106
• src/Data/Drinkery/Glass.hs +0/−71
• src/Data/Drinkery/Patron.hs +78/−0
• src/Data/Drinkery/Tap.hs +88/−22

@@ -9,7 +9,7 @@  `Barman r s` is a monad transformer to produce a stream of type `s`. It is good at interactively serving values.-`topup :: s -> Barman r s m a` is the primary action.+`yield :: s -> Barman r s m a` is the primary action. A barman can also accept requests from the downstream using `accept`.  `Sommelier r` is a list-like backtracking monad (also known as ListT done right).@@ -24,35 +24,31 @@  ## Consumer -`Patron r s` is a monad transformer which consumes `s` and may request `r`.--`MonadDrink` provides the actions of `Patron`:+`Drinker tap` is a monad transformer which consumes `tap`.  * `drink :: m s` Get one element.-* `spit :: s -> m ()` Leave one element.-* `call :: r -> m ()` Send a request.+* `leftover :: s -> m ()` Leave one element.+* `request :: r -> m ()` Send a request. -`(+&) :: (Monoid r, CloseRequest r, Monad m) => Tap m r s -> Patron r s m a -> m a`-connects a tap with a patron.+`(+&) :: (Monoid r, CloseRequest r, Monad m) => Tap r s m -> Drinker (Tap r s) m a -> m a`+connects a tap with a drinker.  ## Transducer -`Distiller p q m r s` is a stream transducer which+`Distiller tap m r s` is a stream transducer which -* Sends `p`-* Consumes `q`+* Consumes `tap` * Receives `r` * Produces `s` -It is actually a `Tap` where the underlying monad is `Patron`.+It is actually a `Tap` where the underlying monad is `Drinker`. -There are three composition operators:+There are two composition operators: -* `$&` Distiller-patron-* `$$$` Distiler-distiller+* `++&` Tap-drinker * `++$` Tap-distiller -`+`, `&`, and `$` means a tap, a patron, and a distiller respectively. The middle+`+`, `&`, and `$` means a tap, a drinker, and a distiller respectively. The middle characters of these operators signify the resulting structures.  ## Why drinkery?@@ -66,10 +62,10 @@ Still there are some differences:  * `Distiller` does not terminate.-* Unlike pipes' `>->`, `$$$` propagates inner requests:-    * `($$$) :: Monoid r => Distiller p q m r s -> Distiller r s m t u -> Distiller p q m t u`+* Unlike pipes' `>->`, `++$` propagates inner requests:+    * `(++$) :: Monad m => Distiller tap m p q -> Distiller (Tap p q) (Drinker tap m) r s -> Distiller tap m r s`     * `(>->) :: Proxy a' a () b m r	-> Proxy () b c' c m r -> Proxy a' a c' c m r`-* `Patron`, the consumer monad, may leave unconsumed inputs.+* `Drinker`, the consumer monad, may leave unconsumed inputs. * `drinkery` has much fewer operators.  ### conduit@@ -79,11 +75,10 @@  ### machines -`machines` has multi-channel consumers but `drinkery` doesn't. `machines` does not support leftovers, nor interactive producers.+Both `machines` and `drinkery` support multi-channel input.  ### iteratee  `iteratee` has an ability to handle requests but those are untyped (`SomeException`).-`drinkery` provides a more robust interface for handling requests.-Two monadic producers - `Barman` and `Sommelier` - are easier to use.+`drinkery` provides a more robust interface for handling requests, and monadic producers.

@@ -1,23 +1,92 @@-import qualified Data.Drinkery as D
-import qualified Data.Drinkery.Glass as D
-import Data.Functor.Identity
 import Control.Arrow
 import Control.Monad
-import Criterion.Main
+import Data.Functor.Identity
 import Data.List
 import Data.Void
+import Gauge.Main
+import qualified Control.Monad.Trans.List as L
+import qualified Data.Drinkery as D
+import qualified ListT as L
+import qualified Pipes as P
+import qualified Pipes.Prelude as P
+import qualified Data.Conduit as C
+import qualified Data.Conduit.Combinators as CC
+import qualified Data.Machine as M
 
-drainD :: D.Distiller () (Maybe Int) IO () (Maybe a) -> IO ()
-drainD h = sourceD D.+& h D.$& D.sinkNull
+drainD :: Monad m => D.Drinker (D.Tap () (Maybe a)) m ()
+drainD = D.drainFrom D.drink
 
-value :: Int
-value = 10000
+sourceAlt :: Monad m => ([Int] -> m Int) -> m Int
+sourceAlt k = do
+  a <- k [1..50]
+  b <- k [1..a]
+  c <- k [1..b]
+  return $! a + b + c
+{-# INLINE sourceAlt #-}
 
-sourceD :: (Monoid r, Monad m) => D.Tap m r (Maybe Int)
-sourceD = D.runSommelier $ D.taste [1..value]
+sourceSeq :: Monad m => (Int -> m ()) -> m ()
+sourceSeq k = forM_ [1..50] $ \a -> forM_ [1..a] $ \b -> forM_ [1..b] $ \c -> k $! a + b + c
+{-# INLINE sourceSeq #-}
 
+sourceD :: Monad m => D.Tap () (Maybe Int) m
+sourceD = D.runSommelier (sourceAlt D.taste)
+{-# INLINE sourceD #-}
+
+sourceP :: Monad m => P.Producer Int m ()
+sourceP = sourceSeq P.yield
+{-# INLINE sourceP #-}
+
+sourceC :: Monad m => C.Producer m Int
+sourceC = sourceSeq C.yield
+{-# INLINE sourceC #-}
+
+sourceM :: M.Source Int
+sourceM = M.construct $ sourceSeq M.yield
+{-# INLINE sourceM #-}
+
 main = defaultMain
-  [ bgroup "scan"
-      [ bench "drinkery" $ whnfIO $ drainD (D.scanningMaybe (+) 0)
+  [ bgroup "drain"
+      [ bench "drinkery/Barman" $ whnfIO
+          $ apply (D.+& drainD)
+          $ D.runBarman (sourceSeq D.pour)
+      , bench "drinkery/Sommelier" $ whnfIO
+          $ apply (D.+& drainD) sourceD
+      , bench "pipes/Producer" $ whnfIO
+          $ apply (\s -> P.runEffect $ s P.>-> P.drain) sourceP
+      , bench "pipes/ListT" $ whnfIO
+          $ apply (\s -> P.runEffect $ s P.>-> P.drain)
+          $ P.enumerate (sourceAlt (P.Select . P.each))
+      , bench "list-t" $ whnfIO
+          $ apply (L.traverse_ $ const $ pure ())
+          $ sourceAlt L.fromFoldable+      , bench "ListT" $ whnfIO
+          $ apply (L.foldlM (\_ _ -> pure ()) ())
+          $ sourceAlt L.fromList
       ]
+  , bgroup "scan"
+      [ bench "drinkery" $ whnfIO $ apply (\h -> sourceD D.+& h D.$& drainD)
+          $ D.scanningMaybe (+) 0
+      , bench "pipes" $ whnfIO $ apply (\p -> P.runEffect $ P.for (sourceP P.>-> p) P.discard)
+          $ P.scan (+) 0 id
+      , bench "conduit" $ whnfIO $ apply (\h -> sourceC C.$= h C.$$ CC.sinkNull)
+          $ CC.scanl (+) 0
+      , bench "machines" $ whnfIO $ apply (M.runT_ . (sourceM M.~>))
+          $ M.scan (+) 0
+      ]
+   , bgroup "scan-chain"
+      [ bench "drinkery/++$" $ whnfIO $ apply (\h -> D.runBarman (sourceSeq D.pour) D.+& h D.$& drainD)
+          $ D.scanningMaybe (+) 0 D.++$ D.scanningMaybe (+) 0
+      , bench "drinkery/$&" $ whnfIO $ apply (\(h, h') -> D.runBarman (sourceSeq D.pour) D.+& h D.$& h' D.$& drainD)
+          (D.scanningMaybe (+) 0, D.scanningMaybe (+) 0)
+      , bench "pipes" $ whnfIO $ apply (\p -> P.runEffect $ P.for (sourceP P.>-> p) P.discard)
+          $ P.scan (+) 0 id P.>-> P.scan (+) 0 id
+      , bench "conduit" $ whnfIO $ apply (\h -> sourceC C.$= h C.$$ CC.sinkNull)
+          $ CC.scanl (+) 0 C.=$= CC.scanl (+) 0
+      , bench "machines" $ whnfIO $ apply (M.runT_ . (sourceM M.~>))
+          $ M.scan (+) 0 M.~> M.scan (+) 0
+      ]
   ]
+
+apply :: (a -> b) -> a -> b
+apply f x = f x
+{-# NOINLINE apply #-}

@@ -1,5 +1,5 @@ name:                drinkery-version:             0+version:             0.1 synopsis:            Boozy streaming library description:         Boozy streaming library homepage:            https://github.com/fumieval/drinkery#readme@@ -18,9 +18,9 @@   exposed-modules:     Data.Drinkery     Data.Drinkery.Class-    Data.Drinkery.Boozer+    Data.Drinkery.Combinators     Data.Drinkery.Distiller-    Data.Drinkery.Glass+    Data.Drinkery.Patron     Data.Drinkery.Tap   build-depends:       base >= 4.7 && < 5, transformers, mtl   ghc-options: -Wall@@ -31,7 +31,7 @@   main-is:        benchmark.hs   ghc-options:    -O2   hs-source-dirs: benchmarks-  build-depends: base, drinkery, criterion+  build-depends: base, drinkery, gauge, pipes, machines, conduit, conduit-combinators, list-t, ListT   default-language:    Haskell2010  source-repository head

@@ -1,11 +1,11 @@ module Data.Drinkery     ( module Data.Drinkery.Class+    , module Data.Drinkery.Combinators     , module Data.Drinkery.Distiller     , module Data.Drinkery.Tap-    , Patron(..)     )where -import Data.Drinkery.Boozer import Data.Drinkery.Class+import Data.Drinkery.Combinators import Data.Drinkery.Distiller import Data.Drinkery.Tap

@@ -1,137 +0,0 @@-{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}-{-# LANGUAGE DeriveFunctor #-}------------------------------------------------------------------------------ Module      :  Data.Drinkery.Boozer--- Copyright   :  (c) Fumiaki Kinoshita 2017--- License     :  BSD3------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>------ Basic consumer-------------------------------------------------------------------------module Data.Drinkery.Boozer where--import Control.Monad.Trans.Class-import Control.Monad.IO.Class-import Control.Monad-import Control.Monad.Reader.Class-import Control.Monad.State.Class-import Data.Drinkery.Class---- | Boozer is the initial encoding of a consumer.-data Boozer r s m a = Drink (s -> Boozer r s m a)-  | Spit s (Boozer r s m a)-  | Call r (Boozer r s m a)-  | Lift (m (Boozer r s m a))-  | Pure a-  deriving Functor---- | Tear down a 'Boozer', maintaining a stack of leftovers.-iterBoozer :: ([s] -> a -> z) -- ^ return-  -> ((s -> z) -> z) -- ^ drink-  -> (r -> z -> z) -- ^ call-  -> (forall x. m x -> (x -> z) -> z) -- ^ bind-  -> Boozer r s m a -> z-iterBoozer p d c t = go [] where-  go [] (Drink k) = d (go [] . k)-  go (x : xs) (Drink k) = go xs (k x)-  go xs (Spit s k) = go (s : xs) k-  go xs (Call r k) = c r (go xs k)-  go xs (Lift m) = t m (go xs)-  go xs (Pure a) = p xs a--hoistBoozer :: Functor n => (forall x. m x -> n x) -> Boozer r s m a -> Boozer r s n a-hoistBoozer t = go where-  go (Pure a) = Pure a-  go (Lift m) = Lift $ go <$> t m-  go (Call r k) = Call r (go k)-  go (Spit s k) = Spit s (go k)-  go (Drink f) = Drink $ go . f--instance Functor m => Applicative (Boozer r s m) where-  pure = Pure-  {-# INLINE pure #-}-  (<*>) = ap-  (*>) = (>>)--instance Functor m => Monad (Boozer r s m) where-  return = Pure-  {-# INLINE return #-}-  m0 >>= k = go m0 where-    go (Pure a) = k a-    go (Drink m) = Drink $ go . m-    go (Lift m) = Lift $ fmap go m-    go (Call r c) = Call r (go c)-    go (Spit s c) = Spit s (go c)--  m0 >> k = go m0 where-    go (Pure _) = k-    go (Drink m) = Drink $ go . m-    go (Lift m) = Lift $ fmap go m-    go (Call r c) = Call r (go c)-    go (Spit s c) = Spit s (go c)--instance MonadTrans (Boozer r s) where-  lift m = Lift $ Pure <$> m--instance MonadIO m => MonadIO (Boozer r s m) where-  liftIO m = Lift $ Pure <$> liftIO m--instance MonadReader x m => MonadReader x (Boozer r s m) where-  ask = lift ask-  local f = hoistBoozer (local f)--instance MonadState x m => MonadState x (Boozer r s m) where-  get = lift get-  put = lift . put-  state = lift . state--instance Functor m => MonadDrunk r s (Boozer r s m) where-  drink = Drink Pure-  spit s = Spit s (Pure ())-  call r = Call r (Pure ())---- | 'Patron' is a CPS'd 'Boozer'.-newtype Patron r s m a = Patron-  { unPatron :: forall x. (a -> Boozer r s m x) -> Boozer r s m x }--runPatron :: Patron r s m a -> Boozer r s m a-runPatron m = unPatron m Pure-{-# INLINE runPatron #-}--instance Functor (Patron r s m) where-  fmap f m = Patron $ \cont -> unPatron m $ cont . f-  {-# INLINE fmap #-}--instance Applicative (Patron r s m) where-  pure a = Patron $ \cont -> cont a-  {-# INLINE pure #-}-  (<*>) = ap-  {-# INLINE (<*>) #-}-  (*>) = (>>)-  {-# INLINE (*>) #-}--instance Monad (Patron r s m) where-  return a = Patron ($a)-  Patron m >>= k = Patron $ \cont -> m (\a -> unPatron (k a) cont)--instance MonadTrans (Patron r s) where-  lift m = Patron $ \cont -> Lift $ cont <$> m--instance MonadDrunk r s (Patron r s m) where-  drink = Patron $ \cont -> Drink cont-  spit s = Patron $ \cont -> Spit s $ cont ()-  call r = Patron $ \cont -> Call r $ cont ()--instance MonadReader x m => MonadReader x (Patron r s m) where-  ask = lift ask-  local f m = Patron $ \cont -> unPatron m (local f . cont)--instance MonadState x m => MonadState x (Patron r s m) where-  get = lift get-  put = lift . put-  state = lift . state--instance MonadIO m => MonadIO (Patron r s m) where-  liftIO m = Patron $ \cont -> Lift $ cont <$> liftIO m

@@ -10,7 +10,12 @@ -- -- Basic classes ------------------------------------------------------------------------module Data.Drinkery.Class where+module Data.Drinkery.Class+  ( Drinker(..)+  , mapDrinker+  , MonadDrunk(..)+  , CloseRequest(..)+  , Closable(..)) where  import Control.Monad.Trans.Class import Control.Monad.Trans.Cont@@ -22,64 +27,103 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.IO.Class+import Control.Monad.Reader.Class+import Control.Monad.Writer.Class+import Control.Monad.State.Class -class Monad m => MonadDrunk r s m | m -> r s where-  drink :: m s-  spit :: s -> m ()-  call :: r -> m ()+-- | A 'Drinker' is a stream consumer monad.+newtype Drinker t m a = Drinker { runDrinker :: t m -> m (a, t m) } -instance MonadDrunk r s m => MonadDrunk r s (Reader.ReaderT x m) where-  drink = lift drink-  spit = lift . spit-  call = lift . call+mapDrinker :: (forall x. m x -> m x) -> Drinker t m a -> Drinker t m a+mapDrinker t = Drinker . fmap t . runDrinker+{-# INLINE mapDrinker #-} -instance MonadDrunk r s m => MonadDrunk r s (Lazy.StateT x m) where-  drink = lift drink-  spit = lift . spit-  call = lift . call+instance (Functor m) => Functor (Drinker s m) where+  fmap f m = Drinker $ \s -> fmap (\(a, s') -> (f a, s')) $ runDrinker m s+  {-# INLINE fmap #-} -instance MonadDrunk r s m => MonadDrunk r s (Strict.StateT x m) where-  drink = lift drink-  spit = lift . spit-  call = lift . call+instance (Functor m, Monad m) => Applicative (Drinker s m) where+  pure a = Drinker $ \s -> return (a, s)+  {-# INLINE pure #-}+  Drinker mf <*> Drinker mx = Drinker $ \ s -> do+    (f, s') <- mf s+    (x, s'') <- mx s'+    return (f x, s'')+  {-# INLINE (<*>) #-}+  m *> k = m >>= \_ -> k+  {-# INLINE (*>) #-} -instance (Monoid x, MonadDrunk r s m) => MonadDrunk r s (Lazy.WriterT x m) where-  drink = lift drink-  spit = lift . spit-  call = lift . call+instance (Monad m) => Monad (Drinker s m) where+  return a = Drinker $ \s -> return (a, s)+  {-# INLINE return #-}+  m >>= k  = Drinker $ \s -> do+    (a, s') <- runDrinker m s+    runDrinker (k a) s'+  {-# INLINE (>>=) #-}+  fail str = Drinker $ \_ -> fail str+  {-# INLINE fail #-} -instance (Monoid x, MonadDrunk r s m) => MonadDrunk r s (Strict.WriterT x m) where-  drink = lift drink-  spit = lift . spit-  call = lift . call+instance MonadTrans (Drinker t) where+  lift m = Drinker $ \t -> m >>= \a -> return (a, t)+  {-# INLINE lift #-} -instance (Monoid y, MonadDrunk r s m) => MonadDrunk r s (Lazy.RWST x y z m) where-  drink = lift drink-  spit = lift . spit-  call = lift . call+instance MonadIO m => MonadIO (Drinker t m) where+  liftIO = lift . liftIO -instance (Monoid y, MonadDrunk r s m) => MonadDrunk r s (Strict.RWST x y z m) where-  drink = lift drink-  spit = lift . spit-  call = lift . call+instance MonadReader r m => MonadReader r (Drinker t m) where+  ask = lift ask+  local f = mapDrinker (local f) -instance MonadDrunk r s m => MonadDrunk r s (MaybeT m) where-  drink = lift drink-  spit = lift . spit-  call = lift . call+instance MonadState s m => MonadState s (Drinker t m) where+  get = lift get+  put = lift . put+  state = lift . state -instance MonadDrunk r s m => MonadDrunk r s (ContT x m) where-  drink = lift drink-  spit = lift . spit-  call = lift . call+instance MonadWriter s m => MonadWriter s (Drinker t m) where+  writer = lift . writer+  tell   = lift . tell+  listen m = Drinker $ \s -> do+    ((a, s'), w) <- listen (runDrinker m s)+    return ((a, w), s')+  pass m = Drinker $ \s -> pass $ do+    ((a, f), s') <- runDrinker m s+    return ((a, s'), f) --- | Get one element without consuming.-smell :: MonadDrunk r s m => m s-smell = do-  s <- drink-  spit s-  return s+-- | Monads that drink+class Monad m => MonadDrunk t m | m -> t where+  drinking :: (forall n. Monad n => t n -> n (a, t n)) -> m a +instance Monad m => MonadDrunk t (Drinker t m) where+  drinking = Drinker++instance MonadDrunk t m => MonadDrunk t (Reader.ReaderT x m) where+  drinking f = lift (drinking f)++instance MonadDrunk t m => MonadDrunk t (Lazy.StateT x m) where+  drinking f = lift (drinking f)++instance MonadDrunk t m => MonadDrunk t (Strict.StateT x m) where+  drinking f = lift (drinking f)++instance (Monoid x, MonadDrunk t m) => MonadDrunk t (Lazy.WriterT x m) where+  drinking f = lift (drinking f)++instance (Monoid x, MonadDrunk t m) => MonadDrunk t (Strict.WriterT x m) where+  drinking f = lift (drinking f)++instance (Monoid y, MonadDrunk t m) => MonadDrunk t (Lazy.RWST x y z m) where+  drinking f = lift (drinking f)++instance (Monoid y, MonadDrunk t m) => MonadDrunk t (Strict.RWST x y z m) where+  drinking f = lift (drinking f)++instance MonadDrunk t m => MonadDrunk t (MaybeT m) where+  drinking f = lift (drinking f)++instance MonadDrunk t m => MonadDrunk t (ContT x m) where+  drinking f = lift (drinking f)+ class CloseRequest a where   -- | A value representing a close request   closeRequest :: a@@ -89,3 +133,7 @@  instance CloseRequest a => CloseRequest [a] where   closeRequest = [closeRequest]++-- | Closable tap+class Closable t where+  close :: Monad m => t m -> m ()

@@ -0,0 +1,50 @@+{-# LANGUAGE LambdaCase, FlexibleContexts #-}+-----------------------------------------------------------------------+--+-- Module      :  Data.Drinkery.Combinators+-- Copyright   :  (c) Fumiaki Kinoshita 2017+-- License     :  BSD3+--+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-----------------------------------------------------------------------+module Data.Drinkery.Combinators+  ( foldlFrom'+  , foldMFrom+  , traverseFrom_+  , drainFrom+  )+where++import Control.Monad hiding (foldM)+import qualified Data.Foldable as F++foldlFrom' :: (Foldable t, Monad m) => m (t a) -> (b -> a -> b) -> b -> m b+foldlFrom' m f = go where+  go b = do+    t <- m+    if null t+      then return b+      else go $! F.foldl' f b t+{-# INLINE foldlFrom' #-}++foldMFrom :: (Foldable t, Monad m) => m (t a) -> (b -> a -> m b) -> b -> m b+foldMFrom m f = go where+  go b = do+    t <- m+    if null t+      then return b+      else F.foldlM f b t >>= go+{-# INLINE foldMFrom #-}++traverseFrom_ :: (Foldable t, Monad m) => m (t a) -> (a -> m b) -> m ()+traverseFrom_ m f = go where+  go = do+    t <- m+    if null t then return () else F.traverse_ f t >> go+{-# INLINE traverseFrom_ #-}++drainFrom :: (Foldable t, Monad m) => m (t a) -> m ()+drainFrom m = go where+  go = m >>= \t -> unless (null t) go+{-# INLINE drainFrom #-}

@@ -14,75 +14,49 @@   -- * Special combinators   , (+&)   , ($&)-  -- * Attaching a distiller+  -- * Basic combinators   , (++$)-  , ($$$)-  -- * Patron   , (++&)-  , ($$&)   -- * Stock distillers+  , Still+  , scanningMaybe+  , filteringMaybe   , mapping   , traversing   , filtering   , scanning-  , scanningMaybe-  , throughMaybe-  -- * Internal-  , boozeOn-  , distillWith   ) where -import Control.Monad.Trans.Class+import Control.Monad.Trans import Data.Drinkery.Tap import Data.Drinkery.Class-import Data.Drinkery.Boozer--boozeOn :: (Monoid r, Monad m) => (forall x. n x -> m x)-  -> (r -> [s] -> Tap m r s -> a -> m z)-  -> r -> [s] -> Tap m r s-  -> Boozer r s n a-  -> m z-boozeOn t cont = go where-  go !r [] (Tap f) (Drink k) = f r >>= \(s, b) -> go mempty [] b (k s)-  go !r (s : ss) b (Drink f) = go r ss b (f s)-  go !r ss b (Spit s k) = go r (s : ss) b k-  go !r ss b (Call r' k) = go (mappend r r') ss b k-  go !r ss b (Lift m) = t m >>= go r ss b-  go !r ss b (Pure a) = cont r ss b a-{-# INLINE boozeOn #-}+import Data.Tuple --- | 'Distiller p q m r s' is a stream transducer which has five parameters:+-- | @Distiller tap m r s@ is a stream transducer which has four parameters: ----- * @p@ request to the upstream--- * @q@ input--- * @m@ underlying monad+-- * @tap@ input -- * @r@ request from the downstream -- * @s@ output-type Distiller p q m = Tap (Patron p q m)--distillWith :: (Monoid p, Monad m) => (forall x. n x -> m x) -> Tap m p q -> Distiller p q n r s -> Tap m r s-distillWith trans = go mempty [] where-  go r lo b (Tap m) = Tap $ \rs -> boozeOn trans-    (\r' lo' b' (s, cont) -> pure (s, go r' lo' b' cont))-    r lo b (runPatron (m rs))-{-# INLINE distillWith #-}+-- * @m@ underlying monad+--+-- This is also a 'Tap'.+--+type Distiller tap r s m = Tap r s (Drinker tap m)  infix 6 +& infixr 7 $&-infix 6 ++&-infixl 7 ++$-infixr 7 $$&-infixl 8 $$$+infixr 7 ++&+infixl 8 ++$ --- | Connect a tap with a patron.+-- | Connect a tap with a Drinker. Flipped 'runDrinker'. -- -- Mnemonic: -- -- * @+@ Left operand is a tap. -- * @+@ Returns a tap (along with the result).--- * @&@ Right operand is a patron.-(++&) :: (Monoid r, Monad m) => Tap m r s -> Patron r s m a -> m (Tap m r s, a)-t ++& p = boozeOn id (\r s t' a -> pure (orderTap r $ foldr consTap t' s, a)) mempty [] t (runPatron p)+-- * @&@ Right operand is a Drinker.+(++&) :: (Functor m) => tap m -> Drinker tap m a -> m (tap m, a)+d ++& b = swap <$> runDrinker b d {-# INLINE (++&) #-}  -- | Attach a distiller to a tap.@@ -92,81 +66,66 @@ -- * @+@ Left operand is a tap. -- * @+@ Returns a tap. -- * @$@ Right operand is a distiller.-(++$) :: (Monoid p, Monad m) => Tap m p q -> Distiller p q m r s -> Tap m r s-(++$) = distillWith id-{-# INLINE (++$) #-}---- | Full duplex composition of distillers. ----- Mnemonic:------ * @$@ Left operand is a distiller.--- * @$@ Returns a distiller.--- * @$@ Right operand is a distiller.-($$$) :: (Monoid r, Monad m) => Distiller p q m r s -> Distiller r s m t u -> Distiller p q m t u-($$$) = distillWith lift-{-# INLINE ($$$) #-}---- | Attach a distiller to a patron.------ Mnemonic:------ * @$@ Left operand is a distiller.--- * @$@ Returns the used distiller.--- * @&@ Right operand is a patron.-($$&) :: (Monoid r, Monad m) => Distiller p q m r s -> Patron r s m a-  -> Patron p q m (Distiller p q m r s, a)-d $$& b = boozeOn lift (\r s t a -> pure (orderTap r $ foldr consTap t s, a)) mempty [] d (runPatron b)-{-# INLINE ($$&) #-}+(++$) :: (Functor m) => tap m -> Distiller tap r s m -> Tap r s m+(++$) = go where -- looks strange, but seems to perform better (GHC 8.2.2)+  go t d = Tap $ \r -> (\((s, d'), t') -> (s, go t' d'))+    <$> runDrinker (unTap d r) t+{-# INLINE (++$) #-} --- | Connect a tap with a patron and close the used tap.-(+&) :: (Monoid r, CloseRequest r, Monad m) => Tap m r s -> Patron r s m a -> m a+-- | Feed a tap to a drinker and close the used tap.+(+&) :: (Closable tap, Monad m) => tap m -> Drinker tap m a -> m a t +& b = do-  (t', a) <- t ++& b-  _ <- unTap t' closeRequest+  (a, t') <- runDrinker b t+  close t'   return a {-# INLINE (+&) #-} --- | Like '$&&' but discards the used distiller.-($&) :: (Monoid r, Monad m) => Distiller p q m r s -> Patron r s m a -> Patron p q m a-t $& b = fmap snd $ t $$& b+-- | Like ('+&') but discards the used tap.+--+-- @($&) :: Distiller tap m r s -> Drinker (Tap r s) (Drinker tap m) a -> Drinker tap m a@+--+($&) :: (Monad m) => tap m -> Drinker tap m a -> m a+t $& b = fmap fst $ runDrinker b t {-# INLINE ($&) #-} +-- | Mono in/out+type Still p q r s m = Distiller (Tap p q) r s m++scanningMaybe :: (Monoid r, Monad m) => (b -> a -> b) -> b -> Still r (Maybe a) r (Maybe b) m+scanningMaybe f b0 = consTap (Just b0) $ go b0 where+  go b = Tap $ \r -> Drinker $ \tap -> do+    (m, t') <- unTap tap r+    case m of+      Just a -> let !b' = f b a in return ((Just b', go b'), t')+      Nothing -> return ((Nothing, go b), t')+{-# INLINE scanningMaybe #-}++filteringMaybe :: (Monoid r, Monad m) => (a -> Bool) -> Still r (Maybe a) r (Maybe a) m+filteringMaybe = filtering . maybe True+{-# INLINE filteringMaybe #-}+ -- | Create a request-preserving distiller.-propagating :: Functor m => Patron r a m (b, Distiller r a m r b) -> Distiller r a m r b-propagating m = Tap $ \r -> call r >> m+propagating :: (Monoid r, Monad m) => Drinker (Tap r a) m (b, Still r a r b m) -> Still r a r b m+propagating m = Tap $ \r -> request r >> m {-# INLINE propagating #-} -mapping :: Functor m => (a -> b) -> Distiller r a m r b-mapping f = propagating $ drink >>= \a -> return (f a, mapping f)+mapping :: (Monoid r, Monad m) => (a -> b) -> Still r a r b m+mapping f = go where+  go = propagating $ drink >>= \a -> return (f a, go)+{-# INLINE mapping #-} -traversing :: Monad m => (a -> m b) -> Distiller r a m r b-traversing f = propagating $ drink >>= \a -> lift (f a) >>= \b -> return (b, traversing f)+traversing :: (Monoid r, Monad m) => (a -> m b) -> Still r a r b m+traversing f = go where+  go = propagating $ drink >>= \a -> lift (f a) >>= \b -> return (b, go) -filtering :: (Monoid r, Functor m) => (a -> Bool) -> Distiller r a m r a-filtering f = propagating $ drink >>= \a -> if f a-  then return (a, filtering f)-  else unTap (filtering f) mempty+filtering :: (Monoid r, Monad m) => (a -> Bool) -> Still r a r a m+filtering f = go where+  go = propagating $ drink >>= \a -> if f a+    then return (a, go)+    else unTap go mempty -scanning :: (Monoid r, Functor m) => (b -> a -> b) -> b -> Distiller r a m r b+scanning :: (Monoid r, Monad m) => (b -> a -> b) -> b -> Still r a r b m scanning f b0 = consTap b0 $ go b0 where   go b = propagating $ fmap (\a -> let !b' = f b a in (b', go $ b')) drink {-# INLINE scanning #-}--scanningMaybe :: (Monoid r, Functor m) => (b -> a -> b) -> b -> Distiller r (Maybe a) m r (Maybe b)-scanningMaybe f b0 = consTap (Just b0) $ go b0 where-  go b = Tap $ \r -> Patron $ \cont -> Call r $ Drink $ \case-    Just a -> let !b' = f b a in cont (Just b', go b')-    Nothing -> cont (Nothing, go b)-{-# INLINE scanningMaybe #-}---- | Transform a 'Distiller' to operate on a stream of 'Maybe's.-throughMaybe :: (Monoid r, Monad m) => Distiller p q m r s -> Distiller p (Maybe q) m r (Maybe s)-throughMaybe d = Tap $ \rs -> iterBoozer-  (\qs (s, d') -> (Just s, throughMaybe d') <$ mapM_ (spit . Just) qs)-  (\cont -> drink >>= maybe (pure end) cont)-  (\p cont -> call p >> cont)-  ((>>=) . lift)-  $ runPatron $ unTap d rs-  where-    end = (Nothing, throughMaybe d)

@@ -1,71 +0,0 @@-{-# LANGUAGE LambdaCase #-}------------------------------------------------------------------------------ Module      :  Data.Drinkery.Glass--- Copyright   :  (c) Fumiaki Kinoshita 2017--- License     :  BSD3------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>------ Things to work with finite streams-------------------------------------------------------------------------module Data.Drinkery.Glass-  ( eof-  , runBarman-  , runSommelier-  , pour-  -- * 'MonadDrunk' actions-  , foldl'-  , foldM-  , traverse_-  , sinkNull-  )-where--import Control.Applicative-import Control.Monad hiding (foldM)-import Data.Drinkery.Class-import Data.Drinkery.Tap-import qualified Data.Foldable as F---- | End of stream-eof :: (Applicative m, Alternative f) => Tap m r (f a)-eof = Tap $ const $ pure (empty, eof)---- | Run a 'Barman' action and terminate the stream with 'eof'.-runBarman :: (Monoid r, Applicative m, Alternative f) => Barman r (f s) m a -> Tap m r (f s)-runBarman m = unBarman m (const eof)-{-# INLINE runBarman #-}---- | Run 'Sommelier' and terminate the stream with 'eof'.-runSommelier :: (Monoid r, Applicative m, Alternative f) => Sommelier r m s -> Tap m r (f s)-runSommelier m = unSommelier m (consTap . pure) eof-{-# INLINE runSommelier #-}--pour :: (Monoid r, Applicative f, Applicative m) => s -> Barman r (f s) m ()-pour = topup . pure--foldl' :: (Foldable t, MonadDrunk r (t a) m) => (b -> a -> b) -> b -> m b-foldl' f = go where-  go b = do-    t <- drink-    if null t-      then return b-      else go $! F.foldl' f b t--foldM :: (Foldable t, MonadDrunk r (t a) m) => (b -> a -> m b) -> b -> m b-foldM f = go where-  go b = do-    t <- drink-    if null t-      then return b-      else F.foldlM f b t >>= go--traverse_ :: (Foldable t, MonadDrunk r (t a) m) => (a -> m b) -> m ()-traverse_ f = go where-  go = do-    t <- drink-    if null t then return () else F.traverse_ f t >> go--sinkNull :: (Foldable t, MonadDrunk r (t a) m) => m ()-sinkNull = drink >>= \t -> unless (null t) sinkNull

@@ -0,0 +1,78 @@+{-# LANGUAGE LambdaCase, DeriveFunctor #-}+module Data.Drinkery.Patron where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans++-- | @Patron s@ is a simple consumer of @s@. Unlike 'Drinker', it can be+-- partially run.+--+-- 'serving' distributes each input to a list of 'Patron's until all the patrons+-- terminate.+-- ('<|>') returns the first result.+--+newtype Patron s m a = Patron { runPatron :: m (Either (s -> Patron s m a) a) }++instance Functor m => Functor (Patron s m) where+  fmap f (Patron m) = Patron $ either (Left . (fmap f .)) (Right . f) <$> m++instance Monad m => Applicative (Patron s m) where+  pure a = Patron $ pure $ Right a+  {-# INLINE pure #-}+  m <*> k = Patron $ runPatron m >>= \case+    Right f -> runPatron $ f <$> k+    Left f -> pure $ Left $ (<*> k) . f++instance Monad m => Monad (Patron s m) where+  return = pure+  Patron m >>= k = Patron $ m >>= \case+    Right a -> runPatron (k a)+    Left f -> pure $ Left $ (>>=k) . f++instance MonadTrans (Patron s) where+  lift = Patron . fmap Right++instance Monad m => Alternative (Patron s m) where+  empty = Patron $ pure $ Left $ const empty+  Patron l <|> Patron r = Patron $ l >>= \case+    Left f -> r >>= \case+      Left g -> return $ Left $ \x -> f x <|> g x+      Right a -> return $ Right a+    Right a -> return $ Right a++instance Monad m => MonadPlus (Patron s m) where+  mzero = empty+  mplus = (<|>)++await :: Monad m => Patron s m s+await = Patron $ pure $ Left pure+{-# INLINE await #-}++serving_ :: Monad m => [Patron s m a] -> Patron s m ()+serving_ t0 = lift (gather runPatron t0) >>= go+  where+    gather k = loop where+      loop (m : ms) = k m >>= \case+        Left f -> (f :) <$> loop ms+        Right _ -> loop ms+      loop [] = pure []+    go [] = return ()+    go t = do+      s <- await+      lift (gather (\f -> runPatron (f s)) t) >>= go++iterPatron :: Monad m => m s -> Patron s m a -> m a+iterPatron k = go where+  go m = runPatron m >>= \case+    Left f -> k >>= go . f+    Right a -> return a+{-# INLINE iterPatron #-}++-- | @iterPatronT drink :: Patron s m a -> Drinker s m a@+iterPatronT :: (Monad m, MonadTrans t, Monad (t m)) => t m s -> Patron s m a -> t m a+iterPatronT k = go where+  go m = lift (runPatron m) >>= \case+    Left f -> k >>= go . f+    Right a -> return a+{-# INLINE iterPatronT #-}

@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}+{-# LANGUAGE Rank2Types, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} ----------------------------------------------------------------------- -- -- Module      :  Data.Drinkery.Tap@@ -10,17 +10,32 @@ -- Stream producers ----------------------------------------------------------------------- module Data.Drinkery.Tap (+  -- * Tap   Tap(..)   , consTap   , orderTap   , makeTap+  -- * Barman   , Barman(..)-  , topup+  , yield   , accept   , inexhaustible+  , runBarman+  , runBarman'+  , pour+  -- * Sommelier   , Sommelier(..)   , taste   , inquire+  , runSommelier+  , runSommelier'+  -- * Drinker+  , drink+  , leftover+  , request+  , smell+  -- * End of stream+  , eof ) where  import Control.Applicative@@ -31,32 +46,55 @@  -- | @'Tap' m r s@ is a non-monadic, endless producer of @s@. It takes a request -- @r@.-newtype Tap m r s = Tap { unTap :: r -> m (s, Tap m r s) }+newtype Tap r s m = Tap { unTap :: r -> m (s, Tap r s m) }  -- | Prepend a new element, delaying requests.-consTap :: (Monoid r, Applicative m) => s -> Tap m r s -> Tap m r s+consTap :: (Monoid r, Applicative m) => s -> Tap r s m -> Tap r s m consTap s t = Tap $ \r -> pure (s, Tap $ unTap t . mappend r) {-# INLINE consTap #-}  -- | Send a request to a 'Tap'.-orderTap :: (Monoid r) => r -> Tap m r s -> Tap m r s+orderTap :: (Monoid r) => r -> Tap r s m -> Tap r s m orderTap r t = Tap $ \r' -> unTap t $! mappend r r' {-# INLINE orderTap #-}  -- | Involve an action.-makeTap :: (Monoid r, Monad m) => m (Tap m r s) -> Tap m r s+makeTap :: (Monoid r, Monad m) => m (Tap r s m) -> Tap r s m makeTap m = Tap $ \r -> m >>= \t -> unTap t r {-# INLINE makeTap #-} +instance CloseRequest r => Closable (Tap r s) where+  close t = void $ unTap t closeRequest++drink :: (Monoid r, MonadDrunk (Tap r s) m) => m s+drink = drinking $ \t -> unTap t mempty+{-# INLINE drink #-}++leftover :: (Monoid r, MonadDrunk (Tap r s) m) => s -> m ()+leftover s = drinking $ \t -> return ((), consTap s t)+{-# INLINE leftover #-}++request :: (Monoid r, MonadDrunk (Tap r s) m) => r -> m ()+request r = drinking $ \t -> return ((), orderTap r t)+{-# INLINE request #-}++-- | Get one element without consuming.+smell :: (Monoid r, MonadDrunk (Tap r s) m) => m s+smell = do+  s <- drink+  leftover s+  return s+{-# INLINE smell #-}+ -- | Monadic producer-newtype Barman r s m a = Barman { unBarman :: (a -> Tap m r s) -> Tap m r s }+newtype Barman r s m a = Barman { unBarman :: (a -> Tap r s m) -> Tap r s m }  instance Functor (Barman r s m) where-  fmap = liftM+  fmap f (Barman m) = Barman $ \cont -> m (cont . f)  instance Applicative (Barman r s m) where   pure = return-  (<*>) = ap+  Barman m <*> Barman k = Barman $ \cont -> m $ \f -> k $ cont . f  instance Monad (Barman r s m) where   return a = Barman ($ a)@@ -65,14 +103,12 @@ instance MonadTrans (Barman r s) where   lift m = Barman $ \k -> Tap $ \rs -> m >>= \a -> unTap (k a) rs -instance MonadDrunk r s m => MonadDrunk r s (Barman p q m) where-  drink = lift drink-  spit = lift . spit-  call = lift . call+instance MonadDrunk t m => MonadDrunk t (Barman p q m) where+  drinking f = lift (drinking f)  -- | Produce one element. Orders are put off.-topup :: (Monoid r, Applicative m) => s -> Barman r s m ()-topup s = Barman $ \cont -> consTap s (cont ())+yield :: (Monoid r, Applicative m) => s -> Barman r s m ()+yield s = Barman $ \cont -> consTap s (cont ())  -- | Accept orders and clear the queue. accept :: Monoid r => Barman r s m r@@ -80,14 +116,14 @@  -- | Create a infinite 'Tap' from a 'Barman'. ----- @Barman r s (Boozer p q m) x -> Distiller p q m r s@+-- @inexhaustible :: 'Barman' r s ('Drinker' tap m) x -> 'Distiller' tap m r s@ ---inexhaustible :: Barman r s m x -> Tap m r s+inexhaustible :: Barman r s m x -> Tap r s m inexhaustible t = unBarman t $ const $ inexhaustible t  -- | Backtracking producer a.k.a. "ListT done right". newtype Sommelier r m s = Sommelier-  { unSommelier :: forall x. (s -> Tap m r x -> Tap m r x) -> Tap m r x -> Tap m r x }+  { unSommelier :: forall x. (s -> Tap r x m -> Tap r x m) -> Tap r x m -> Tap r x m }  instance Functor (Sommelier r m) where   fmap f m = Sommelier $ \c e -> unSommelier m (c . f) e@@ -104,16 +140,18 @@   empty = Sommelier $ \_ e -> e   a <|> b = Sommelier $ \c e -> unSommelier a c (unSommelier b c e) +instance MonadPlus (Sommelier r m) where+  mzero = empty+  mplus = (<|>)+ instance MonadTrans (Sommelier r) where   lift m = Sommelier $ \c e -> Tap $ \rs -> m >>= \a -> unTap (c a e) rs  instance MonadIO m => MonadIO (Sommelier r m) where   liftIO m = Sommelier $ \c e -> Tap $ \rs -> liftIO m >>= \a -> unTap (c a e) rs -instance MonadDrunk r s m => MonadDrunk r s (Sommelier p m) where-  drink = lift drink-  spit = lift . spit-  call = lift . call+instance MonadDrunk t m => MonadDrunk t (Sommelier p m) where+  drinking f = lift (drinking f)  -- | Take all the elements in a 'Foldable' container. taste :: Foldable f => f s -> Sommelier r m s@@ -122,3 +160,31 @@ -- | Get a request. inquire :: Monoid r => Sommelier r m r inquire = Sommelier $ \c e -> Tap $ \rs -> unTap (c rs e) mempty++-- | End of stream+eof :: (Applicative m, Alternative f) => Tap r (f a) m+eof = Tap $ const $ pure (empty, eof)++-- | Run a 'Barman' action and terminate the stream with 'eof'.+runBarman :: (Monoid r, Applicative m, Alternative f) => Barman r (f s) m a -> Tap r (f s) m+runBarman m = unBarman m (const eof)+{-# INLINE runBarman #-}++-- | Specialised 'runBarman'+runBarman' :: (Applicative m, Alternative f) => Barman () (f s) m a -> Tap () (f s) m+runBarman' = runBarman+{-# INLINE runBarman' #-}++-- | Run 'Sommelier' and terminate the stream with 'eof'.+runSommelier :: (Monoid r, Applicative m, Alternative f) => Sommelier r m s -> Tap r (f s) m+runSommelier m = unSommelier m (consTap . pure) eof+{-# INLINE runSommelier #-}++-- | Specialised 'runSommelier'+runSommelier' :: (Applicative m, Alternative f) => Sommelier () m s -> Tap () (f s) m+runSommelier' = runSommelier+{-# INLINE runSommelier' #-}++pour :: (Monoid r, Applicative f, Applicative m) => s -> Barman r (f s) m ()+pour = yield . pure+{-# INLINE pour #-}