drinkery 0.1 → 0.2

raw patch · 7 files changed

+253/−100 lines, 7 filesdep +exceptionsdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• benchmarks/benchmark.hs +14/−17
• drinkery.cabal +67/−34
• src/Data/Drinkery/Distiller.hs +39/−34
• src/Data/Drinkery/IO.hs +20/−0
• src/Data/Drinkery/Patron.hs +13/−1
• src/Data/Drinkery/Still.hs +59/−0
• src/Data/Drinkery/Tap.hs +41/−14

@@ -4,8 +4,8 @@ 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 Data.Drinkery.Still as D
 import qualified ListT as L
 import qualified Pipes as P
 import qualified Pipes.Prelude as P
@@ -28,7 +28,7 @@ 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 :: Monad m => D.Cask () Int m
 sourceD = D.runSommelier (sourceAlt D.taste)
 {-# INLINE sourceD #-}
 
@@ -36,7 +36,7 @@ sourceP = sourceSeq P.yield
 {-# INLINE sourceP #-}
 
-sourceC :: Monad m => C.Producer m Int
+sourceC :: Monad m => C.ConduitT i Int m ()
 sourceC = sourceSeq C.yield
 {-# INLINE sourceC #-}
 
@@ -48,7 +48,7 @@   [ bgroup "drain"
       [ bench "drinkery/Barman" $ whnfIO
           $ apply (D.+& drainD)
-          $ D.runBarman (sourceSeq D.pour)
+          $ D.runBarman (sourceSeq D.yield)
       , bench "drinkery/Sommelier" $ whnfIO
           $ apply (D.+& drainD) sourceD
       , bench "pipes/Producer" $ whnfIO
@@ -58,30 +58,27 @@           $ 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
+          $ sourceAlt L.fromFoldable
       ]
   , bgroup "scan"
       [ bench "drinkery" $ whnfIO $ apply (\h -> sourceD D.+& h D.$& drainD)
-          $ D.scanningMaybe (+) 0
+          $ D.scan (+) 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 "conduit" $ whnfIO $ C.runConduit $ apply (\(h, s) -> sourceC C..| h C..| s)
+          (CC.scanl (+) 0, CC.sinkNull)
       , 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 "drinkery/++$" $ whnfIO $ apply (\h -> D.runBarman (sourceSeq D.yield) D.+& h D.$& drainD)
+          $ D.scan (+) 0 D.++$ D.scan (+) 0
+      , bench "drinkery/$&" $ whnfIO $ apply (\(h, h') -> D.runBarman (sourceSeq D.yield) D.+& h D.$& h' D.$& drainD)
+          (D.scan (+) 0, D.scan (+) 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 "conduit" $ whnfIO $ apply (\(h, s) -> C.runConduit $ sourceC C..| h C..| s)
+          (CC.scanl (+) 0 C..| CC.scanl (+) 0, CC.sinkNull)
       , bench "machines" $ whnfIO $ apply (M.runT_ . (sourceM M.~>))
           $ M.scan (+) 0 M.~> M.scan (+) 0
       ]

@@ -1,39 +1,72 @@-name:                drinkery-version:             0.1-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+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: c680196ca0c264db17dcb6cca154fa3a64e957e2d4859e8dd024c4b302e0f731 -library-  hs-source-dirs:      src-  exposed-modules:-    Data.Drinkery-    Data.Drinkery.Class-    Data.Drinkery.Combinators-    Data.Drinkery.Distiller-    Data.Drinkery.Patron-    Data.Drinkery.Tap-  build-depends:       base >= 4.7 && < 5, transformers, mtl-  ghc-options: -Wall-  default-language:    Haskell2010+name:           drinkery+version:        0.2+synopsis:       Boozy streaming library+description:    Please see the README on Github at <https://github.com/fumieval/drinkery#readme>+category:       Control+homepage:       https://github.com/fumieval/drinkery#readme+bug-reports:    https://github.com/fumieval/drinkery/issues+author:         Fumiaki Kinoshita+maintainer:     fumiexcel@gmail.com+copyright:      Copyright (c) 2017 Fumiaki Kinoshita+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10 -benchmark benchmark-  type:           exitcode-stdio-1.0-  main-is:        benchmark.hs-  ghc-options:    -O2-  hs-source-dirs: benchmarks-  build-depends: base, drinkery, gauge, pipes, machines, conduit, conduit-combinators, list-t, ListT-  default-language:    Haskell2010+extra-source-files:+    README.md  source-repository head-  type:     git+  type: git   location: https://github.com/fumieval/drinkery++library+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base <=5+    , exceptions+    , mtl+    , transformers+  exposed-modules:+      Data.Drinkery+      Data.Drinkery.Class+      Data.Drinkery.Combinators+      Data.Drinkery.Distiller+      Data.Drinkery.IO+      Data.Drinkery.Patron+      Data.Drinkery.Still+      Data.Drinkery.Tap+  other-modules:+      Paths_drinkery+  default-language: Haskell2010++benchmark benchmark+  type: exitcode-stdio-1.0+  main-is: benchmark.hs+  hs-source-dirs:+      benchmarks+  ghc-options: -O2+  build-depends:+      ListT+    , base+    , conduit+    , conduit-combinators+    , drinkery+    , exceptions+    , gauge+    , list-t+    , machines+    , mtl+    , pipes+    , transformers+  other-modules:+      Paths_drinkery+  default-language: Haskell2010

@@ -18,18 +18,20 @@   , (++$)   , (++&)   -- * Stock distillers-  , Still-  , scanningMaybe-  , filteringMaybe+  , reservingTap+  , echo   , mapping   , traversing   , filtering   , scanning+  , repeating   ) where +import Control.Monad.Catch (onException, MonadCatch) import Control.Monad.Trans import Data.Drinkery.Tap import Data.Drinkery.Class+import Data.Semigroup import Data.Tuple  -- | @Distiller tap m r s@ is a stream transducer which has four parameters:@@ -74,9 +76,9 @@ {-# INLINE (++$) #-}  -- | Feed a tap to a drinker and close the used tap.-(+&) :: (Closable tap, Monad m) => tap m -> Drinker tap m a -> m a+(+&) :: (Closable tap, MonadCatch m) => tap m -> Drinker tap m a -> m a t +& b = do-  (a, t') <- runDrinker b t+  (a, t') <- runDrinker b t `onException` close t   close t'   return a {-# INLINE (+&) #-}@@ -89,43 +91,46 @@ 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 :: (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 #-}+echo :: Monad m => Distiller (Tap r s) r s m+echo = mapping id -mapping :: (Monoid r, Monad m) => (a -> b) -> Still r a r b m+mapping :: (Monad m) => (a -> b) -> Distiller (Tap r a) r b m mapping f = go where-  go = propagating $ drink >>= \a -> return (f a, go)+  go = Tap $ \r -> drinking $ \t -> fmap (\(s, t') -> ((f s, go), t')) $ unTap t r {-# INLINE mapping #-} -traversing :: (Monoid r, Monad m) => (a -> m b) -> Still r a r b m+-- | Get one element preserving a request+reservingTap :: MonadDrunk (Tap r a) m => (a -> m (s, Tap r s m)) -> Tap r s m+reservingTap k = Tap $ \r -> do+  a <- drinking $ \t -> unTap t r+  k a+{-# INLINE reservingTap #-}++traversing :: (Monad m) => (a -> m b) -> Distiller (Tap r a) r b m traversing f = go where-  go = propagating $ drink >>= \a -> lift (f a) >>= \b -> return (b, go)+  go = reservingTap $ \a -> do+    b <- lift $ f a+    return (b, go)+{-# INLINE traversing #-} -filtering :: (Monoid r, Monad m) => (a -> Bool) -> Still r a r a m+filtering :: (Monoid r, Monad m) => (a -> Bool) -> Distiller (Tap r a) r a m filtering f = go where-  go = propagating $ drink >>= \a -> if f a+  go = reservingTap $ \a -> if f a     then return (a, go)     else unTap go mempty+{-# INLINE filtering #-} -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+scanning :: Monad m => (b -> a -> b) -> b -> Distiller (Tap r a) r b m+scanning f b0 = go b0 where+  go b = reservingTap $ \a -> do+    let !b' = f b a+    return (b', go $ b') {-# INLINE scanning #-}++-- | Create a request-preserving distiller from a drinker action.+repeating :: (MonadDrunk (Tap r a) m, Semigroup r) => m b -> Tap r b m+repeating m = go where+  go = Tap $ \r -> do+    request r+    a <- m+    return (a, go)

@@ -0,0 +1,20 @@+module Data.Drinkery.IO where++import Control.Exception+import Data.Drinkery.Class+import Data.Drinkery.Tap+import Data.IORef++-- | Create a popper from a 'Tap'.+--+-- @tapPopper :: CloseRequest r => Tap r s IO -> GivesPopper@+--+tapPopper :: (Monoid r, CloseRequest r) => Tap r s IO -> (IO s -> IO ()) -> IO ()+tapPopper tap0 needsPopper = do+  vTap <- newIORef tap0+  let popper = do+        t <- readIORef vTap+        (s, t') <- unTap t mempty+        writeIORef vTap t'+        return s+  needsPopper popper `finally` do readIORef vTap >>= close

@@ -1,9 +1,12 @@-{-# LANGUAGE LambdaCase, DeriveFunctor #-}+{-# LANGUAGE LambdaCase, DeriveFunctor, FlexibleContexts #-} module Data.Drinkery.Patron where  import Control.Applicative import Control.Monad import Control.Monad.Trans+import Data.Drinkery.Class+import Data.Drinkery.Tap+import Data.Semigroup  -- | @Patron s@ is a simple consumer of @s@. Unlike 'Drinker', it can be -- partially run.@@ -45,6 +48,9 @@   mzero = empty   mplus = (<|>) +instance MonadIO m => MonadIO (Patron s m) where+  liftIO = Patron . fmap Right . liftIO+ await :: Monad m => Patron s m s await = Patron $ pure $ Left pure {-# INLINE await #-}@@ -76,3 +82,9 @@     Left f -> k >>= go . f     Right a -> return a {-# INLINE iterPatronT #-}++lookAheadT :: (Monad m, MonadTrans t, Monoid r, Semigroup r, MonadDrunk (Tap r s) (t m)) => Patron s m a -> t m a+lookAheadT = go [] where+  go xs m = lift (runPatron m) >>= \case+    Right a -> a <$ mapM_ leftover (reverse xs)+    Left f -> drink >>= \s -> go (s : xs) (f s)

@@ -0,0 +1,59 @@+{-# LANGUAGE BangPatterns, Rank2Types, FlexibleContexts, LambdaCase #-}+module Data.Drinkery.Still where++import Control.Applicative+import Data.Drinkery.Class+import Data.Drinkery.Distiller+import Data.Drinkery.Tap+import Data.Semigroup++type Cask r s = Tap r (Maybe s)++-- | Mono in/out+type Still p q r s m = Cask r s (Drinker (Cask p q) m)++type Pipe a b m = forall r. (Monoid r, Semigroup r) => Still r a r b m++scan :: Monad m => (b -> a -> b) -> b -> Pipe a b m+scan 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 scan #-}++reserve :: (Monoid r, MonadDrunk (Cask r s) m)+    => (s -> Barman r (Maybe t) m ()) -> Barman r (Maybe t) m ()+reserve k = Barman $ \cont -> Tap $ \r -> drinking (\t -> unTap t r) >>= \case+  Nothing -> return (Nothing, cont ())+  Just s -> unTap (unBarman (k s) cont) mempty++map :: (Functor t, Monad m) => (a -> b) -> Distiller (Tap r (t a)) r (t b) m+map = mapping . fmap+{-# INLINE map #-}++mapMaybe :: (Monad m) => (a -> Maybe b) -> Pipe a b m+mapMaybe f = inexhaustible $ reserve $ mapM_ yield . f+{-# INLINE mapMaybe #-}++filter :: Monad m => (a -> Bool) -> Pipe a a m+filter = filtering . maybe True+{-# INLINE filter #-}++mapAccum :: Monad m => (s -> a -> (s, b)) -> s -> Pipe a b m+mapAccum f = go where+  go s = Tap $ \r -> Drinker $ \tap -> do+    (m, t') <- unTap tap r+    case m of+      Just a -> let (s', b) = f s a in return ((Just b, go s'), t')+      Nothing -> return ((Nothing, go s), t')+{-# INLINE mapAccum #-}++-- | Consume all the content of a 'Tap' and return the elements as a list.+drinkUp :: (Monoid r, Semigroup r, MonadDrunk (Tap r (Maybe s)) m) => m [s]+drinkUp = drink >>= maybe (pure []) (\x -> (x:) <$> drinkUp)++sip :: (Monoid r, Alternative m, MonadDrunk (Tap r (Maybe s)) m) => m s+sip = drink >>= maybe empty pure+{-# INLINE sip #-}

@@ -15,6 +15,9 @@   , consTap   , orderTap   , makeTap+  , repeatTap+  , repeatTapM+  , repeatTapM'   -- * Barman   , Barman(..)   , yield@@ -29,6 +32,7 @@   , inquire   , runSommelier   , runSommelier'+  , retractSommelier   -- * Drinker   , drink   , leftover@@ -42,6 +46,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class+import Data.Semigroup import Data.Drinkery.Class  -- | @'Tap' m r s@ is a non-monadic, endless producer of @s@. It takes a request@@ -49,20 +54,34 @@ 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 r s m -> Tap r s m-consTap s t = Tap $ \r -> pure (s, Tap $ unTap t . mappend r)+consTap :: (Semigroup r, Applicative m) => s -> Tap r s m -> Tap r s m+consTap s t = Tap $ \r -> pure (s, Tap $ unTap t . (<>) r) {-# INLINE consTap #-}  -- | Send a request to a 'Tap'.-orderTap :: (Monoid r) => r -> Tap r s m -> Tap r s m-orderTap r t = Tap $ \r' -> unTap t $! mappend r r'+orderTap :: (Semigroup r) => r -> Tap r s m -> Tap r s m+orderTap r t = Tap $ \r' -> unTap t $! r <> r' {-# INLINE orderTap #-}  -- | Involve an action.-makeTap :: (Monoid r, Monad m) => m (Tap r s m) -> Tap r s m+makeTap :: (Monad m) => m (Tap r s m) -> Tap r s m makeTap m = Tap $ \r -> m >>= \t -> unTap t r {-# INLINE makeTap #-} +repeatTap :: Applicative m => s -> Tap r s m+repeatTap s = go where+  go = Tap $ const $ pure (s, go)+{-# INLINE repeatTap #-}++repeatTapM :: Applicative m => m s -> Tap r s m+repeatTapM m = go where+  go = Tap $ const $ flip (,) go <$> m+{-# INLINE repeatTapM #-}++repeatTapM' :: Applicative m => m s -> Tap () s m+repeatTapM' = repeatTapM+{-# INLINE repeatTapM' #-}+ instance CloseRequest r => Closable (Tap r s) where   close t = void $ unTap t closeRequest @@ -70,16 +89,16 @@ drink = drinking $ \t -> unTap t mempty {-# INLINE drink #-} -leftover :: (Monoid r, MonadDrunk (Tap r s) m) => s -> m ()+leftover :: (Semigroup 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 :: (Semigroup 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 :: (Monoid r, Semigroup r, MonadDrunk (Tap r s) m) => m s smell = do   s <- drink   leftover s@@ -103,12 +122,15 @@ instance MonadTrans (Barman r s) where   lift m = Barman $ \k -> Tap $ \rs -> m >>= \a -> unTap (k a) rs +instance MonadIO m => MonadIO (Barman r s m) where+  liftIO m = Barman $ \k -> Tap $ \rs -> liftIO m >>= \a -> unTap (k a) rs+ instance MonadDrunk t m => MonadDrunk t (Barman p q m) where   drinking f = lift (drinking f)  -- | Produce one element. Orders are put off.-yield :: (Monoid r, Applicative m) => s -> Barman r s m ()-yield s = Barman $ \cont -> consTap s (cont ())+pour :: (Semigroup r, Applicative m) => s -> Barman r s m ()+pour s = Barman $ \cont -> consTap s (cont ())  -- | Accept orders and clear the queue. accept :: Monoid r => Barman r s m r@@ -163,7 +185,7 @@  -- | End of stream eof :: (Applicative m, Alternative f) => Tap r (f a) m-eof = Tap $ const $ pure (empty, eof)+eof = repeatTap empty  -- | 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@@ -176,7 +198,7 @@ {-# 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 :: (Semigroup r, Applicative m, Alternative f) => Sommelier r m s -> Tap r (f s) m runSommelier m = unSommelier m (consTap . pure) eof {-# INLINE runSommelier #-} @@ -185,6 +207,11 @@ runSommelier' = runSommelier {-# INLINE runSommelier' #-} -pour :: (Monoid r, Applicative f, Applicative m) => s -> Barman r (f s) m ()-pour = yield . pure+retractSommelier :: Monad m => Sommelier () m s -> m ()+retractSommelier (Sommelier f) = go $ f (const $ consTap True) (repeatTap False) where+  go m = unTap m () >>= \(a, k) -> when a (go k)+{-# INLINE retractSommelier #-}++yield :: (Semigroup r, Applicative f, Applicative m) => s -> Barman r (f s) m ()+yield = pour . pure {-# INLINE pour #-}