packages feed

producer (empty) → 0.1.0.0

raw patch · 8 files changed

+475/−0 lines, 8 filesdep +QuickCheckdep +basedep +checkerssetup-changed

Dependencies added: QuickCheck, base, checkers, producer, tasty, tasty-auto, tasty-hunit, tasty-quickcheck

Files

+ LICENSE.txt view
@@ -0,0 +1,17 @@+Copyright (c) 2017 Eric Torreborre <etorreborre@yahoo.com>++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated +documentation files (the "Software"), to deal in the Software without restriction, including without limitation+the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, +and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of +the Software. Neither the name of specs nor the names of its contributors may be used to endorse or promote +products derived from this software without specific prior written permission.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED+TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF+CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE.+
+ README.md view
@@ -0,0 +1,5 @@+![Build status](https://travis-ci.org/etorreborre/producer-hs.svg?branch=master)++# Producer++Simple streaming library for Haskell
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ producer.cabal view
@@ -0,0 +1,51 @@+name: producer+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: MIT+license-file: LICENSE.txt+copyright: Eric Torreborre+maintainer: etorreborre@yahoo.com+homepage: https://github.com/etorreborre/producer-hs#readme+bug-reports: https://github.com/etorreborre/producer-hs/issues+synopsis: Simple streaming datatype+description:+    Producer is a simple streaming datatype, making that only a limited number+    of elements are ever kept in memory. As such it is more a library showing the use of+    simple functional programming to do streaming rather than a production library.+category: Education+author: Eric Torreborre+extra-source-files:+    README.md++source-repository head+    type: git+    location: https://github.com/etorreborre/producer-hs++library+    exposed-modules:+        Streaming.Producer+    build-depends:+        base >=4.7 && <5+    default-language: Haskell2010+    hs-source-dirs: src+    ghc-options: -Wall++test-suite producer-test+    type: exitcode-stdio-1.0+    main-is: test.hs+    build-depends:+        base -any,+        producer -any,+        QuickCheck -any,+        tasty -any,+        tasty-quickcheck -any,+        tasty-hunit -any,+        tasty-auto -any,+        checkers -any+    default-language: Haskell2010+    hs-source-dirs: test+    other-modules:+        Test.Streaming.ProducerSpec+        Test.Tasty.Extensions+    ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans -fno-warn-missing-signatures
+ src/Streaming/Producer.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-|++Module      : Streaming.Producer+Description : Simple data type for streaming and associated combinators+Copyright   : (c) Eric Torreborre, 2017+                  Someone Else, 2014+License     : MIT+Maintainer  : etorreborre@yahoo.com+Stability   : experimental++-}+module Streaming.Producer (+    Producer(..)+  , Stream(..)+  , done+  , one+  , more+  , emit+  , append+  , filter+  , take+  , drop+  , chunk+  , runList+  , runChunks+) where++import           Control.Applicative   (liftA2)+import           Data.Functor.Identity+import qualified Data.List             as DL (drop, filter, take)+import           Prelude               hiding (drop, filter, take)++-- data types++-- | A Producer generates values of type a with effects of type m+newtype Producer m a =+  Producer { runStream :: m (Stream m a) }+++-- | ADT for the produced elements. There are either:+--+--      * no element+--+--      * one element+--+--      * several elements (a "chunk") followed by the next producer+--+data Stream m a =+    Done+  | One a+  | More [a] (Producer m a)++-- |+-- == Constructors++-- | A Producer with no elements+done :: Applicative m => Producer m a+done = Producer (pure Done)++-- | A Producer with one element+one :: Applicative m => a -> Producer m a+one a = Producer (pure (One a))++-- | A Producer with n elements+emit :: Applicative m => [a] -> Producer m a+emit as = more as done++-- | A Producer with n elements and another Producer+more :: Applicative m => [a] -> Producer m a -> Producer m a+more as next = Producer (pure (More as next))++-- |+-- == Combinators++-- | Append 2 Producers together+append :: Applicative m => Producer m a -> Producer m a -> Producer m a+append (Producer s1) (Producer s2) =  Producer (liftA2 appendStream s1 s2)++appendStream :: Applicative m => Stream m a -> Stream m a -> Stream m a+appendStream s Done = s+appendStream Done s = s+appendStream (One a) (More as next) = More (a:as) next+appendStream (One a1) (One a2) = More [a1, a2] done+appendStream (More as1 (Producer next)) s2 = More as1 (Producer (fmap (`appendStream` s2) next))++mapStream :: Monad m => (Stream m a -> Producer m a) -> Producer m a -> Producer m a+mapStream f p = Producer $ runStream p >>= \s -> runStream (f s)++-- | Filter the values of a Producer+filter :: Monad m => (a -> Bool) -> Producer m a -> Producer m a+filter = mapStream . filterStream++filterStream :: Monad m => (a -> Bool) -> Stream m a -> Producer m a+filterStream _ Done = done+filterStream f (One a) = if f a then one a else done+filterStream f (More as next) =+  more (DL.filter f as) (filter f next)++-- | Take the first n elements+-- If n <= 0 an empty Producer is returned+take :: Monad m => Int -> Producer m a -> Producer m a+take = mapStream . takeStream++takeStream :: Monad m => Int -> Stream m a -> Producer m a+takeStream _ Done = done+takeStream n (One a) = if n <= 0 then done else one a+takeStream n (More as next) =+  let diff = n - length as in+    if diff > 0 then+      more as (take diff next)+    else+      more (DL.take n as) done++-- | Drop the first n elements+-- If n <= 0 nothing is dropped+drop :: Monad m => Int -> Producer m a -> Producer m a+drop = mapStream . dropStream++dropStream :: Monad m => Int -> Stream m a -> Producer m a+dropStream _ Done = done+dropStream n (One a) = if n > 0 then done else one a+dropStream n (More as next) =+  let diff = n - length as in+    if diff >= 0 then+      drop diff next+    else+      more (DL.drop n as) next++-- | Make sure that the underlying chunks have a size n+-- as much as possible+chunk :: Monad m => Int -> Producer m a -> Producer m a+chunk = mapStream . chunkStream++chunkStream :: Monad m => Int -> Stream m a -> Producer m a+chunkStream _ Done    = done+chunkStream _ (One a) = one a+chunkStream n (More as next) =+  if n <= 0 then more as next+  else+    go [] (More as next)+    where+      --go :: [a] -> Stream m a -> Producer m a+      go acc Done = emit acc++      go acc (One a) =+        emit (acc ++ [a])++      go acc (More as1 next1) =+        let needed = n - length acc in+          if length as1 >= needed then+            emit (acc ++ DL.take needed as1) `append`+            chunk n (more (DL.drop needed as1) next1)+          else+            mapStream (go (acc ++ as1)) next1++-- |+-- == Observations+-- The following functions can "run" a Producer to get values back++-- | return a list of values+runList :: Monad m => Producer m a -> m [a]+runList (Producer ma) = ma >>= runListStream++runListStream :: Monad m => Stream m a -> m [a]+runListStream Done           = pure []+runListStream (One a)        = pure [a]+runListStream (More as next) =  (\x -> as ++ x) <$> runList next++-- | return a list of chunks+runChunks :: Monad m => Producer m a -> m [[a]]+runChunks (Producer ma) = ma >>= runChunksStream++runChunksStream :: Monad m => Stream m a -> m [[a]]+runChunksStream Done           = pure []+runChunksStream (One a)        = pure [[a]]+runChunksStream (More as next) =+  appendChunk <$> runChunks next+  where+    -- appendChunk :: [[a]] -> [[a]]+    appendChunk []     = [as]+    appendChunk [[]]   = [as]+    appendChunk (c:cs) = as:c:cs++-- Instances+instance (Show a) => Show (Producer Identity a) where+  show p = show (runList p)++instance (Functor m) => Functor (Producer m) where+  fmap f (Producer s) = Producer (fmap (fmap f) s)++instance (Monad m) => Applicative (Producer m) where+    pure a = Producer (return (One a))++    (<*>) p1 p2 = p1 >>= (`fmap` p2)++instance (Monad m) => Monad (Producer m) where+  return a = Producer (return (One a))++  Producer s >>= f = Producer (s >>= f') where+    f' Done               = pure Done+    f' (One a)            = runStream (f a)+    f' (More [] next)     = runStream (next >>= f)+    f' (More (a:as) next) = runStream (f a `append` (more as next >>= f))++instance (Functor m) => Functor (Stream m) where+  fmap _ Done           = Done+  fmap f (One a)        = One (f a)+  fmap f (More as next) = More (fmap f as) (fmap f next)
+ test/Test/Streaming/ProducerSpec.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Streaming.ProducerSpec where++import           Data.Foldable+import           Data.Functor.Identity+import qualified Data.List                 as DL+import           Data.Proxy+import           Prelude                   hiding (drop, filter, take)+import           Streaming.Producer+import           Test.QuickCheck.Arbitrary+import           Test.QuickCheck.Checkers+import           Test.QuickCheck.Classes+import           Test.QuickCheck.Gen+import           Test.QuickCheck.Property+import           Test.Tasty+import           Test.Tasty.Extensions+import           Test.Tasty.HUnit          as H+import           Test.Tasty.QuickCheck     as QC++test_show = prop "show" $ \(p :: ProducerInt) ->+  show p == show (runList p)++test_append = testGroup "append" [+    eg "sanity check - runList done" $+      null $ run done++  , eg "append done - done" $+      null $ run $ append done done++  , prop "append 2 producers" $ \(p1, p2) ->+      run (append p1 p2)  == (run p1 ++ run p2)+  ]++test_filter = testGroup "filter" [+  prop "filter ints with tight predicate" $ \p ->+    let f = (== 0) in+      run (filter f p) == DL.filter f (run p)++  , prop "filter ints with more accepting predicate" $ \p ->+    let f = (> 0) in+      run (filter f p) == DL.filter f (run p)+  ]++test_take = testGroup "take, drop, chunk" [+    prop "take values" $ \(p, n) ->+      run (take n p) == DL.take n (run p)++  , prop "drop values" $ \(p, n) ->+      run (drop n p) == DL.drop n (run p)++  , prop "chunk values returns all values" $ \(p, n) ->+      run (chunk n p) == run p++  , minTestsOk 1000 $ prop "chunk values returns chunks of size == n, excepted possibly for the last one" $ \(p, n) ->+     n <= 1     ||+     size p < n ||+     if n `rem` size p == 0 then+       all (\c -> n == length c) (runC (chunk n p))+     else+       all (\c -> n == length c) (dropLast (runC (chunk n p)))++  , prop "chunk values for a producer with no elements" $ \n ->+     null $ runC (chunk n done)++  , prop "chunk values for a producer with one element" $ \(n, a) ->+     runC (chunk n (one a)) == [[a]]+  ]++test_monad = testGroup "laws" [+    functorLaws     (Proxy :: Proxy ProducerIntIntInt)+  , applicativeLaws (Proxy :: Proxy ProducerIntIntInt)+  , monadLaws       (Proxy :: Proxy ProducerIntIntInt)+  ]++-- HELPERS++instance Arbitrary ProducerInt where+  arbitrary = oneof [+      elements [done, one 1],+      more <$> arbitrary <*> arbitrary+    ]++instance Arbitrary (Producer Identity (Int -> Int)) where+  arbitrary = oneof [+      elements [done, one (+1), one (* 2)],+      more <$> arbitrary <*> arbitrary+    ]++instance Arbitrary ProducerIntIntInt where+  arbitrary =+    do a <- arbitrary+       b <- arbitrary+       c <- arbitrary+       oneof [+           elements [done, one (a :: Int, b :: Int, c :: Int)],+           more <$> arbitrary <*> arbitrary+         ]++run :: ProducerInt -> [Int]+run = runIdentity . runList++size :: ProducerInt -> Int+size = length . run++empty :: ProducerInt -> Bool+empty p = size p == 0++dropLast :: [a] -> [a]+dropLast []     = []+dropLast [_]    = []+dropLast (a:as) = a : dropLast as++runC :: ProducerInt -> [[Int]]+runC = runIdentity . runChunks++type ProducerInt = Producer Identity Int+type ProducerIntIntInt = Producer Identity (Int, Int, Int)++instance Eq ProducerInt where+  (==) p1 p2 = runList p1 == runList p2++instance EqProp ProducerInt where+  (=-=) = eq
+ test/Test/Tasty/Extensions.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Tasty.Extensions where++import           Data.Foldable+import           Data.Proxy+import           Test.QuickCheck.Arbitrary+import           Test.QuickCheck.Checkers+import           Test.QuickCheck.Classes+import           Test.QuickCheck.Gen+import           Test.QuickCheck.Property+import           Test.Tasty+import           Test.Tasty.HUnit          as H+import           Test.Tasty.QuickCheck     as QC++functorLaws :: forall m a b c. (+  Arbitrary (m (a, b, c)), Show (m (a, b, c)),+  Functor m, Arbitrary a, Arbitrary b, Arbitrary c,+  CoArbitrary a, CoArbitrary b,+  Show (m a), Arbitrary (m a),+  EqProp (m a), EqProp (m c)) => Proxy (m (a, b, c)) -> TestTree++functorLaws _ = prop "check functor laws" $ \(p :: m (a, b, c)) ->+  snd $ fold $ unbatch $ functor p :: Property++applicativeLaws :: forall m a b c. (+  Arbitrary (m (a, b, c)), Show (m (a, b, c)),+  Applicative m, Arbitrary a, CoArbitrary a, Arbitrary b, Arbitrary (m a),+  Arbitrary (m (b -> c)), Show (m (b -> c)),+  Arbitrary (m (a -> b)), Show (m (a -> b)),+  Show a, Show (m a),+  EqProp (m a), EqProp (m b), EqProp (m c)) => Proxy (m (a, b, c)) -> TestTree++applicativeLaws _ = prop "check applicative laws" $ \(p :: m (a, b, c)) ->+  snd $ fold $ unbatch $ applicative p :: Property++monadLaws :: forall m a b c. (+   Arbitrary (m (a, b, c)), Show (m (a, b, c)),+   Monad m, Show a,+   Arbitrary a, CoArbitrary a,+   Arbitrary b, CoArbitrary b,+   Arbitrary (m a), EqProp (m a), Show (m a),+   Arbitrary (m b), EqProp (m b),+   Arbitrary (m c), EqProp (m c)) => Proxy (m (a, b, c)) -> TestTree++monadLaws _ = prop "check monad laws" $ \(p :: m (a, b, c)) ->+  snd $ fold $ unbatch $ monad p :: Property++minTestsOk :: Int -> (TestTree -> TestTree)+minTestsOk n = localOption (QuickCheckTests n)++instance Monoid Property where+  mempty = label "ok" True+  mappend = (.&.)++prop :: Testable a => String -> a -> TestTree+prop = QC.testProperty++eg :: String -> Bool -> TestTree+eg name b = H.testCase name (assertBool name b)
+ test/test.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-auto #-}