packages feed

potoki-core (empty) → 0.9

raw patch · 11 files changed

+830/−0 lines, 11 filesdep +QuickCheckdep +basedep +managedsetup-changed

Dependencies added: QuickCheck, base, managed, potoki-core, profunctors, quickcheck-instances, rerebase, stm, tasty, tasty-hunit, tasty-quickcheck

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2017, Metrix.AI++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.++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ library/Potoki/Core/Consume.hs view
@@ -0,0 +1,82 @@+module Potoki.Core.Consume where++import Potoki.Core.Prelude+import Potoki.Core.Types+import qualified Potoki.Core.Fetch as A+++instance Profunctor Consume where+  {-# INLINE dimap #-}+  dimap inputMapping outputMapping (Consume consume) =+    Consume (\ fetch -> fmap outputMapping (consume (fmap inputMapping fetch)))++instance Choice Consume where+  right' (Consume rightConsumeIO) =+    Consume $ \ (Fetch eitherFetchIO) -> do+      fetchedLeftMaybeRef <- newIORef Nothing+      consumedRight <- +        rightConsumeIO $ Fetch $ \ nil just -> join $ eitherFetchIO (return nil) $ \ case+          Right !fetchedRight -> return (just fetchedRight)+          Left !fetchedLeft -> writeIORef fetchedLeftMaybeRef (Just fetchedLeft) >> return nil+      fetchedLeftMaybe <- readIORef fetchedLeftMaybeRef+      case fetchedLeftMaybe of+        Nothing -> return (Right consumedRight)+        Just fetchedLeft -> return (Left fetchedLeft)++instance Functor (Consume input) where+  fmap = rmap++instance Applicative (Consume a) where+  pure x = Consume $ \_ -> pure x++  Consume leftConsumeIO <*> Consume rightConsumeIO =+    Consume $ \fetch -> leftConsumeIO fetch <*> rightConsumeIO fetch++instance Monad (Consume a) where+  Consume leftConsumeIO >>= toRightConsumeIO = Consume $ \fetch -> do+    Consume rightConsumeIO <- toRightConsumeIO <$> leftConsumeIO fetch+    rightConsumeIO fetch++instance MonadIO (Consume a) where+  liftIO a = Consume $ \_ -> a++apConcurrently :: Consume a (b -> c) -> Consume a b -> Consume a c+apConcurrently (Consume leftConsumeIO) (Consume rightConsumeIO) =+  Consume $ \ fetch -> do+    (leftFetch, rightFetch) <- A.duplicate fetch+    rightOutputVar <- newEmptyMVar+    forkIO $ do+      !rightOutput <- rightConsumeIO rightFetch+      putMVar rightOutputVar rightOutput+    !leftOutput <- leftConsumeIO leftFetch+    rightOutput <- takeMVar rightOutputVar+    return (leftOutput rightOutput)++{-# INLINABLE list #-}+list :: Consume input [input]+list =+  Consume $ \ (Fetch fetchIO) ->+  let+    build !acc =+      join+        (fetchIO+          (pure (acc []))+          (\ !element -> build (acc . (:) element)))+    in build id++{-# INLINE sum #-}+sum :: Num num => Consume num num+sum =+  Consume $ \ (Fetch fetchIO) ->+  let+    build !acc =+      join+        (fetchIO+          (pure acc)+          (\ !element -> build (element + acc)))+    in build 0++{-# INLINABLE transform #-}+transform :: Transform input output -> Consume output sinkOutput -> Consume input sinkOutput+transform (Transform transformManaged) (Consume sink) =+  Consume (\ fetch -> with (fmap ($ fetch) transformManaged) sink)
+ library/Potoki/Core/Fetch.hs view
@@ -0,0 +1,162 @@+module Potoki.Core.Fetch where++import Potoki.Core.Prelude+import Potoki.Core.Types+++deriving instance Functor Fetch++instance Applicative Fetch where+  pure x =+    Fetch (\ nil just -> pure (just x))+  (<*>) (Fetch leftFn) (Fetch rightFn) =+    Fetch (\ nil just ->+      join (leftFn (pure nil) (\ leftElement ->+        rightFn nil (\ rightElement -> just (leftElement rightElement)))))++instance Monad Fetch where+  return =+    pure+  (>>=) (Fetch leftFn) rightK =+    Fetch (\ nil just ->+      join (leftFn (pure nil) (\ leftElement ->+        case rightK leftElement of+          Fetch rightFn -> rightFn nil just)))++instance Alternative Fetch where+  empty =+    Fetch (\ nil just -> pure nil)+  (<|>) (Fetch leftSignal) (Fetch rightSignal) =+    Fetch (\ nil just -> join (leftSignal (rightSignal nil just) (pure . just)))++instance MonadPlus Fetch where+  mzero =+    empty+  mplus =+    (<|>)++{-# INLINABLE duplicate #-}+duplicate :: Fetch element -> IO (Fetch element, Fetch element)+duplicate (Fetch fetchIO) =+  do+    leftBuffer <- newTQueueIO+    rightBuffer <- newTQueueIO+    notFetchingVar <- newTVarIO True+    notEndVar <- newTVarIO True+    let+      newFetch ownBuffer mirrorBuffer =+        Fetch+          (\ nil just -> do+            join+              (atomically+                (mplus+                  (do+                    element <- readTQueue ownBuffer+                    return (return (just element)))+                  (do+                    notEnd <- readTVar notEndVar+                    if notEnd+                      then do+                        notFetching <- readTVar notFetchingVar+                        guard notFetching+                        writeTVar notFetchingVar False+                        return+                          (join+                            (fetchIO+                              (do+                                atomically+                                  (do+                                    writeTVar notEndVar False+                                    writeTVar notFetchingVar True)+                                return nil)+                              (\ !element -> do+                                atomically+                                  (do+                                    writeTQueue mirrorBuffer element+                                    writeTVar notFetchingVar True)+                                return (just element))))+                      else return (return nil)))))+      leftFetch =+        newFetch leftBuffer rightBuffer+      rightFetch =+        newFetch rightBuffer leftBuffer+      in return (leftFetch, rightFetch)++{-# INLINABLE maybeRef #-}+maybeRef :: IORef (Maybe a) -> Fetch a+maybeRef refElem =+  Fetch $ \nil just -> do+    elem <- readIORef refElem+    case elem of+      Nothing -> return nil+      Just e  -> do+        writeIORef refElem Nothing+        return $ just e++{-# INLINABLE list #-}+list :: IORef [element] -> Fetch element+list unsentListRef =+  Fetch $ \nil just -> do+    refList <- readIORef unsentListRef+    case refList of+      (!head) : tail -> do+        writeIORef unsentListRef tail+        return $ just head+      _              -> do+        writeIORef unsentListRef []+        return nil++{-# INLINABLE firstCachingSecond #-}+firstCachingSecond :: IORef b -> Fetch (a, b) -> Fetch a+firstCachingSecond cacheRef (Fetch bothFetchIO) =+  Fetch $ \ nil just ->+  join $+  bothFetchIO+    (return nil)+    (\ (!first, !second) -> do+      writeIORef cacheRef second+      return (just first))++{-# INLINABLE bothFetchingFirst #-}+bothFetchingFirst :: IORef b -> Fetch a -> Fetch (a, b)+bothFetchingFirst cacheRef (Fetch firstFetchIO) =+  Fetch $ \ nil just ->+  join $+  firstFetchIO+    (return nil)+    (\ !firstFetched -> do+      secondCached <- readIORef cacheRef+      return (just (firstFetched, secondCached)))++{-# INLINABLE rightHandlingLeft #-}+rightHandlingLeft :: (left -> IO ()) -> Fetch (Either left right) -> Fetch right+rightHandlingLeft handle (Fetch eitherFetchIO) =+  Fetch $ \ nil just ->+  join $ eitherFetchIO (return nil) $ \ case+    Right !rightInput -> return (just rightInput)+    Left !leftInput -> handle leftInput $> nil++{-# INLINABLE rightCachingLeft #-}+rightCachingLeft :: IORef (Maybe left) -> Fetch (Either left right) -> Fetch right+rightCachingLeft cacheRef =+  rightHandlingLeft (writeIORef cacheRef . Just)++{-# INLINABLE eitherFetchingRight #-}+eitherFetchingRight :: IORef (Maybe left) -> Fetch right -> Fetch (Either left right)+eitherFetchingRight cacheRef (Fetch rightFetchIO) =+  Fetch $ \ nil just ->+  join $ rightFetchIO (return nil) $ \ right ->+  atomicModifyIORef' cacheRef $ \ case+    Nothing -> (Nothing, just (Right right))+    Just left -> (Nothing, just (Left left))++{-# INLINABLE signaling #-}+signaling :: IO () -> IO () -> Fetch a -> Fetch a+signaling signalEnd signalElement (Fetch io) =+  Fetch $ \ nil just ->+  join (io (signalEnd $> nil) (\ element -> signalElement >> return (just element)))++{-# INLINE ioMaybe #-}+ioMaybe :: IO (Maybe a) -> Fetch a+ioMaybe io =+  Fetch $ \nil just -> maybe nil just <$> io
+ library/Potoki/Core/IO.hs view
@@ -0,0 +1,46 @@+module Potoki.Core.IO where++import Potoki.Core.Prelude+import Potoki.Core.Types+import qualified Potoki.Core.Produce as A+import qualified Potoki.Core.Consume as B+++produceAndConsume :: Produce input -> Consume input output -> IO output+produceAndConsume (Produce produceManaged) (Consume consume) =+  with produceManaged consume++produceAndTransformAndConsume :: Produce input -> Transform input anotherInput -> Consume anotherInput output -> IO output+produceAndTransformAndConsume (Produce produceManaged) (Transform transformManaged) (Consume consume) =+  with (($) <$> transformManaged <*> produceManaged) consume++produce :: Produce input -> forall x. IO x -> (input -> IO x) -> IO x+produce (Produce produceManaged) stop emit =+  with produceManaged $ \ (Fetch fetchIO) -> +  fix (\ loop -> join (fetchIO stop (\ element -> emit element >> loop)))++consume :: (forall x. x -> (input -> x) -> IO x) -> Consume input output -> IO output+consume fetch (Consume consume) =+  consume (Fetch fetch)++{-| Fetch all the elements running the provided handler on them -}+fetchAndHandleAll :: Fetch element -> IO () -> (element -> IO ()) -> IO ()+fetchAndHandleAll (Fetch fetchIO) onEnd onElement =+  fix (\ loop -> join (fetchIO onEnd (\ element -> onElement element >> loop)))++{-| Fetch and handle just one element -}+fetchAndHandle :: Fetch element -> IO a -> (element -> IO a) -> IO a+fetchAndHandle (Fetch fetchIO) onEnd onElement =+  join (fetchIO onEnd onElement)++{-| Fetch just one element -}+fetch :: Fetch element -> IO (Maybe element)+fetch (Fetch fetchIO) =+  fetchIO Nothing Just++transformList :: Transform a b -> [a] -> IO [b]+transformList transform inputList =+  produceAndTransformAndConsume+    (A.list inputList)+    transform+    (B.list)
+ library/Potoki/Core/Prelude.hs view
@@ -0,0 +1,83 @@+module Potoki.Core.Prelude+( +  module Exports,+)+where++-- base+-------------------------+import Control.Applicative as Exports+import Control.Arrow as Exports+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.IO.Class as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.ST as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports+import Data.Int as Exports+import Data.IORef as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+import Data.Maybe as Exports+import Data.Monoid as Exports+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports+import Data.String as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports+import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)+import GHC.Exts as Exports (lazy, inline, sortWith, groupWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import Numeric as Exports+import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports (Handle, hClose)+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (printf, hPrintf)+import Text.Read as Exports (Read(..), readMaybe, readEither)+import Unsafe.Coerce as Exports++-- profunctors+-------------------------+import Data.Profunctor.Unsafe as Exports+import Data.Profunctor.Choice as Exports+import Data.Profunctor.Strong as Exports++-- stm+-------------------------+import Control.Concurrent.STM as Exports++-- managed+-------------------------+import Control.Monad.Managed as Exports
+ library/Potoki/Core/Produce.hs view
@@ -0,0 +1,34 @@+module Potoki.Core.Produce where++import Potoki.Core.Prelude+import Potoki.Core.Types+import qualified Potoki.Core.Fetch as A+++deriving instance Functor Produce++instance Applicative Produce where+  pure x = Produce $ do+    refX <- newIORef (Just x)+    return (A.maybeRef refX, pure ())+  (<*>) (Produce leftManaged) (Produce rightManaged) =+    Produce ((<*>) <$> leftManaged <*> rightManaged)++instance Alternative Produce where+  empty =+    Produce (pure empty)+  (<|>) (Produce leftManaged) (Produce rightManaged) =+    Produce ((<|>) <$> leftManaged <*> rightManaged)++{-# INLINABLE list #-}+list :: [input] -> Produce input+list list =+  Produce (liftIO (A.list <$> newIORef list))++{-# INLINE transform #-}+transform :: Transform input output -> Produce input -> Produce output+transform (Transform transformManaged) (Produce produceManaged) =+  Produce $ do+    fetch <- produceManaged+    newFetch <- transformManaged+    return (newFetch fetch)
+ library/Potoki/Core/Transform.hs view
@@ -0,0 +1,126 @@+module Potoki.Core.Transform+(+  Transform(..),+  consume,+  mapFetch,+  executeIO,+  take,+)+where++import Potoki.Core.Prelude hiding (take)+import Potoki.Core.Types+import qualified Potoki.Core.Fetch as A+import qualified Potoki.Core.Consume as C+import qualified Potoki.Core.Produce as D+import qualified Potoki.Core.IO as E+++instance Category Transform where+  id =+    Transform (return id)+  (.) (Transform left) (Transform right) =+    Transform ((.) <$> left <*> right)++instance Profunctor Transform where+  dimap inputMapping outputMapping (Transform managed) =+    Transform $ do+      newFetch <- managed+      return $ \ oldFetch -> fmap outputMapping (newFetch (fmap inputMapping oldFetch))++instance Choice Transform where+  right' (Transform rightTransformManaged) =+    Transform $ do+      rightInFetchToOutFetch <- rightTransformManaged+      fetchedLeftMaybeRef <- liftIO (newIORef Nothing)+      return $ \ inFetch ->+        let+          Fetch rightFetchIO = rightInFetchToOutFetch (A.rightHandlingLeft (writeIORef fetchedLeftMaybeRef . Just) inFetch)+          in Fetch $ \ stop yield -> do+            join $ rightFetchIO+              (do+                fetchedLeftMaybe <- readIORef fetchedLeftMaybeRef+                case fetchedLeftMaybe of+                  Just fetchedLeft -> do+                    writeIORef fetchedLeftMaybeRef Nothing+                    return (yield (Left fetchedLeft))+                  Nothing -> return stop)+              (\ right -> return (yield (Right right)))++instance Strong Transform where+  first' (Transform firstTransformManaged) =+    Transform $ do+      cacheRef <- liftIO (newIORef undefined)+      firstInFetchToOutFetch <- firstTransformManaged+      return (A.bothFetchingFirst cacheRef . firstInFetchToOutFetch . A.firstCachingSecond cacheRef)++instance Arrow Transform where+  arr fn =+    Transform (return (fmap fn))+  first =+    first'++instance ArrowChoice Transform where+  left =+    left'++{-# INLINE consume #-}+consume :: Consume input output -> Transform input output+consume (Consume runFetch) =+  Transform $ do+    stoppedRef <- liftIO (newIORef False)+    return $ \ (Fetch fetch) -> Fetch $ \ stop yield -> do+      stopped <- readIORef stoppedRef+      if stopped+        then do+          writeIORef stoppedRef False+          return stop+        else do+          emittedRef <- newIORef False+          output <-+            runFetch $ Fetch $ \ inputNil inputJust ->+            join+              (fetch+                (do+                  writeIORef stoppedRef True+                  return inputNil)+                (\ !input -> do+                  writeIORef emittedRef True+                  return (inputJust input)))+          stopped <- readIORef stoppedRef+          if stopped+            then do+              emitted <- readIORef emittedRef+              if emitted+                then return (yield output)+                else do+                  writeIORef stoppedRef False+                  return stop+            else return (yield output)++{-# INLINE mapFetch #-}+mapFetch :: (Fetch a -> Fetch b) -> Transform a b+mapFetch mapping =+  Transform $ return mapping++{-|+Execute the IO action.+-}+{-# INLINE executeIO #-}+executeIO :: Transform (IO a) a+executeIO =+  mapFetch $ \ (Fetch fetchIO) -> Fetch $ \ stop yield ->+  join (fetchIO (return stop) (fmap yield))++{-# INLINE take #-}+take :: Int -> Transform input input+take amount =+  Transform $ do+    countRef <- liftIO (newIORef amount)+    return $ \ (Fetch fetchIO) -> Fetch $ \ stop yield -> do+      count <- readIORef countRef+      if count > 0+        then do+          writeIORef countRef $! pred count+          fetchIO stop yield+        else return stop
+ library/Potoki/Core/Types.hs view
@@ -0,0 +1,37 @@+module Potoki.Core.Types+where++import Potoki.Core.Prelude+++{-|+Passive producer of elements with support for early termination.+-}+newtype Fetch element =+  {-|+  Something close to a Church encoding of @IO (Maybe element)@.+  -}+  Fetch (forall x. x -> (element -> x) -> IO x)++{-|+Passive producer of elements with support for early termination+and resource management.+-}+newtype Produce element =+  Produce (Managed (Fetch element))++{-|+Active consumer of input into output.+Sort of like a reducer in Map/Reduce.++Automates the management of resources.+-}+newtype Consume input output =+  {-|+  An action, which executes the provided fetch in IO,+  while managing the resources behind the scenes.+  -}+  Consume (Fetch input -> IO output)++newtype Transform input output =+  Transform (Managed (Fetch input -> Fetch output))
+ potoki-core.cabal view
@@ -0,0 +1,81 @@+name:+  potoki-core+version:+  0.9+synopsis:+  Low-level components of "potoki"+description:+  Provides everything required for building custom instances of+  the \"potoki\" abstractions.+  Consider this library to be the Internals modules of \"potoki\".+category:+  Streaming+homepage:+  https://github.com/metrix-ai/potoki-core +bug-reports:+  https://github.com/metrix-ai/potoki-core/issues +author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Metrix.AI Ninjas <ninjas@metrix.ai>+copyright:+  (c) 2017, Metrix.AI+license:+  MIT+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  >=1.10++source-repository head+  type:+    git+  location:+    git://github.com/metrix-ai/potoki-core.git++library+  hs-source-dirs:+    library+  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+  exposed-modules:+    Potoki.Core.Produce+    Potoki.Core.Fetch+    Potoki.Core.Consume+    Potoki.Core.IO+    Potoki.Core.Transform+  other-modules:+    Potoki.Core.Types+    Potoki.Core.Prelude+  build-depends:+    base >=4.7 && <5,+    managed >=1.0.5 && <2,+    profunctors >=5.2 && <6,+    stm >=2.4 && <3++test-suite tests+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    tests+  main-is:+    Main.hs+  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:+    tasty >=0.12 && <0.13,+    tasty-quickcheck >=0.9 && <0.10,+    tasty-hunit >=0.9 && <0.10,+    quickcheck-instances >=0.3.11 && <0.4,+    QuickCheck >=2.8.1 && <3,+    --+    rerebase >=1.1 && <2
+ tests/Main.hs view
@@ -0,0 +1,155 @@+module Main 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.Vector as G+++main =+  defaultMain $+  testGroup "All tests" $+  [+    testProperty "list to list" $ \ (list :: [Int]) ->+    list === unsafePerformIO (C.produceAndConsume (E.list list) D.list)+    ,+    testProperty "consecutive consumers" $ \ (list :: [Int], amount) ->+    list === unsafePerformIO (C.produceAndConsume (E.list list) ((++) <$> D.transform (A.take amount) D.list <*> D.list))+    ,+    transform+  ]++transform =+  testGroup "Transform" $+  [+    transformChoice+    ,+    transformArrowLaws+  ]++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)