drinkery (empty) → 0

raw patch · 11 files changed

+789/−0 lines, 11 filesdep +basedep +criteriondep +drinkerysetup-changed

Dependencies added: base, criterion, drinkery, mtl, transformers

Files

LICENSE +30/−0
README.md +89/−0
Setup.hs +2/−0
benchmarks/benchmark.hs +23/−0
drinkery.cabal +39/−0
src/Data/Drinkery.hs +11/−0
src/Data/Drinkery/Boozer.hs +137/−0
src/Data/Drinkery/Class.hs +91/−0
src/Data/Drinkery/Distiller.hs +172/−0
src/Data/Drinkery/Glass.hs +71/−0
src/Data/Drinkery/Tap.hs +124/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Fumiaki Kinoshita (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Fumiaki Kinoshita nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER 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.

+ README.md view

@@ -0,0 +1,89 @@+# drinkery++drinkery is a yet another stream processing library themed on liquors. While it+offers a simple interface, it also tries to be as expressive as possible.++## Producers++drinkery supports three types of producers: `Barman`, `Sommelier`, and `Tap`.++`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.+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).+It is useful for sampling elements of containers with effects.+`taste :: Foldable f => f s -> Sommelier r m s` samples elements in any `Foldable`+container. `inquire` to interact with the downstream.++`Tap` is an endless producer. This can be connected to a 'Patron' or a 'Distiller'.++`Barman` and `Sommelier` are converted to `Tap`+by `runBarman` and `runSommelier` respectively.++## Consumer++`Patron r s` is a monad transformer which consumes `s` and may request `r`.++`MonadDrink` provides the actions of `Patron`:++* `drink :: m s` Get one element.+* `spit :: s -> m ()` Leave one element.+* `call :: 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.++## Transducer++`Distiller p q m r s` is a stream transducer which++* Sends `p`+* Consumes `q`+* Receives `r`+* Produces `s`++It is actually a `Tap` where the underlying monad is `Patron`.++There are three composition operators:++* `$&` Distiller-patron+* `$$$` Distiler-distiller+* `++$` Tap-distiller++`+`, `&`, and `$` means a tap, a patron, and a distiller respectively. The middle+characters of these operators signify the resulting structures.++## Why drinkery?++drinkery is designed to be fully featured and complements other libraries' missing+functionalities.++### pipes++`pipes` is quite similar in that both `Proxy` and `Distiller` are bidirectional.+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`+    * `(>->) :: 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.+* `drinkery` has much fewer operators.++### conduit++Both `drinkery` and `conduit` support leftovers, closing operation, and end of stream.+The main difference is interactivity.++### machines++`machines` has multi-channel consumers but `drinkery` doesn't.+`machines` does not support leftovers, nor interactive producers.++### 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ benchmarks/benchmark.hs view

@@ -0,0 +1,23 @@+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.List
+import Data.Void
+
+drainD :: D.Distiller () (Maybe Int) IO () (Maybe a) -> IO ()
+drainD h = sourceD D.+& h D.$& D.sinkNull
+
+value :: Int
+value = 10000
+
+sourceD :: (Monoid r, Monad m) => D.Tap m r (Maybe Int)
+sourceD = D.runSommelier $ D.taste [1..value]
+
+main = defaultMain
+  [ bgroup "scan"
+      [ bench "drinkery" $ whnfIO $ drainD (D.scanningMaybe (+) 0)
+      ]
+  ]

+ drinkery.cabal view

@@ -0,0 +1,39 @@+name:                drinkery+version:             0+synopsis:            Boozy streaming library+description:         Boozy streaming library+homepage:            https://github.com/fumieval/drinkery#readme+license:             BSD3+license-file:        LICENSE+author:              Fumiaki Kinoshita+maintainer:          fumiexcel@gmail.com+copyright:           Copyright (c) 2017 Fumiaki Kinoshita+category:            Data+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:+    Data.Drinkery+    Data.Drinkery.Class+    Data.Drinkery.Boozer+    Data.Drinkery.Distiller+    Data.Drinkery.Glass+    Data.Drinkery.Tap+  build-depends:       base >= 4.7 && < 5, transformers, mtl+  ghc-options: -Wall+  default-language:    Haskell2010++benchmark benchmark+  type:           exitcode-stdio-1.0+  main-is:        benchmark.hs+  ghc-options:    -O2+  hs-source-dirs: benchmarks+  build-depends: base, drinkery, criterion+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/fumieval/drinkery

+ src/Data/Drinkery.hs view

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

+ src/Data/Drinkery/Boozer.hs view

@@ -0,0 +1,137 @@+{-# 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

+ src/Data/Drinkery/Class.hs view

@@ -0,0 +1,91 @@+{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor #-}+-----------------------------------------------------------------------+--+-- Module      :  Data.Drinkery.Class+-- Copyright   :  (c) Fumiaki Kinoshita 2017+-- License     :  BSD3+--+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- Basic classes+-----------------------------------------------------------------------+module Data.Drinkery.Class where++import Control.Monad.Trans.Class+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.Reader as Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+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++class Monad m => MonadDrunk r s m | m -> r s where+  drink :: m s+  spit :: s -> m ()+  call :: r -> m ()++instance MonadDrunk r s m => MonadDrunk r s (Reader.ReaderT x m) where+  drink = lift drink+  spit = lift . spit+  call = lift . call++instance MonadDrunk r s m => MonadDrunk r s (Lazy.StateT x m) where+  drink = lift drink+  spit = lift . spit+  call = lift . call++instance MonadDrunk r s m => MonadDrunk r s (Strict.StateT x m) where+  drink = lift drink+  spit = lift . spit+  call = lift . call++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 (Monoid x, MonadDrunk r s m) => MonadDrunk r s (Strict.WriterT x m) where+  drink = lift drink+  spit = lift . spit+  call = lift . call++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 (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 MonadDrunk r s m => MonadDrunk r s (MaybeT m) where+  drink = lift drink+  spit = lift . spit+  call = lift . call++instance MonadDrunk r s m => MonadDrunk r s (ContT x m) where+  drink = lift drink+  spit = lift . spit+  call = lift . call++-- | Get one element without consuming.+smell :: MonadDrunk r s m => m s+smell = do+  s <- drink+  spit s+  return s++class CloseRequest a where+  -- | A value representing a close request+  closeRequest :: a++instance CloseRequest () where+  closeRequest = ()++instance CloseRequest a => CloseRequest [a] where+  closeRequest = [closeRequest]

+ src/Data/Drinkery/Distiller.hs view

@@ -0,0 +1,172 @@+{-# LANGUAGE Rank2Types, BangPatterns, LambdaCase, FlexibleContexts #-}+-----------------------------------------------------------------------+--+-- Module      :  Data.Drinkery.Distiller+-- Copyright   :  (c) Fumiaki Kinoshita 2017+-- License     :  BSD3+--+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- Stream transducers+-----------------------------------------------------------------------+module Data.Drinkery.Distiller+  ( Distiller+  -- * Special combinators+  , (+&)+  , ($&)+  -- * Attaching a distiller+  , (++$)+  , ($$$)+  -- * Patron+  , (++&)+  , ($$&)+  -- * Stock distillers+  , mapping+  , traversing+  , filtering+  , scanning+  , scanningMaybe+  , throughMaybe+  -- * Internal+  , boozeOn+  , distillWith+  ) where++import Control.Monad.Trans.Class+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 #-}++-- | 'Distiller p q m r s' is a stream transducer which has five parameters:+--+-- * @p@ request to the upstream+-- * @q@ input+-- * @m@ underlying monad+-- * @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 #-}++infix 6 +&+infixr 7 $&+infix 6 ++&+infixl 7 ++$+infixr 7 $$&+infixl 8 $$$++-- | Connect a tap with a patron.+--+-- 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)+{-# INLINE (++&) #-}++-- | Attach a distiller to a tap.+--+-- Mnemonic:+--+-- * @+@ 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 ($$&) #-}++-- | 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+t +& b = do+  (t', a) <- t ++& b+  _ <- unTap t' closeRequest+  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+{-# INLINE ($&) #-}++-- | 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+{-# INLINE propagating #-}++mapping :: Functor m => (a -> b) -> Distiller r a m r b+mapping f = propagating $ drink >>= \a -> return (f a, mapping f)++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)++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++scanning :: (Monoid r, Functor m) => (b -> a -> b) -> b -> Distiller r a m r b+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)

+ src/Data/Drinkery/Glass.hs view

@@ -0,0 +1,71 @@+{-# 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

+ src/Data/Drinkery/Tap.hs view

@@ -0,0 +1,124 @@+{-# LANGUAGE Rank2Types, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}+-----------------------------------------------------------------------+--+-- Module      :  Data.Drinkery.Tap+-- Copyright   :  (c) Fumiaki Kinoshita 2017+-- License     :  BSD3+--+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- Stream producers+-----------------------------------------------------------------------+module Data.Drinkery.Tap (+  Tap(..)+  , consTap+  , orderTap+  , makeTap+  , Barman(..)+  , topup+  , accept+  , inexhaustible+  , Sommelier(..)+  , taste+  , inquire+) where++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Drinkery.Class++-- | @'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) }++-- | Prepend a new element, delaying requests.+consTap :: (Monoid r, Applicative m) => s -> Tap m r s -> Tap m r s+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 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 m = Tap $ \r -> m >>= \t -> unTap t r+{-# INLINE makeTap #-}++-- | Monadic producer+newtype Barman r s m a = Barman { unBarman :: (a -> Tap m r s) -> Tap m r s }++instance Functor (Barman r s m) where+  fmap = liftM++instance Applicative (Barman r s m) where+  pure = return+  (<*>) = ap++instance Monad (Barman r s m) where+  return a = Barman ($ a)+  Barman m >>= k = Barman $ \cont -> m $ \a -> unBarman (k a) cont++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++-- | Produce one element. Orders are put off.+topup :: (Monoid r, Applicative m) => s -> Barman r s m ()+topup s = Barman $ \cont -> consTap s (cont ())++-- | Accept orders and clear the queue.+accept :: Monoid r => Barman r s m r+accept = Barman $ \cont -> Tap $ \rs -> unTap (cont rs) mempty++-- | 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 m x -> Tap m r s+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 }++instance Functor (Sommelier r m) where+  fmap f m = Sommelier $ \c e -> unSommelier m (c . f) e++instance Applicative (Sommelier r m) where+  pure = return+  (<*>) = ap++instance Monad (Sommelier r m) where+  return s = Sommelier $ \c e -> c s e+  m >>= k = Sommelier $ \c e -> unSommelier m (\s -> unSommelier (k s) c) e++instance Alternative (Sommelier r m) where+  empty = Sommelier $ \_ e -> e+  a <|> b = Sommelier $ \c e -> unSommelier a c (unSommelier b c e)++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++-- | Take all the elements in a 'Foldable' container.+taste :: Foldable f => f s -> Sommelier r m s+taste xs = Sommelier $ \c e -> foldr c e xs++-- | Get a request.+inquire :: Monoid r => Sommelier r m r+inquire = Sommelier $ \c e -> Tap $ \rs -> unTap (c rs e) mempty