pipes-extras (empty) → 1.0.0
raw patch · 5 files changed
+336/−0 lines, 5 filesdep +HUnitdep +basedep +foldlsetup-changed
Dependencies added: HUnit, base, foldl, pipes, pipes-extras, test-framework, test-framework-hunit, transformers
Files
- LICENSE +24/−0
- Setup.hs +2/−0
- pipes-extras.cabal +44/−0
- src/Pipes/Extras.hs +240/−0
- tests/Main.hs +26/−0
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2014 Gabriel Gonzalez +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 Gabriel Gonzalez 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ pipes-extras.cabal view
@@ -0,0 +1,44 @@+Name: pipes-extras +Version: 1.0.0 +Cabal-Version: >=1.10 +Build-Type: Simple +License: BSD3 +License-File: LICENSE +Copyright: 2014 Gabriel Gonzalez +Author: Gabriel Gonzalez +Maintainer: Gabriel439@gmail.com +Bug-Reports: https://github.com/Gabriel439/Haskell-Pipes-Extras-Library/issues +Synopsis: Extra utilities for pipes +Description: This package holds miscellaneous utilities related to the @pipes@ + library. +Category: Control, Pipes +Source-Repository head + Type: git + Location: https://github.com/Gabriel439/Haskell-Pipes-Extras-Library + +Library + HS-Source-Dirs: src + Build-Depends: + base >= 4 && < 5 , + pipes >= 4.0 && < 4.2, + foldl >= 1.0.1 && < 1.1, + transformers >= 0.2.0.0 && < 0.4 + Exposed-Modules: Pipes.Extras + GHC-Options: -O2 -Wall + Default-Language: Haskell2010 + +test-suite tests + Type: exitcode-stdio-1.0 + HS-Source-Dirs: tests + Main-Is: Main.hs + GHC-Options: -Wall -rtsopts -fno-warn-missing-signatures -fno-enable-rewrite-rules + Default-Language: Haskell2010 + + Build-Depends: + base >= 4 && < 5 , + pipes-extras , + pipes >= 4.0 && < 4.2 , + test-framework >= 0.4 && < 1 , + test-framework-hunit >= 0.3 && < 1 , + HUnit >= 1.2 && < 1.3 , + transformers >= 0.2.0.0 && < 0.4
+ src/Pipes/Extras.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE RankNTypes, Trustworthy #-} + +-- | Unassorted utilities for @pipes@ + +module Pipes.Extras ( + -- * ArrowChoice + arr + , left + , right + , (+++) + + -- * Lenses + , input + , output + + -- * Fun + , check + , delay + , progress + + -- * Foldl Compatibility + -- $foldl + , fold + , foldM + , scan + , scanM + + -- * Fold Variations + -- $variations + , scan1 + , scan1M + , scan1i + , scan1iM + ) where + +import Control.Concurrent (threadDelay) +import Data.Char (toLower) +import Data.Functor.Identity (Identity(Identity, runIdentity)) +import Control.Foldl (purely, impurely, Fold, FoldM) +import Pipes +import Pipes.Core (request, respond, (>\\), (//>)) +import qualified Pipes.Prelude as Pipes + +-- | Like 'Control.Arrow.arr' from 'Control.Arrow.Arrow' +arr :: Monad m => (a -> b) -> Pipe a b m r +arr = Pipes.map +{-# INLINABLE arr #-} + +-- | Like 'Control.Arrow.left' from 'Control.Arrow.ArrowChoice' +left :: Monad m => Pipe a b m r -> Pipe (Either a x) (Either b x) m r +left p = await' >~ for p yield' + where + yield' b = yield (Left b) + await' = do + e <- await + case e of + Left a -> return a + Right x -> do + yield (Right x) + await' +{-# INLINABLE left #-} + +-- | Like 'Control.Arrow.right' from 'Control.Arrow.ArrowChoice' +right :: Monad m => Pipe a b m r -> Pipe (Either x a) (Either x b) m r +right p = await' >~ for p yield' + where + yield' b = yield (Right b) + await' = do + e <- await + case e of + Left x -> do + yield (Left x) + await' + Right a -> return a +{-# INLINABLE right #-} + +{-| Like ('Control.Arrow.+++') from 'Control.Arrow.ArrowChoice' + +> pL +++ pR = left pL >-> right pR +-} +(+++) + :: Monad m + => Pipe a b m r -> Pipe c d m r -> Pipe (Either a c) (Either b d) m r +pL +++ pR = left pL >-> right pR +{-# INLINABLE (+++) #-} + +type Setter s t a b = (a -> Identity b) -> (s -> Identity t) + +{-| It helps to think in terms of the following simpler types: + +> input :: Monad m => Setter' (Consumer a m r) a +> input :: Monad m => Setter' (Pipe a b m r) a + + Note: This only works with @lens@ and not @lens-family-core@ +-} +input :: Monad m => Setter (Proxy x' b y' y m r) (Proxy x' a y' y m r) a b +input k p = Identity (request' >\\ p) + where + request' a' = fmap (\a -> runIdentity (k a)) (request a') +{-# INLINABLE input #-} + +{-| It helps to think in terms of the following simpler types: + +> output :: Monad m => Setter' (Producer b m r) b +> output :: Monad m => Setter' (Pipe a b m r) b + + Note: This only works with @lens@ and not @lens-family-core@ +-} +output :: Monad m => Setter (Proxy x' x y' a m r) (Proxy x' x y' b m r) a b +output k p = Identity (p //> respond') + where + respond' a = respond (runIdentity (k a)) +{-# INLINABLE output #-} + +{-| Ask whether or not to let values pass through + +>>> runEffect $ each [1..3] >-> check >-> Pipes.print +Allow <1> [Y/n]? +y<Enter> +1 +Allow <2> [Y/n]? +no<Enter> +Allow <3> [Y/n]? +YES<Enter> +3 + +-} +check :: Show a => Pipe a a IO r +check = Pipes.filterM $ \a -> do + let prompt = do + putStrLn ("Allow <" ++ show a ++ "> [Y/n]?") + str <- getLine + case map toLower str of + "" -> return True + "y" -> return True + "yes" -> return True + "n" -> return False + "no" -> return False + _ -> do + putStrLn "Please enter (y)es or (n)o." + prompt + prompt +{-# INLINABLE check #-} + +{-| Display a progress bar + + This is very simple and only works if nothing else writes to the terminal + + Try this: + +>>> runEffect $ each [1..] >-> progress >-> delay 0.1 >-> Pipes.Prelude.drain +-} +progress :: Pipe a a IO r +progress = go (0 :: Integer) + where + go n = do + let str = bar n ++ " " ++ show n + lift $ putStr str + a <- await + yield a + lift $ putStr (replicate (length str) '\b') + go (n + 1) + bar n = case n `mod` 4 of + 0 -> "|" + 1 -> "/" + 2 -> "-" + _ -> "\\" +{-# INLINABLE progress #-} + +-- | Add a delay (in seconds) between each element +delay :: Double -> Pipe a a IO r +delay seconds = for cat $ \a -> do + yield a + lift $ threadDelay (truncate (seconds * 1000000)) +{-# INLINABLE delay #-} + +{- $foldl + Note that you can already mix the @pipes@ and @foldl@ libraries without + using @pipes-extras@ just by using: + +> import Control.Foldl (purely) +> import Pipes.Prelude (fold) +> +> purely fold :: Monad m => Fold a b -> Producer a m () -> m b + + The following functions are for people who are too lazy to do even that. +-} + +-- | Strict fold of the elements of a 'Producer' +fold :: Monad m => Fold a b -> Producer a m () -> m b +fold = purely Pipes.fold +{-# INLINABLE fold #-} + +-- | Strict, monadic fold of the elements of a 'Producer' +foldM :: Monad m => FoldM m a b -> Producer a m () -> m b +foldM = impurely Pipes.foldM +{-# INLINABLE foldM #-} + +-- | Strict left scan +scan :: Monad m => Fold a b -> Pipe a b m r +scan = purely Pipes.scan +{-# INLINABLE scan #-} + +-- | Strict, monadic left scan +scanM :: Monad m => FoldM m a b -> Pipe a b m r +scanM = impurely Pipes.scanM +{-# INLINABLE scanM #-} + +{- $variations + These are minor variations on left folds / scans +-} + +{-| Strict, endomorphic left scan without explicit initial state. + +> -- Compute exponential moving average +> ema :: (Monad m, Fractional a) => a -> Pipe a a m r +> ema α = scan1i (\last input -> last * α + input * (1 - α)) +-} +scan1i :: Monad m => (a -> a -> a) -> Pipe a a m r +scan1i step = scan1 step id id +{-# INLINABLE scan1i #-} + +-- | Strict, monadic and endomorphic left scan without explicit initial state +scan1iM :: Monad m => (a -> a -> m a) -> Pipe a a m r +scan1iM step = scan1M step return return +{-# INLINABLE scan1iM #-} + +-- | Strict left scan without explicit initial state +scan1 :: Monad m => (x -> a -> x) -> (a -> x) -> (x -> b) -> Pipe a b m r +scan1 step begin done = do + initial <- await + Pipes.scan step (begin initial) done +{-# INLINABLE scan1 #-} + +-- | Strict, monadic left scan without explicit initial state +scan1M :: Monad m => (x -> a -> m x) -> (a -> m x) -> (x -> m b) -> Pipe a b m r +scan1M step begin done = do + initial <- await + Pipes.scanM step (begin initial) done +{-# INLINABLE scan1M #-}
+ tests/Main.hs view
@@ -0,0 +1,26 @@+module Main (main) where + +import Data.Functor.Identity (Identity) +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +import Pipes (Pipe, (>->), each) +import Pipes.Prelude (toList) +import Pipes.Extras (scan1i) + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = + [ testGroup "Scans" [ + testCase "Scan1i works for EMA calculation" testScan1i + ] + ] + +testScan1i :: Assertion +testScan1i = transduce (scan1i (\l i -> l * α + i * (1 - α))) [2, 0, 0, 1.5] @?= ([2, 1, 0.5, 1] :: [Double]) + where α = 0.5 + +transduce :: Pipe a b Identity () -> [a] -> [b] +transduce pipe xs = toList (each xs >-> pipe)