potoki-core 0.10 → 0.11
raw patch · 9 files changed
+285/−229 lines, 9 files
Files
- library/Potoki/Core/Consume.hs +38/−31
- library/Potoki/Core/Fetch.hs +102/−93
- library/Potoki/Core/IO.hs +24/−17
- library/Potoki/Core/Prelude.hs +2/−1
- library/Potoki/Core/Produce.hs +10/−7
- library/Potoki/Core/Transform.hs +77/−67
- library/Potoki/Core/Types.hs +2/−5
- potoki-core.cabal +1/−1
- tests/Main.hs +29/−7
library/Potoki/Core/Consume.hs view
@@ -17,44 +17,51 @@ instance Profunctor Consume where {-# INLINE dimap #-} dimap inputMapping outputMapping (Consume consume) =- Consume (\ fetch -> fmap outputMapping (consume (fmap inputMapping fetch)))+ Consume (\ fetch -> fmap outputMapping (consume $ fmap inputMapping fetch)) instance Choice Consume where+ right' :: Consume a b -> Consume (Either c a) (Either c b) 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)+ Consume $ \ (Fetch eitherFetchIO) -> do+ fetchedLeftMaybeRef <- newIORef Nothing+ consumedRight <-+ rightConsumeIO $ Fetch $ do+ eitherFetch <- eitherFetchIO+ case eitherFetch of+ Nothing -> return Nothing+ Just element -> case element of+ Right fetchedRight -> return $ Just fetchedRight+ Left fetchedLeft -> do+ writeIORef fetchedLeftMaybeRef $ Just fetchedLeft+ return Nothing+ 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+ pure x = Consume $ \ _ -> pure x Consume leftConsumeIO <*> Consume rightConsumeIO =- Consume $ \fetch -> leftConsumeIO fetch <*> rightConsumeIO fetch+ Consume $ \ fetch -> leftConsumeIO fetch <*> rightConsumeIO fetch instance Monad (Consume a) where- Consume leftConsumeIO >>= toRightConsumeIO = Consume $ \fetch -> do+ Consume leftConsumeIO >>= toRightConsumeIO = Consume $ \ fetch -> do Consume rightConsumeIO <- toRightConsumeIO <$> leftConsumeIO fetch rightConsumeIO fetch instance MonadIO (Consume a) where- liftIO a = Consume $ \_ -> a+ 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+ _ <- forkIO $ do !rightOutput <- rightConsumeIO rightFetch putMVar rightOutputVar rightOutput !leftOutput <- leftConsumeIO leftFetch@@ -65,27 +72,27 @@ list :: Consume input [input] list = Consume $ \ (Fetch fetchIO) ->- let- build !acc =- join- (fetchIO- (pure (acc []))- (\ !element -> build (acc . (:) element)))- in build id+ let + build !acc = do+ fetch <- fetchIO+ case fetch of+ Nothing -> pure $ acc []+ Just !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+ let+ build !acc = do+ fetch <- fetchIO+ case fetch of+ Nothing -> pure acc+ Just !element -> build $ element + acc+ in build 0 {-# INLINABLE transform #-} transform :: Transform input output -> Consume output sinkOutput -> Consume input sinkOutput transform (Transform transformAcquire) (Consume sink) =- Consume (\ fetch -> B.acquire (fmap ($ fetch) transformAcquire) sink)+ Consume $ \ fetch -> B.acquire (fmap ($ fetch) transformAcquire) sink
library/Potoki/Core/Fetch.hs view
@@ -10,7 +10,6 @@ rightCachingLeft, eitherFetchingRight, signaling,- ioMaybe, ioFetch, ) where@@ -23,26 +22,26 @@ 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)))))+ Fetch (pure (Just x))+ (<*>) (Fetch leftIO) (Fetch rightIO) =+ Fetch ((<*>) <$> leftIO <*> rightIO) 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)))+ (>>=) (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 (\ nil just -> pure nil)- (<|>) (Fetch leftSignal) (Fetch rightSignal) =- Fetch (\ nil just -> join (leftSignal (rightSignal nil just) (pure . just)))+ Fetch (pure Nothing)+ (<|>) (Fetch leftIO) (Fetch rightIO) =+ Fetch ((<|>) <$> leftIO <*> rightIO) instance MonadPlus Fetch where mzero =@@ -50,6 +49,10 @@ mplus = (<|>) +instance MonadIO Fetch where+ liftIO io =+ Fetch (fmap Just io)+ {-# INLINABLE duplicate #-} duplicate :: Fetch element -> IO (Fetch element, Fetch element) duplicate (Fetch fetchIO) =@@ -60,96 +63,102 @@ 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)))))+ Fetch $ do+ fetch <- fetchIO+ 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 $ case fetch of+ Nothing -> do+ atomically+ (do+ writeTVar notEndVar False+ writeTVar notFetchingVar True+ )+ return Nothing+ Just !element -> do+ atomically+ (do+ writeTQueue mirrorBuffer element+ writeTVar notFetchingVar True+ )+ return $ Just element+ else return $ return Nothing+ )+ ) leftFetch = newFetch leftBuffer rightBuffer rightFetch = newFetch rightBuffer leftBuffer- in return (leftFetch, rightFetch)+ 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+ Fetch $ do+ elemVal <- readIORef refElem+ case elemVal of+ Nothing -> return Nothing+ Just element -> do writeIORef refElem Nothing- return $ just e+ return $ Just element {-# INLINABLE list #-} list :: IORef [element] -> Fetch element list unsentListRef =- Fetch $ \nil just -> do+ Fetch $ do refList <- readIORef unsentListRef case refList of- (!head) : tail -> do- writeIORef unsentListRef tail- return $ just head+ (!headVal) : (!tailVal) -> do+ writeIORef unsentListRef tailVal+ return $ Just headVal _ -> do writeIORef unsentListRef []- return nil+ return Nothing {-# 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))+ Fetch $ do+ bothFetch <- bothFetchIO+ case bothFetch of+ Nothing -> return Nothing+ Just (!firstVal, !secondVal) -> do+ writeIORef cacheRef secondVal+ return $ Just firstVal {-# 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)))+ Fetch $ do+ firstFetch <- firstFetchIO+ case firstFetch of+ Nothing -> return Nothing+ Just !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+rightHandlingLeft left2IO (Fetch eitherFetchIO) =+ Fetch $ do+ eitherFetch <- eitherFetchIO+ case eitherFetch of+ Nothing -> return Nothing+ Just input -> case input of+ Right rightInput -> return $ Just rightInput+ Left leftInput -> left2IO leftInput $> Nothing {-# INLINABLE rightCachingLeft #-} rightCachingLeft :: IORef (Maybe left) -> Fetch (Either left right) -> Fetch right@@ -159,26 +168,26 @@ {-# 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))+ Fetch $ do+ rightFetch <- rightFetchIO+ case rightFetch of+ Nothing -> return Nothing+ Just r -> atomicModifyIORef' cacheRef $ \ case+ Nothing -> (Nothing, Just $ Right r)+ Just l -> (Nothing, Just $ Left l) {-# 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+signaling signalEnd signalElement (Fetch fetchIO) =+ Fetch $ do+ fetch <- fetchIO+ case fetch of+ Nothing -> signalEnd $> Nothing+ Just element -> signalElement >> return (Just element) {-# INLINABLE ioFetch #-} ioFetch :: IO (Fetch a) -> Fetch a-ioFetch io =- Fetch $ \ nil just -> do- Fetch fetchIO <- io- fetchIO nil just+ioFetch fetchIO =+ Fetch $ do+ Fetch fetch <- fetchIO+ fetch
library/Potoki/Core/IO.hs view
@@ -8,36 +8,43 @@ produceAndConsume :: Produce input -> Consume input output -> IO output-produceAndConsume (Produce produceManaged) (Consume consume) =- C.acquire produceManaged consume+produceAndConsume (Produce produceAcquire) (Consume consumeFunc) =+ C.acquire produceAcquire consumeFunc produceAndTransformAndConsume :: Produce input -> Transform input anotherInput -> Consume anotherInput output -> IO output-produceAndTransformAndConsume (Produce produceManaged) (Transform transformManaged) (Consume consume) =- C.acquire (($) <$> transformManaged <*> produceManaged) consume+produceAndTransformAndConsume (Produce produceAcquire) (Transform transformAcquire) (Consume consumeFunc) =+ C.acquire (($) <$> transformAcquire <*> produceAcquire) consumeFunc produce :: Produce input -> forall x. IO x -> (input -> IO x) -> IO x-produce (Produce produceManaged) stop emit =- C.acquire produceManaged $ \ (Fetch fetchIO) -> - fix (\ loop -> join (fetchIO stop (\ element -> emit element >> loop)))+produce (Produce produceAcquire) stop emit =+ C.acquire produceAcquire $ \ (Fetch fetchIO) ->+ fix $ \ doLoop -> do+ fetch <- fetchIO+ case fetch of+ Nothing -> stop+ Just element -> emit element >> doLoop -consume :: (forall x. x -> (input -> x) -> IO x) -> Consume input output -> IO output-consume fetch (Consume consume) =- consume (Fetch fetch)+consume :: IO (Maybe input) -> Consume input output -> IO output+consume fetchIO (Consume consumeFunc) =+ consumeFunc $ Fetch fetchIO {-| 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)))+ fix $ \ doLoop -> do+ fetch <- fetchIO+ case fetch of+ Nothing -> onEnd+ Just element -> onElement element >> doLoop {-| 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+ do+ fetch <- fetchIO+ case fetch of+ Nothing -> onEnd+ Just element -> onElement element transformList :: Transform a b -> [a] -> IO [b] transformList transform inputList =
library/Potoki/Core/Prelude.hs view
@@ -32,10 +32,11 @@ 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.Monoid as Exports hiding (Last(..), (<>), First(..)) import Data.Ord as Exports import Data.Proxy as Exports import Data.Ratio as Exports+import Data.Semigroup as Exports import Data.STRef as Exports import Data.String as Exports import Data.Traversable as Exports
library/Potoki/Core/Produce.hs view
@@ -9,7 +9,6 @@ import Potoki.Core.Prelude import Potoki.Core.Types import qualified Potoki.Core.Fetch as A-import qualified Acquire.IO as B deriving instance Functor Produce@@ -39,17 +38,21 @@ Produce (Acquire io2) -> A.ioFetch $ do join (readIORef release2Ref)- (fetch2, release2) <- io2- writeIORef release2Ref release2- return fetch2+ (fetch2', release2') <- io2+ writeIORef release2Ref release2'+ return fetch2' release3 = join (readIORef release2Ref) >> release1 in return (fetch1 >>= fetch2, release3) +instance MonadIO Produce where+ liftIO io =+ Produce (return (liftIO io))+ {-# INLINABLE list #-} list :: [input] -> Produce input-list list =- Produce (liftIO (A.list <$> newIORef list))+list inputList =+ Produce $ liftIO (A.list <$> newIORef inputList) {-# INLINE transform #-} transform :: Transform input output -> Produce input -> Produce output@@ -57,4 +60,4 @@ Produce $ do fetch <- produceAcquire newFetch <- transformAcquire- return (newFetch fetch)+ return $ newFetch fetch
library/Potoki/Core/Transform.hs view
@@ -12,48 +12,47 @@ 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)+ (.) (Transform leftVal) (Transform rightVal) =+ Transform ((.) <$> leftVal <*> rightVal) instance Profunctor Transform where- dimap inputMapping outputMapping (Transform managed) =+ dimap inputMapping outputMapping (Transform acquire) = Transform $ do- newFetch <- managed- return $ \ oldFetch -> fmap outputMapping (newFetch (fmap inputMapping oldFetch))+ newFetch <- acquire+ return $ \ oldFetch -> fmap outputMapping (newFetch $ fmap inputMapping oldFetch) instance Choice Transform where- right' (Transform rightTransformManaged) =+ right' :: Transform a b -> Transform (Either c a) (Either c b)+ right' (Transform rightTransformAcquire) = Transform $ do- rightInFetchToOutFetch <- rightTransformManaged- fetchedLeftMaybeRef <- liftIO (newIORef Nothing)+ rightInFetchToOutFetch <- rightTransformAcquire+ 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)))+ Fetch rightFetchIO = rightInFetchToOutFetch $ A.rightHandlingLeft (writeIORef fetchedLeftMaybeRef . Just) inFetch+ in Fetch $ do+ rightFetch <- rightFetchIO+ case rightFetch of+ Nothing -> do+ fetchedLeftMaybe <- readIORef fetchedLeftMaybeRef+ case fetchedLeftMaybe of+ Nothing -> return Nothing+ Just fetchedLeft -> do+ writeIORef fetchedLeftMaybeRef Nothing+ return $ Just (Left fetchedLeft)+ Just element -> return $ Just (Right element) instance Strong Transform where- first' (Transform firstTransformManaged) =+ first' (Transform firstTransformAcquire) = Transform $ do- cacheRef <- liftIO (newIORef undefined)- firstInFetchToOutFetch <- firstTransformManaged- return (A.bothFetchingFirst cacheRef . firstInFetchToOutFetch . A.firstCachingSecond cacheRef)+ cacheRef <- liftIO $ newIORef undefined+ firstInFetchToOutFetch <- firstTransformAcquire+ return $ A.bothFetchingFirst cacheRef . firstInFetchToOutFetch . A.firstCachingSecond cacheRef instance Arrow Transform where arr fn =@@ -69,55 +68,63 @@ consume :: Consume input output -> Transform input output consume (Consume runFetch) = Transform $ do- stoppedRef <- liftIO (newIORef False)- return $ \ (Fetch fetch) -> Fetch $ \ stop yield -> do+ stoppedRef <- liftIO $ newIORef False+ return $ \ (Fetch inputIO) -> Fetch $ do stopped <- readIORef stoppedRef if stopped then do writeIORef stoppedRef False- return stop+ return Nothing 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+ output <- runFetch $ Fetch $ do+ input <- inputIO+ case input of+ Nothing -> do+ writeIORef stoppedRef True+ return Nothing+ Just element -> do+ writeIORef emittedRef True+ return $ Just element+ checkStopped <- readIORef stoppedRef+ if checkStopped then do emitted <- readIORef emittedRef if emitted- then return (yield output)+ then return $ Just output else do writeIORef stoppedRef False- return stop- else return (yield output)+ return Nothing+ else return $ Just output {-# INLINABLE produce #-} produce :: (input -> Produce output) -> Transform input output produce inputToProduce = Transform $ do- stateRef <- liftIO (newIORef Nothing)- return $ \ (Fetch inputFetchIO) -> Fetch $ \ nil just -> fix $ \ loop -> do+ stateRef <- liftIO $ newIORef Nothing+ return $ \ (Fetch inputFetchIO) -> Fetch $ fix $ \ doLoop -> do state <- readIORef stateRef case state of Just (Fetch outputFetchIO, kill) ->- join $ outputFetchIO- (kill >> writeIORef stateRef Nothing >> loop)- (return . just)+ do+ outputFetchResult <- outputFetchIO+ case outputFetchResult of+ Just x -> return (Just x)+ Nothing -> do+ kill+ writeIORef stateRef Nothing+ doLoop Nothing ->- join $ inputFetchIO (return nil) $ \ !input -> do- case inputToProduce input of- Produce (Acquire produceIO) -> do- fetchAndKill <- produceIO- writeIORef stateRef (Just fetchAndKill)- loop+ do+ inputFetchResult <- inputFetchIO+ case inputFetchResult of+ Just input -> do+ case inputToProduce input of+ Produce (Acquire produceIO) -> do+ fetchAndKill <- produceIO+ writeIORef stateRef (Just fetchAndKill)+ doLoop+ Nothing -> return Nothing {-# INLINE mapFetch #-} mapFetch :: (Fetch a -> Fetch b) -> Transform a b@@ -130,18 +137,21 @@ {-# INLINE executeIO #-} executeIO :: Transform (IO a) a executeIO =- mapFetch $ \ (Fetch fetchIO) -> Fetch $ \ stop yield ->- join (fetchIO (return stop) (fmap yield))+ mapFetch $ \ (Fetch fetchIO) -> Fetch (fetchIO >>= sequence) {-# 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+take amount+ | amount <= 0 =+ Transform $ return $ \ _ -> Fetch $ return Nothing+ | otherwise =+ Transform $ do+ countRef <- liftIO $ newIORef amount+ return $ \ (Fetch fetchIO) -> Fetch $ do+ count <- readIORef countRef+ if count > 0+ then do+ modifyIORef countRef pred+ fetchIO+ else+ return Nothing
library/Potoki/Core/Types.hs view
@@ -5,13 +5,10 @@ {-|-Passive producer of elements with support for early termination.+Passive producer of elements. -} newtype Fetch element =- {-|- Something close to a Church encoding of @IO (Maybe element)@.- -}- Fetch (forall x. x -> (element -> x) -> IO x)+ Fetch (IO (Maybe element)) {-| Passive producer of elements with support for early termination
potoki-core.cabal view
@@ -1,7 +1,7 @@ name: potoki-core version:- 0.10+ 0.11 synopsis: Low-level components of "potoki" description:
tests/Main.hs view
@@ -38,13 +38,35 @@ ] transformProduce =- testCase "Produce" $ 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+ 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" $