diff --git a/library/Potoki/Core/Consume.hs b/library/Potoki/Core/Consume.hs --- a/library/Potoki/Core/Consume.hs +++ b/library/Potoki/Core/Consume.hs @@ -209,7 +209,6 @@ Consume $ \ fetch -> try $ withFile path WriteMode $ \ handleVal -> do - hSetBuffering handleVal NoBuffering L.fetchAndHandleAll fetch (return ()) (C.hPut handleVal) {-| @@ -224,7 +223,6 @@ Consume $ \ fetch -> try $ withFile path AppendMode $ \ handleVal -> do - hSetBuffering handleVal NoBuffering L.fetchAndHandleAll fetch (return ()) (C.hPut handleVal) {-# INLINABLE deleteFiles #-} diff --git a/library/Potoki/Core/Fetch.hs b/library/Potoki/Core/Fetch.hs --- a/library/Potoki/Core/Fetch.hs +++ b/library/Potoki/Core/Fetch.hs @@ -40,32 +40,11 @@ (<*>) (Fetch leftIO) (Fetch rightIO) = Fetch ((<*>) <$> leftIO <*> rightIO) -instance Monad Fetch where - return = - pure - (>>=) (Fetch leftIO) rightFetch = - Fetch $ do - leftFetching <- leftIO - case leftFetching of - Nothing -> return Nothing - Just leftElement -> case rightFetch leftElement of - Fetch rightIO -> rightIO - instance Alternative Fetch where empty = Fetch (pure Nothing) (<|>) (Fetch leftIO) (Fetch rightIO) = Fetch ((<|>) <$> leftIO <*> rightIO) - -instance MonadPlus Fetch where - mzero = - empty - mplus = - (<|>) - -instance MonadIO Fetch where - liftIO io = - Fetch (fmap Just io) {-# INLINABLE duplicate #-} duplicate :: Fetch element -> IO (Fetch element, Fetch element) diff --git a/library/Potoki/Core/Produce.hs b/library/Potoki/Core/Produce.hs --- a/library/Potoki/Core/Produce.hs +++ b/library/Potoki/Core/Produce.hs @@ -43,24 +43,44 @@ return = pure (>>=) (Produce (Acquire io1)) k2 = Produce $ Acquire $ do - (fetch1, release1) <- io1 + (A.Fetch fetch1, release1) <- io1 release2Ref <- newIORef (return ()) + fetch3Var <- newIORef (return Nothing) let fetch2 input1 = case k2 input1 of - Produce (Acquire io2) -> - A.ioFetch $ do - join (readIORef release2Ref) - (fetch2', release2') <- io2 - writeIORef release2Ref release2' - return fetch2' + Produce (Acquire io2) -> do + join (readIORef release2Ref) + (A.Fetch fetch2', release2') <- io2 + writeIORef release2Ref release2' + return fetch2' release3 = join (readIORef release2Ref) >> release1 - in return (fetch1 >>= fetch2, release3) + fetch3 = do + res <- readIORef fetch3Var + mayY <- res + case mayY of + Nothing -> do + mayX <- fetch1 + case mayX of + Nothing -> return Nothing + Just x -> do + fetch2 x >>= writeIORef fetch3Var + fetch3 + Just y -> return $ Just y + return (A.Fetch fetch3, release3) instance MonadIO Produce where - liftIO io = - Produce (return (liftIO io)) + liftIO io = Produce . liftIO $ do + refX <- newIORef $ Just io + let fetch = A.Fetch $ fetchIO refX + where + fetchIO ref = do + elemVal <- readIORef ref + for elemVal $ \getElement -> do + writeIORef ref Nothing + getElement + return fetch {-# INLINABLE list #-} list :: [input] -> Produce input @@ -188,4 +208,3 @@ infiniteMVar :: MVar element -> Produce element infiniteMVar var = Produce $ M.Acquire (return (A.infiniteMVar var, return ())) - diff --git a/library/Potoki/Core/Transform/Concurrency.hs b/library/Potoki/Core/Transform/Concurrency.hs --- a/library/Potoki/Core/Transform/Concurrency.hs +++ b/library/Potoki/Core/Transform/Concurrency.hs @@ -11,12 +11,11 @@ import Potoki.Core.Types import qualified Potoki.Core.Fetch as A import qualified Acquire.Acquire as M +import qualified Control.Concurrent.Chan.Unagi.Bounded as B {-# INLINE bufferize #-} bufferize :: Int -> Transform element element -bufferize = undefined -{- bufferize size = Transform $ \ (A.Fetch fetch) -> M.Acquire $ do (inChan, outChan) <- B.newChan size @@ -25,7 +24,6 @@ Nothing -> B.writeChan inChan Nothing Just !element -> B.writeChan inChan (Just element) >> doLoop return $ (A.Fetch $ B.readChan outChan, return ()) --} {-| Identity Transform, which ensures that the inputs are fetched synchronously. diff --git a/potoki-core.cabal b/potoki-core.cabal --- a/potoki-core.cabal +++ b/potoki-core.cabal @@ -1,7 +1,7 @@ name: potoki-core version: - 2 + 2.1 synopsis: Low-level components of "potoki" description: @@ -65,7 +65,6 @@ profunctors >=5.2 && <6, stm >=2.4 && <3, attoparsec >=0.13 && <0.15, - base-prelude <2, bytestring ==0.10.*, directory >=1.3 && <2, foldl >=1.3 && <2, @@ -84,20 +83,26 @@ tests main-is: Main.hs + other-modules: + Potoki + Transform default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 build-depends: - -- + -- potoki-core, -- testing: attoparsec, - tasty >=0.12 && <0.13, - tasty-quickcheck >=0.9 && <0.10, - tasty-hunit >=0.9 && <0.10, + acquire >=0.2 && <0.3, + tasty >=1.0.1 && <1.2, + tasty-quickcheck >=0.10 && <0.11, + tasty-hunit >=0.10 && <0.11, quickcheck-instances >=0.3.11 && <0.4, QuickCheck >=2.8.1 && <3, random >=1.1 && <2, + foldl >=1.3.7 && <1.4, + ilist >=0.3.1.0 && <0.4, -- rerebase >=1.1 && <2 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -3,6 +3,7 @@ import Prelude hiding (first, second) import Control.Arrow import Test.QuickCheck.Instances +import Test.QuickCheck.Monadic as M import Test.Tasty import Test.Tasty.Runners import Test.Tasty.HUnit @@ -11,10 +12,14 @@ import qualified Potoki.Core.Consume as D import qualified Potoki.Core.Transform as A import qualified Potoki.Core.Produce as E +import qualified Potoki.Core.Fetch as Fe import qualified Data.Attoparsec.ByteString.Char8 as B import qualified Data.ByteString as F import qualified Data.Vector as G import qualified System.Random as H +import qualified Acquire.Acquire as Ac +import Potoki +import Transform main = @@ -30,285 +35,151 @@ potoki , transform - ] - -transform = - testGroup "Transform" $ - [ - transformProduce , - transformChoice + resourceChecker , - transformArrowLaws - ] - -transformProduce = - testGroup "Produce" $ - [ - testCase "1" $ do - let - list = [1, 2, 3] :: [Int] - result <- C.produceAndTransformAndConsume - (E.list list) - (A.produce (E.list . \ n -> flip replicate n n)) - (D.list) - assertEqual "" [1, 2, 2, 3, 3, 3] result - , - testCase "2" $ do - let - list = [1, 2, 3] :: [Int] - result <- C.produceAndTransformAndConsume - (E.list list) - (A.produce (E.list . \ n -> [(n, n)])) - (D.list) - assertEqual "" [(1, 1), (2, 2), (3, 3)] result - , - testCase "3" $ do - let - list = [1, 2, 3] :: [Int] - result <- C.produceAndTransformAndConsume - (E.list list) - (A.produce (E.list . \ n -> [n, n])) - (D.list) - assertEqual "" [1, 1, 2, 2, 3, 3] result - ] - -transformChoice = - testGroup "Choice" $ - [ - testCase "1" $ do - let - list = [Left 1, Left 2, Right 'z', Left 2, Right 'a', Left 1, Right 'b', Left 0, Right 'x', Left 4, Left 3] - transform = left' id - result <- C.produceAndTransformAndConsume (E.list list) transform D.list - assertEqual "" [Left 1, Left 2, Right 'z', Left 2, Right 'a', Left 1, Right 'b', Left 0, Right 'x', Left 4, Left 3] result + testCase "sync resource checker" $ do + resourceVar <- newIORef Initial + let produce = syncCheckResource resourceVar + C.produceAndConsume produce D.sum + fin <- readIORef resourceVar + assertEqual "" Released fin , - testCase "2" $ do - let - list = [Left 1, Left 2, Right 'z', Right 'a', Right 'b', Left 0, Right 'x', Left 4, Left 3] - transform = right' (A.consume D.list) - result <- C.produceAndTransformAndConsume (E.list list) transform D.list - assertEqual "" [Left 1, Left 2, Right "zab", Left 0, Right "x", Left 4, Left 3] result + testCase "async resource checker" $ do + resourceVar <- newTVarIO Initial + let produce = asyncCheckResource resourceVar + potokiThreadId <- forkIO $ do + C.produceAndConsume produce D.sum + return () + atomically $ do + resource <- readTVar resourceVar + guard $ resource == Acquired + killThread potokiThreadId + atomically $ do + resource <- readTVar resourceVar + guard $ resource == Released , - testCase "3" $ do - let - list = [Left 4, Right 'z', Right 'a', Left 3, Right 'b', Left 0, Left 1, Right 'x', Left 4, Left 3] - transform = left' (A.consume D.list) - result <- C.produceAndTransformAndConsume (E.list list) transform D.list - assertEqual "" [Left [4], Right 'z', Right 'a', Left [3], Right 'b', Left [0, 1], Right 'x', Left [4, 3]] result + testProperty "Transform->Produce resource checker" $ \ (list :: [Int]) -> + let prod = E.list list + in monadicIO $ do + check <- run $ do + resourceVar1 <- newIORef Initial + res <- C.produceAndConsume (E.transform (checkTransform resourceVar1) prod) D.sum + readIORef resourceVar1 + M.assert $ check == Released ] -transformArrowLaws = - testGroup "Arrow laws" +resourceChecker :: TestTree +resourceChecker = + testGroup "produce1 >>= produce2" $ [ - testGroup "Strong" - [ - testCase "1" $ do - let - input = [(1,'a'),(2,'b'),(3,'c'),(4,'d')] - transform = first transform1 - result <- C.produceAndTransformAndConsume (E.list input) transform D.list - assertEqual "" [(6,'c'),(4,'d')] result - , - testCase "Lack of elements" $ do - let - input = [(1,'a'),(2,'b')] - transform = first transform1 - result <- C.produceAndTransformAndConsume (E.list input) transform D.list - assertEqual "" [(3,'b')] result - ] - , - transformProperty "arr id = id" - (arr id :: A.Transform Int Int) - id - , - transformProperty "arr (f >>> g) = arr f >>> arr g" - (arr (f >>> g)) - (arr f >>> arr g) - , - transformProperty "first (arr f) = arr (first f)" - (first (arr f) :: A.Transform (Int, Char) (Int, Char)) - (arr (first f)) - , - transformProperty "first (f >>> g) = first f >>> first g" - (first (transform1 >>> transform2) :: A.Transform (Int, Char) (Int, Char)) - (first (transform1) >>> first (transform2)) - , - transformProperty "first f >>> arr fst = arr fst >>> f" - (first transform1 >>> arr fst :: A.Transform (Int, Char) Int) - (arr fst >>> transform1) - , - transformProperty "first f >>> arr (id *** g) = arr (id *** g) >>> first f" - (first transform1 >>> arr (id *** g)) - (arr (id *** g) >>> first transform1) - , - transformProperty "first (first f) >>> arr assoc = arr assoc >>> first f" - (first (first transform1) >>> arr assoc :: A.Transform ((Int, Char), Double) (Int, (Char, Double))) - (arr assoc >>> first transform1) - , - transformProperty "left (arr f) = arr (left f)" - (left (arr f) :: A.Transform (Either Int Char) (Either Int Char)) - (arr (left f)) - , - transformProperty "left (f >>> g) = left f >>> left g" - (left (transform1 >>> transform2) :: A.Transform (Either Int Char) (Either Int Char)) - (left (transform1) >>> left (transform2)) - , - transformProperty "f >>> arr Left = arr Left >>> left f" - (transform1 >>> arr Left :: A.Transform Int (Either Int Char)) - (arr Left >>> left transform1) + testCase "Check produce binding" $ do + resourceVar1 <- newIORef Initial + resourceVar2 <- newIORef Initial + let prod1 = checkProduce resourceVar1 (const True) 100 + prod2 = \x -> checkProduce resourceVar2 (/= Released) x + res <- C.produceAndConsume (prod1 >>= prod2) D.sum + fin <- readIORef resourceVar1 + assertEqual "" Released fin , - transformProperty "left f >>> arr (id +++ g) = arr (id +++ g) >>> left f" - (left transform1 >>> arr (id +++ g)) - (arr (id +++ g) >>> left transform1) + testProperty "Bind for produce" $ \ (list :: [Int]) -> + let check = list >>= (enumFromTo 0) + prod1 = E.list list + prod2 = \x -> E.list $ enumFromTo 0 x + in monadicIO $ do + res <- run $ C.produceAndConsume (prod1 >>= prod2) D.list + M.assert (check == res) , - transformProperty "left (left f) >>> arr assocsum = arr assocsum >>> left f" - (left (left transform1) >>> arr assocsum :: A.Transform (Either (Either Int Char) Double) (Either Int (Either Char Double))) - (arr assocsum >>> left transform1) + testProperty "liftIO for Produce. Consume0" $ \ (_ :: Int) -> + monadicIO $ do + check <- run $ do + checkVar <- newIORef False + let prod = liftIO $ writeIORef checkVar True + C.produceAndConsume prod someThing + readIORef checkVar + M.assert $ check == False , - transformProperty "left (left (arr f)) >>> arr assocsum = arr assocsum >>> left (arr f)" - (left (left (arr f)) >>> arr assocsum :: A.Transform (Either (Either Int Char) Double) (Either Int (Either Char Double))) - (arr assocsum >>> left (arr f)) + testProperty "liftIO for Produce. ConsumeN" $ \ (n :: Int) -> + monadicIO $ do + let prod = liftIO (return n) + len <- run (C.produceAndConsume prod D.count) + M.assert (len == 1) ] - where - f = (+24) :: Int -> Int - g = (*3) :: Int -> Int - transform1 = A.consume (D.transform (A.take 3) D.sum) :: A.Transform Int Int - transform2 = A.consume (D.transform (A.take 4) D.sum) :: A.Transform Int Int - assoc ((a,b),c) = (a,(b,c)) - assocsum (Left (Left x)) = Left x - assocsum (Left (Right y)) = Right (Left y) - assocsum (Right z) = Right (Right z) -transformProperty :: - (Arbitrary input, Show input, Eq output, Show output) => - String -> A.Transform input output -> A.Transform input output -> TestTree -transformProperty name leftTransform rightTransform = - testProperty name property +someThing :: D.Consume input Int +someThing = D.Consume $ \ (Fe.Fetch _) -> return 0 + +single :: Foldable f => f a -> Maybe a +single = join . (foldr' f Nothing) where - property list = - transform leftTransform === transform rightTransform - where - transform transform = - unsafePerformIO (C.produceAndTransformAndConsume (E.list list) transform D.list) + f x Nothing = Just $ Just x + f _ _ = Just Nothing -potoki :: TestTree -potoki = - testGroup "All tests for potoki's end-users functions" $ - [ - testCase "vector to list" $ do - result <- C.produceAndConsume (E.vector (G.fromList [1,2,3])) (D.list) - assertEqual "" [1,2,3] result - , - testCase "just" $ do - result <- C.produceAndConsume (E.list [Just 1, Nothing, Just 2]) (D.transform A.just D.list) - assertEqual "" [1,2] result - , - testCase "transform,consume,take" $ do - let - transform = A.consume (D.transform (A.take 3) D.list) - consume = D.transform transform D.list - produceAndConsume list = C.produceAndConsume (E.list list) (consume) - assertEqual "" [[1,2,3], [4,5,6], [7,8]] =<< produceAndConsume [1,2,3,4,5,6,7,8] - assertEqual "" [[1,2,3], [4,5,6], [7,8,9]] =<< produceAndConsume [1,2,3,4,5,6,7,8,9] - assertEqual "" [] =<< produceAndConsume ([] :: [Int]) - , - testCase "File reading" $ do - let produce = - E.transform (arr (either (const Nothing) Just) >>> A.just) $ - E.fileBytes "samples/1" - result <- C.produceAndConsume produce (fmap F.length D.concat) - assertEqual "" 17400 result - , - transformPotoki - , - parsingPotoki - ] +data Resource + = Initial + | Acquired + | Released + | AcquiredImproperly + | ReleasedImproperly + deriving (Show, Eq) +checkTransform :: IORef Resource -> A.Transform Int Int +checkTransform resourceVar = A.Transform $ \ fetchIO -> Ac.Acquire $ do + writeIORef resourceVar Acquired + return $ (,) (plusFetch fetchIO) $ do + res <- readIORef resourceVar + case res of + Acquired -> writeIORef resourceVar Released + _ -> writeIORef resourceVar ReleasedImproperly -transformPotoki :: TestTree -transformPotoki = - testGroup "Transform" $ - [ - testCase "Order" $ do - let - list = [Left 1, Left 2, Right 'z', Left 2, Right 'a', Left 1, Right 'b', Left 0, Right 'x', Left 4, Left 3] - transform = left (A.consume (D.transform (A.take 2) D.sum)) - result <- C.produceAndConsume (E.list list) (D.transform transform D.list) - assertEqual "" [Left 3, Right 'z', Left 2, Right 'a', Left 1, Right 'b', Left 0, Right 'x', Left 7] result - , - testCase "Interrupted order" $ do - let - list = [Left 1, Left 2, Right 'a'] - transform = left (A.consume (D.transform (A.take 3) D.sum)) - result <- C.produceAndConsume (E.list list) (D.transform transform D.list) - assertEqual "" [Left 3, Right 'a'] result - , - testCase "Distinct" $ do - let - list = [1,2,3,2,3,2,1,4,1] :: [Int] - result <- C.produceAndConsume (E.list list) (D.transform A.distinct D.list) - assertEqual "" [1,2,3,4] result - , - testCase "Distinct By" $ do - let - list = [(1, ""),(2, ""),(3, ""),(2, ""),(3, ""),(2, ""),(1, ""),(4, ""),(1, "")] :: [(Int, String)] - result <- C.produceAndConsume (E.list list) (D.transform (A.distinctBy fst) D.list) - assertEqual "" [(1, ""),(2, ""),(3, ""),(4, "")] result - , - testCase "Concurrently" $ do - let - list = [1..20000] - produce = E.list list - transform = - A.concurrently 12 $ - arr (\ x -> H.randomRIO (0, 100) >>= threadDelay >> return x) >>> - A.executeIO - consume = D.transform transform D.list - result <- C.produceAndConsume produce consume - assertBool "Is dispersed" (list /= result) - assertEqual "Contains no duplicates" 0 (length result - length (nub result)) - assertEqual "Equals the original once sorted" list (sort result) - , - testProperty "Line" $ \ chunks -> - let - expected = - mconcat chunks - actual = - unsafePerformIO (C.produceAndConsume produce consume) - where - produce = - E.list chunks - consume = - rmap (mconcat . intersperse "\n") $ - D.transform A.extractLines D.list - in expected === actual - ] - -parsingPotoki :: TestTree -parsingPotoki = - testGroup "Parsing" $ - [ - testCase "Sample 1" $ do - let parser = B.double <* B.char ',' - transform = arr (either (const Nothing) Just) >>> A.just >>> A.parseBytes parser - produce = E.transform transform (E.fileBytes "samples/1") - result <- C.produceAndConsume produce D.count - assertEqual "" 4350 result - , - testCase "Sample 1 greedy" $ do - let parser = B.sepBy B.double (B.char ',') - transform = arr (either (const Nothing) Just) >>> A.just >>> A.parseBytes parser - produce = E.transform transform (E.fileBytes "samples/1") - result <- C.produceAndConsume produce D.list - assertEqual "" [Right 4350] (fmap (fmap length) result) - , - testCase "Split chunk" $ - let - produce = E.list ["1", "2", "3"] - parser = B.anyChar - transform = A.parseBytes parser >>> arr (either (const Nothing) Just) >>> A.just - consume = D.transform transform D.count - in do - assertEqual "" 3 =<< C.produceAndConsume produce consume - ] +plusFetch :: Fe.Fetch Int -> Fe.Fetch Int +plusFetch (Fe.Fetch fetchIO) = Fe.Fetch $ do + fetch <- fetchIO + return $ fmap succ fetch + +checkProduce :: IORef Resource -> (Resource -> Bool) -> Int -> E.Produce Int +checkProduce resourceVar f k = E.Produce . Ac.Acquire $ do + res <- readIORef resourceVar + if f res && res /= Initial + then do + return $ (,) (Fe.Fetch $ return Nothing) $ writeIORef resourceVar AcquiredImproperly + else do + writeIORef resourceVar Acquired + stVar <- newIORef 0 + let fetch = do + n <- readIORef stVar + if n >= k then return (Nothing) + else do + writeIORef stVar $! n + 1 + return (Just n) + return $ (,) (Fe.Fetch fetch) $ do + res <- readIORef resourceVar + case res of + Acquired -> writeIORef resourceVar Released + _ -> writeIORef resourceVar ReleasedImproperly + +asyncCheckResource :: TVar Resource -> E.Produce Int +asyncCheckResource resourceVar = E.Produce . Ac.Acquire $ do + atomically $ writeTVar resourceVar Acquired + stVar <- newIORef 0 + let fetch = do + n <- readIORef stVar + writeIORef stVar $! n + 1 + return (Just n) + return (Fe.Fetch fetch, atomically $ writeTVar resourceVar Released) + +syncCheckResource :: IORef Resource -> E.Produce Int +syncCheckResource resourceVar = E.Produce . Ac.Acquire $ do + writeIORef resourceVar Acquired + stVar <- newIORef 0 + let fetch = do + n <- readIORef stVar + if n >= 1000 then return (Nothing) + else do + writeIORef stVar $! n + 1 + return (Just n) + return $ (,) (Fe.Fetch fetch) $ do + res <- readIORef resourceVar + case res of + Acquired -> writeIORef resourceVar Released + _ -> writeIORef resourceVar ReleasedImproperly diff --git a/tests/Potoki.hs b/tests/Potoki.hs new file mode 100644 --- /dev/null +++ b/tests/Potoki.hs @@ -0,0 +1,253 @@ +module Potoki where + +import Prelude hiding (first, second) +import Control.Arrow +import Test.QuickCheck.Instances +import Test.QuickCheck.Monadic as M +import Test.Tasty +import Test.Tasty.Runners +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import qualified Control.Foldl as Fl +import qualified Potoki.Core.IO as C +import qualified Potoki.Core.Consume as D +import qualified Potoki.Core.Transform as A +import qualified Potoki.Core.Produce as E +import qualified Data.Attoparsec.ByteString.Char8 as B +import qualified Data.ByteString as F +import qualified Data.Vector as G +import qualified System.Random as H +import Data.List.Index (indexed) + +potoki :: TestTree +potoki = + testGroup "All tests for potoki's end-users functions" $ + [ + testCase "vector to list" $ do + result <- C.produceAndConsume (E.vector (G.fromList [1,2,3])) (D.list) + assertEqual "" [1,2,3] result + , + testCase "just" $ do + result <- C.produceAndConsume (E.list [Just 1, Nothing, Just 2]) (D.transform A.just D.list) + assertEqual "" [1,2] result + , + testCase "transform,consume,take" $ do + let + transform = A.consume (D.transform (A.take 3) D.list) + consume = D.transform transform D.list + produceAndConsume list = C.produceAndConsume (E.list list) (consume) + assertEqual "" [[1,2,3], [4,5,6], [7,8]] =<< produceAndConsume [1,2,3,4,5,6,7,8] + assertEqual "" [[1,2,3], [4,5,6], [7,8,9]] =<< produceAndConsume [1,2,3,4,5,6,7,8,9] + assertEqual "" [] =<< produceAndConsume ([] :: [Int]) + , + testCase "File reading" $ do + let produce = + E.transform (arr (either (const Nothing) Just) >>> A.just) $ + E.fileBytes "samples/1" + result <- C.produceAndConsume produce (fmap F.length D.concat) + assertEqual "" 17400 result + , + transformPotoki + , + parsingPotoki + , + consumePotoki + ] + + +transformPotoki :: TestTree +transformPotoki = + testGroup "Transform" $ + [ + testCase "Order" $ do + let + list = [Left 1, Left 2, Right 'z', Left 2, Right 'a', Left 1, Right 'b', Left 0, Right 'x', Left 4, Left 3] + transform = left (A.consume (D.transform (A.take 2) D.sum)) + result <- C.produceAndConsume (E.list list) (D.transform transform D.list) + assertEqual "" [Left 3, Right 'z', Left 2, Right 'a', Left 1, Right 'b', Left 0, Right 'x', Left 7] result + , + testCase "Interrupted order" $ do + let + list = [Left 1, Left 2, Right 'a'] + transform = left (A.consume (D.transform (A.take 3) D.sum)) + result <- C.produceAndConsume (E.list list) (D.transform transform D.list) + assertEqual "" [Left 3, Right 'a'] result + , + testCase "Distinct" $ do + let + list = [1,2,3,2,3,2,1,4,1] :: [Int] + result <- C.produceAndConsume (E.list list) (D.transform A.distinct D.list) + assertEqual "" [1,2,3,4] result + , + testCase "Distinct By" $ do + let + list = [(1, ""),(2, ""),(3, ""),(2, ""),(3, ""),(2, ""),(1, ""),(4, ""),(1, "")] :: [(Int, String)] + result <- C.produceAndConsume (E.list list) (D.transform (A.distinctBy fst) D.list) + assertEqual "" [(1, ""),(2, ""),(3, ""),(4, "")] result + , + testCase "Concurrently" $ do + let + list = [1..20000] + produce = E.list list + transform = + A.concurrently 12 $ + arr (\ x -> H.randomRIO (0, 100) >>= threadDelay >> return x) >>> + A.executeIO + consume = D.transform transform D.list + result <- C.produceAndConsume produce consume + assertBool "Is dispersed" (list /= result) + assertEqual "Contains no duplicates" 0 (length result - length (nub result)) + assertEqual "Equals the original once sorted" list (sort result) + , + testProperty "Line" $ \ chunks -> + let + expected = + mconcat chunks + actual = + unsafePerformIO (C.produceAndConsume produce consume) + where + produce = + E.list chunks + consume = + rmap (mconcat . intersperse "\n") $ + D.transform A.extractLines D.list + in expected === actual + ] + +parsingPotoki :: TestTree +parsingPotoki = + testGroup "Parsing" $ + [ + testCase "Sample 1" $ do + let parser = B.double <* B.char ',' + transform = arr (either (const Nothing) Just) >>> A.just >>> A.parseBytes parser + produce = E.transform transform (E.fileBytes "samples/1") + result <- C.produceAndConsume produce D.count + assertEqual "" 4350 result + , + testCase "Sample 1 greedy" $ do + let parser = B.sepBy B.double (B.char ',') + transform = arr (either (const Nothing) Just) >>> A.just >>> A.parseBytes parser + produce = E.transform transform (E.fileBytes "samples/1") + result <- C.produceAndConsume produce D.list + assertEqual "" [Right 4350] (fmap (fmap length) result) + , + testCase "Split chunk" $ + let + produce = E.list ["1", "2", "3"] + parser = B.anyChar + transform = A.parseBytes parser >>> arr (either (const Nothing) Just) >>> A.just + consume = D.transform transform D.count + in do + assertEqual "" 3 =<< C.produceAndConsume produce consume + ] + +consumePotoki = + testGroup "Consume" $ + [ + testProperty "count" $ \ (list :: [Int]) -> + let n = length list + in monadicIO $ do + let prod = E.list list + len <- run (C.produceAndConsume prod D.count) + M.assert (len == n) + , + testProperty "sum" $ \ (list :: [Int]) -> + let n = sum list + in monadicIO $ do + let prod = E.list list + len <- run (C.produceAndConsume prod D.sum) + M.assert (len == n) + , + testProperty "head" $ \ (list :: [Int]) -> + let el = if null list then Nothing else (Just (head list)) + in monadicIO $ do + let prod = E.list list + he <- run (C.produceAndConsume prod D.head) + M.assert (he == el) + , + testProperty "last" $ \ (list :: [Int]) -> + let el = if null list then Nothing else (Just (last list)) + in monadicIO $ do + let prod = E.list list + he <- run (C.produceAndConsume prod D.last) + M.assert (he == el) + , + testProperty "list" $ \ (list :: [Int]) -> + monadicIO $ do + let prod = E.list list + res <- run (C.produceAndConsume prod D.list) + M.assert (res == list) + , + testProperty "reverseList" $ \ (list :: [Int]) -> + let revList = reverse list + in monadicIO $ do + let prod = E.list list + res <- run (C.produceAndConsume prod D.reverseList) + M.assert (res == revList) + , + testProperty "vector" $ \ (list :: [Int]) -> + let vec = G.fromList list + in monadicIO $ do + let prod = E.list list + res <- run (C.produceAndConsume prod D.vector) + M.assert (res == vec) + , + testProperty "concat" $ \ (list :: [[Int]]) -> + let con = concat list + in monadicIO $ do + let prod = E.list list + res <- run (C.produceAndConsume prod D.concat) + M.assert (res == con) + , + testProperty "fold" $ \ (list :: [Int], fun :: (Fun (Int, Int) Int), first :: Int) -> + let f = applyFun2 fun + fol = foldl' f first list + in monadicIO $ do + let prod = E.list list + res <- run (C.produceAndConsume prod (D.fold (Fl.Fold f first id))) + M.assert (res == fol) + , + testProperty "foldInIO" $ \ (list :: [Int]) -> + let fin = sum list + in monadicIO $ do + let prod = E.list list + res <- run $ do + sumVar <- newIORef 0 + (C.produceAndConsume prod (D.foldInIO (Fl.FoldM (\_ a -> modifyIORef' sumVar (a+)) (pure ()) (\_ -> readIORef sumVar)) ) ) + M.assert (res == fin) + , + testProperty "folding" $ \ (list :: [Int], fun :: (Fun (Int, Int) Int), first :: Int) -> + let f = applyFun2 fun + fol = foldl' f first list + in monadicIO $ do + let prod = E.list list + res <- run (C.produceAndConsume prod (D.folding (Fl.Fold f first id) (D.sum) )) + a <- run (C.produceAndConsume prod D.sum) + M.assert (res == (fol, a)) + , + testProperty "foldingInIO" $ \ (list :: [Int]) -> + let fol = sum list + in monadicIO $ do + let prod = E.list list + res <- run $ do + sumVar <- newIORef 0 + (C.produceAndConsume prod (D.foldingInIO (Fl.FoldM (\_ a -> modifyIORef' sumVar (a+)) (pure ()) (\_ -> readIORef sumVar)) (D.sum) )) + a <- run (C.produceAndConsume prod D.sum) + M.assert (res == (fol, a)) + , + testProperty "execState" $ \ (list :: [Int]) -> + let f = modify' . (+) + resL = sum list + in monadicIO $ do + let prod = E.list list + res <- run (C.produceAndConsume prod (D.execState f 0)) + M.assert (res == resL) + , + testProperty "Choice consume right'" $ \ (list :: [Either Bool Int]) -> + let n = sum <$> sequence list + in monadicIO $ do + let prod = E.list list + len <- run (C.produceAndConsume prod $ right' D.sum) + M.assert (len == n) + ] diff --git a/tests/Transform.hs b/tests/Transform.hs new file mode 100644 --- /dev/null +++ b/tests/Transform.hs @@ -0,0 +1,178 @@ +module Transform where + +import Prelude hiding (first, second) +import Control.Arrow +import Test.QuickCheck.Instances +import Test.Tasty +import Test.Tasty.Runners +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import qualified Potoki.Core.IO as C +import qualified Potoki.Core.Consume as D +import qualified Potoki.Core.Transform as A +import qualified Potoki.Core.Produce as E +import qualified Data.Attoparsec.ByteString.Char8 as B +import qualified Data.ByteString as F +import qualified Data.Vector as G +import qualified System.Random as H + +transform :: TestTree +transform = + testGroup "Transform" $ + [ + transformProduce + , + transformChoice + , + transformArrowLaws + ] + +transformProduce = + testGroup "Produce" $ + [ + testCase "1" $ do + let + list = [1, 2, 3] :: [Int] + result <- C.produceAndTransformAndConsume + (E.list list) + (A.produce (E.list . \ n -> flip replicate n n)) + (D.list) + assertEqual "" [1, 2, 2, 3, 3, 3] result + , + testCase "2" $ do + let + list = [1, 2, 3] :: [Int] + result <- C.produceAndTransformAndConsume + (E.list list) + (A.produce (E.list . \ n -> [(n, n)])) + (D.list) + assertEqual "" [(1, 1), (2, 2), (3, 3)] result + , + testCase "3" $ do + let + list = [1, 2, 3] :: [Int] + result <- C.produceAndTransformAndConsume + (E.list list) + (A.produce (E.list . \ n -> [n, n])) + (D.list) + assertEqual "" [1, 1, 2, 2, 3, 3] result + ] + +transformChoice = + testGroup "Choice" $ + [ + testCase "1" $ do + let + list = [Left 1, Left 2, Right 'z', Left 2, Right 'a', Left 1, Right 'b', Left 0, Right 'x', Left 4, Left 3] + transform = left' id + result <- C.produceAndTransformAndConsume (E.list list) transform D.list + assertEqual "" [Left 1, Left 2, Right 'z', Left 2, Right 'a', Left 1, Right 'b', Left 0, Right 'x', Left 4, Left 3] result + , + testCase "2" $ do + let + list = [Left 1, Left 2, Right 'z', Right 'a', Right 'b', Left 0, Right 'x', Left 4, Left 3] + transform = right' (A.consume D.list) + result <- C.produceAndTransformAndConsume (E.list list) transform D.list + assertEqual "" [Left 1, Left 2, Right "zab", Left 0, Right "x", Left 4, Left 3] result + , + testCase "3" $ do + let + list = [Left 4, Right 'z', Right 'a', Left 3, Right 'b', Left 0, Left 1, Right 'x', Left 4, Left 3] + transform = left' (A.consume D.list) + result <- C.produceAndTransformAndConsume (E.list list) transform D.list + assertEqual "" [Left [4], Right 'z', Right 'a', Left [3], Right 'b', Left [0, 1], Right 'x', Left [4, 3]] result + ] + +transformArrowLaws = + testGroup "Arrow laws" + [ + testGroup "Strong" + [ + testCase "1" $ do + let + input = [(1,'a'),(2,'b'),(3,'c'),(4,'d')] + transform = first transform1 + result <- C.produceAndTransformAndConsume (E.list input) transform D.list + assertEqual "" [(6,'c'),(4,'d')] result + , + testCase "Lack of elements" $ do + let + input = [(1,'a'),(2,'b')] + transform = first transform1 + result <- C.produceAndTransformAndConsume (E.list input) transform D.list + assertEqual "" [(3,'b')] result + ] + , + transformProperty "arr id = id" + (arr id :: A.Transform Int Int) + id + , + transformProperty "arr (f >>> g) = arr f >>> arr g" + (arr (f >>> g)) + (arr f >>> arr g) + , + transformProperty "first (arr f) = arr (first f)" + (first (arr f) :: A.Transform (Int, Char) (Int, Char)) + (arr (first f)) + , + transformProperty "first (f >>> g) = first f >>> first g" + (first (transform1 >>> transform2) :: A.Transform (Int, Char) (Int, Char)) + (first (transform1) >>> first (transform2)) + , + transformProperty "first f >>> arr fst = arr fst >>> f" + (first transform1 >>> arr fst :: A.Transform (Int, Char) Int) + (arr fst >>> transform1) + , + transformProperty "first f >>> arr (id *** g) = arr (id *** g) >>> first f" + (first transform1 >>> arr (id *** g)) + (arr (id *** g) >>> first transform1) + , + transformProperty "first (first f) >>> arr assoc = arr assoc >>> first f" + (first (first transform1) >>> arr assoc :: A.Transform ((Int, Char), Double) (Int, (Char, Double))) + (arr assoc >>> first transform1) + , + transformProperty "left (arr f) = arr (left f)" + (left (arr f) :: A.Transform (Either Int Char) (Either Int Char)) + (arr (left f)) + , + transformProperty "left (f >>> g) = left f >>> left g" + (left (transform1 >>> transform2) :: A.Transform (Either Int Char) (Either Int Char)) + (left (transform1) >>> left (transform2)) + , + transformProperty "f >>> arr Left = arr Left >>> left f" + (transform1 >>> arr Left :: A.Transform Int (Either Int Char)) + (arr Left >>> left transform1) + , + transformProperty "left f >>> arr (id +++ g) = arr (id +++ g) >>> left f" + (left transform1 >>> arr (id +++ g)) + (arr (id +++ g) >>> left transform1) + , + transformProperty "left (left f) >>> arr assocsum = arr assocsum >>> left f" + (left (left transform1) >>> arr assocsum :: A.Transform (Either (Either Int Char) Double) (Either Int (Either Char Double))) + (arr assocsum >>> left transform1) + , + transformProperty "left (left (arr f)) >>> arr assocsum = arr assocsum >>> left (arr f)" + (left (left (arr f)) >>> arr assocsum :: A.Transform (Either (Either Int Char) Double) (Either Int (Either Char Double))) + (arr assocsum >>> left (arr f)) + ] + where + f = (+24) :: Int -> Int + g = (*3) :: Int -> Int + transform1 = A.consume (D.transform (A.take 3) D.sum) :: A.Transform Int Int + transform2 = A.consume (D.transform (A.take 4) D.sum) :: A.Transform Int Int + assoc ((a,b),c) = (a,(b,c)) + assocsum (Left (Left x)) = Left x + assocsum (Left (Right y)) = Right (Left y) + assocsum (Right z) = Right (Right z) + +transformProperty :: + (Arbitrary input, Show input, Eq output, Show output) => + String -> A.Transform input output -> A.Transform input output -> TestTree +transformProperty name leftTransform rightTransform = + testProperty name property + where + property list = + transform leftTransform === transform rightTransform + where + transform transform = + unsafePerformIO (C.produceAndTransformAndConsume (E.list list) transform D.list)