diff --git a/iteratee.cabal b/iteratee.cabal --- a/iteratee.cabal +++ b/iteratee.cabal @@ -1,5 +1,5 @@ name: iteratee -version: 0.8.9.0 +version: 0.8.9.1 synopsis: Iteratee-based I/O description: The Iteratee monad provides strict, safe, and functional I/O. In addition @@ -12,7 +12,7 @@ license: BSD3 license-file: LICENSE homepage: http://www.tiresiaspress.us/haskell/iteratee -tested-with: GHC == 7.2.1, GHC == 7.4.2 +tested-with: GHC == 7.0.4, GHC == 7.2.1 stability: experimental cabal-version: >= 1.6 @@ -41,22 +41,21 @@ else cpp-options: -DUSE_POSIX exposed-modules: + Data.Iteratee.IO.Posix Data.Iteratee.IO.Fd build-depends: - unix >= 2 && < 3, - unix-bytestring >= 0.3.5 && < 0.4 + unix >= 2 && < 3 build-depends: base >= 3 && < 6, ListLike >= 1.0 && < 4, MonadCatchIO-transformers > 0.2 && < 0.4, + monad-control == 0.3.* , bytestring >= 0.9 && < 0.10, containers >= 0.2 && < 0.6, - lifted-base >= 0.1.1 && < 0.2, - monad-control >= 0.3 && < 0.4, parallel >= 2 && < 4, transformers >= 0.2 && < 0.4, - transformers-base >= 0.4 && < 0.5 + transformers-base >= 0.3 && < 0.5 exposed-modules: Data.Nullable diff --git a/src/Data/Iteratee.hs b/src/Data/Iteratee.hs --- a/src/Data/Iteratee.hs +++ b/src/Data/Iteratee.hs @@ -44,12 +44,18 @@ -} module Data.Iteratee ( - module I + module Data.Iteratee.Binary, + module Data.Iteratee.ListLike, + module Data.Iteratee.PTerm, + fileDriver, + fileDriverVBuf, + fileDriverRandom, + fileDriverRandomVBuf ) where -import Data.Iteratee.Binary as I -import Data.Iteratee.IO as I -import Data.Iteratee.ListLike as I -import Data.Iteratee.PTerm as I +import Data.Iteratee.Binary +import Data.Iteratee.IO +import Data.Iteratee.ListLike +import Data.Iteratee.PTerm diff --git a/src/Data/Iteratee/Base.hs b/src/Data/Iteratee/Base.hs --- a/src/Data/Iteratee/Base.hs +++ b/src/Data/Iteratee/Base.hs @@ -3,9 +3,8 @@ ,FlexibleContexts ,FlexibleInstances ,UndecidableInstances - ,RankNTypes + ,Rank2Types ,DeriveDataTypeable - ,ScopedTypeVariables ,ExistentialQuantification #-} -- |Monadic Iteratees: @@ -14,6 +13,7 @@ module Data.Iteratee.Base ( -- * Types Stream (..) + ,StreamStatus (..) -- ** Exception types ,module Data.Iteratee.Exception -- ** Iteratees @@ -22,17 +22,15 @@ -- ** Control functions ,run ,tryRun + ,mapIteratee ,ilift ,ifold -- ** Creating Iteratees ,idone ,icont - ,icontP - ,ierr - ,ireq ,liftI ,idoneM - ,ierrM + ,icontM -- ** Stream Functions ,setEOF -- * Classes @@ -49,13 +47,11 @@ import Data.Maybe import Data.Monoid -import Control.Arrow (first) import Control.Monad (liftM, join) import Control.Monad.Base import Control.Monad.IO.Class import Control.Monad.Trans.Class -import Control.Monad.CatchIO (MonadCatchIO (..), - catch, block) +import Control.Monad.CatchIO (MonadCatchIO (..), catch, block) import Control.Monad.Trans.Control import Control.Applicative hiding (empty) import Control.Exception (SomeException) @@ -94,6 +90,13 @@ fmap f (Chunk xs) = Chunk $ f xs fmap _ (EOF mErr) = EOF mErr +-- |Describe the status of a stream of data. +data StreamStatus = + DataRemaining + | EofNoError + | EofError SomeException + deriving (Show, Typeable) + -- ---------------------------------------------- -- create exception type hierarchy @@ -106,166 +109,114 @@ -- ---------------------------------------------- -- | Monadic iteratee newtype Iteratee s m a = Iteratee{ runIter :: forall r. - (a -> r) -> - ((Stream s -> m (Iteratee s m a, Stream s)) -> r) -> - (Iteratee s m a -> SomeException -> r) -> - (forall b. m b -> (b -> (Iteratee s m a)) -> r) -> - r} + (a -> Stream s -> m r) -> + ((Stream s -> Iteratee s m a) -> Maybe SomeException -> m r) -> + m r} -- ---------------------------------------------- -idone :: a -> Iteratee s m a -idone a = Iteratee $ \onDone _ _ _ -> onDone a -{-# INLINE idone #-} - -icont :: (Stream s -> m (Iteratee s m a, Stream s)) -> Iteratee s m a -icont k = Iteratee $ \_ onCont _ _ -> onCont k -{-# INLINE icont #-} - -icontP :: Monad m => (Stream s -> (Iteratee s m a, Stream s)) -> Iteratee s m a -icontP k = Iteratee $ \_ onCont _ _ -> onCont (return . k) -{-# INLINE icontP #-} - --- | identical to icont, left in for compatibility-ish reasons -liftI :: Monad m => (Stream s -> (Iteratee s m a, Stream s)) -> Iteratee s m a -liftI = icontP -{-# INLINE liftI #-} +idone :: a -> Stream s -> Iteratee s m a +idone a s = Iteratee $ \onDone _ -> onDone a s -ierr :: Iteratee s m a -> SomeException -> Iteratee s m a -ierr i e = Iteratee $ \_ _ onErr _ -> onErr i e -{-# INLINE ierr #-} +icont :: (Stream s -> Iteratee s m a) -> Maybe SomeException -> Iteratee s m a +icont k e = Iteratee $ \_ onCont -> onCont k e -ireq :: m b -> (b -> Iteratee s m a) -> Iteratee s m a -ireq mb bf = Iteratee $ \_ _ _ onReq -> onReq mb bf -{-# INLINE ireq #-} +liftI :: (Stream s -> Iteratee s m a) -> Iteratee s m a +liftI k = Iteratee $ \_ onCont -> onCont k Nothing -- Monadic versions, frequently used by enumerators -idoneM :: Monad m => a -> m (Iteratee s m a) -idoneM x = return $ idone x +idoneM :: Monad m => a -> Stream s -> m (Iteratee s m a) +idoneM x str = return $ Iteratee $ \onDone _ -> onDone x str -ierrM :: Monad m => Iteratee s m a -> SomeException -> m (Iteratee s m a) -ierrM i e = return $ ierr i e +icontM + :: Monad m => + (Stream s -> Iteratee s m a) + -> Maybe SomeException + -> m (Iteratee s m a) +icontM k e = return $ Iteratee $ \_ onCont -> onCont k e -instance forall s m. (Functor m) => Functor (Iteratee s m) where - {-# INLINE fmap #-} - fmap f m = runIter m (idone . f) onCont onErr (onReq f) - where - onCont k = icont $ fmap (first (fmap f)) . k - onErr i e = ierr (fmap f i) e - onReq :: (a -> b) -> m x -> (x -> Iteratee s m a) -> Iteratee s m b - onReq ff mb doB = ireq mb (fmap ff . doB) +instance (Functor m) => Functor (Iteratee s m) where + fmap f m = Iteratee $ \onDone onCont -> + let od = onDone . f + oc = onCont . (fmap f .) + in runIter m od oc -instance (Functor m, Monad m) => Applicative (Iteratee s m) where - pure x = idone x +instance (Functor m, Monad m, Nullable s) => Applicative (Iteratee s m) where + pure x = idone x (Chunk empty) {-# INLINE (<*>) #-} m <*> a = m >>= flip fmap a -instance (Monad m) => Monad (Iteratee s m) where +instance (Monad m, Nullable s) => Monad (Iteratee s m) where {-# INLINE return #-} - return = idone + return x = Iteratee $ \onDone _ -> onDone x (Chunk empty) {-# INLINE (>>=) #-} - (>>=) = bindIter + (>>=) = bindIteratee -{-# INLINE bindIter #-} -bindIter :: forall s m a b. (Monad m) +{-# INLINE bindIteratee #-} +bindIteratee :: (Monad m, Nullable s) => Iteratee s m a -> (a -> Iteratee s m b) -> Iteratee s m b -bindIter m f = runIter m f onCont onErr onReq - where - push i str = runIter i - (\a -> return (idone a, str)) - (\k -> k str) - (\iResume e -> return (ierr iResume e, EOF (Just e))) - (\mb doB -> mb >>= \b -> push (doB b) str) - onCont k = icont $ \str -> do - (i', strRem) <- k str - let oD a = push (f a) strRem - oC _k = return (i' `bindIter` f, strRem) - oE iResume e = return (ierr (bindIter iResume f) e - ,EOF (Just e)) - oR :: m x -> (x -> Iteratee s m a) -> m (Iteratee s m b, Stream s) - oR mb doB = mb >>= \b -> - push (doB b `bindIter` f) strRem - runIter i' oD oC oE oR - onErr i e = ierr (i >>= f) e - onReq :: m x -> (x -> Iteratee s m a) -> Iteratee s m b - onReq mb doB = ireq mb (( `bindIter` f) . doB) +bindIteratee = self + where + self m f = Iteratee $ \onDone onCont -> + let m_done a (Chunk s) + | nullC s = runIter (f a) onDone onCont + m_done a stream = runIter (f a) (const . flip onDone stream) f_cont + where f_cont k Nothing = runIter (k stream) onDone onCont + f_cont k e = onCont k e + in runIter m m_done (onCont . (flip self f .)) -instance MonadTrans (Iteratee s) where - lift = flip ireq idone +instance NullPoint s => MonadTrans (Iteratee s) where + lift m = Iteratee $ \onDone _ -> m >>= flip onDone (Chunk empty) -instance (MonadBase b m) => MonadBase b (Iteratee s m) where +instance (MonadBase b m, Nullable s, NullPoint s) => MonadBase b (Iteratee s m) where liftBase = lift . liftBase -instance (MonadIO m) => MonadIO (Iteratee s m) where +instance (MonadIO m, Nullable s, NullPoint s) => MonadIO (Iteratee s m) where liftIO = lift . liftIO -instance forall s m. (MonadCatchIO m) => +instance (MonadCatchIO m, Nullable s, NullPoint s) => MonadCatchIO (Iteratee s m) where - m `catch` f = let oC k = icont $ \s -> k s `catch` - (\e -> return (f e - , EOF . Just $ toException e)) - oE i' e = ierr (i' `catch` f) e - in runIter m idone oC oE (catchOR m f) + m `catch` f = Iteratee $ \od oc -> runIter m od oc `catch` (\e -> runIter (f e) od oc) block = ilift block unblock = ilift unblock --- This definition is pulled out from the MonadCatchIO.catch instance because --- it's the simplest way to make the type signatures work out... -catchOR :: (Exception e, MonadCatchIO m) => Iteratee s m a -> (e -> Iteratee s m a) -> m b -> (b -> Iteratee s m a) -> Iteratee s m a -catchOR _ f mb doB = ireq ((doB `liftM` mb) `catch` (\e -> return (f e) )) id - instance forall s. (NullPoint s, Nullable s) => MonadTransControl (Iteratee s) where newtype StT (Iteratee s) x = - StIter { unStIter :: Either x (Maybe SomeException) } - liftWith f = lift $ f $ \t -> liftM StIter (runIter t - (return . Left) - (const . return $ Right Nothing) - (\_ e -> return $ Right (Just e)) - (\mb doB -> pushoR mb doB)) + StIter { unStIter :: Either (x, Stream s) (Maybe SomeException) } + liftWith f = lift $ f $ \t -> liftM StIter + (runIter t (\x s -> return $ Left (x,s)) + (\_ e -> return $ Right e) ) restoreT = join . lift . liftM - (either idone + (either (uncurry idone) (te . fromMaybe (iterStrExc "iteratee: error in MonadTransControl instance")) . unStIter ) {-# INLINE liftWith #-} {-# INLINE restoreT #-} -pushoR :: Monad m => - m x - -> (x -> Iteratee s m a) - -> m (Either a (Maybe SomeException)) -pushoR mb doB = mb >>= \b -> runIter (doB b) - (return . Left) - (const . return $ Right Nothing) - (\_ e -> return $ Right (Just e)) - pushoR - -te :: SomeException -> Iteratee s m a -te e = ierr (te e) e - instance (MonadBaseControl b m, Nullable s) => MonadBaseControl b (Iteratee s m) where newtype StM (Iteratee s m) a = StMIter { unStMIter :: ComposeSt (Iteratee s) m a} liftBaseWith = defaultLiftBaseWith StMIter restoreM = defaultRestoreM unStMIter +te :: SomeException -> Iteratee s m a +te e = icont (const (te e)) (Just e) + -- |Send 'EOF' to the @Iteratee@ and disregard the unconsumed part of the -- stream. If the iteratee is in an exception state, that exception is -- thrown with 'Control.Exception.throw'. Iteratees that do not terminate -- on @EOF@ will throw 'EofException'. -run :: forall s m a. Monad m => Iteratee s m a -> m a -run iter = runIter iter onDone onCont onErr onReq +run :: Monad m => Iteratee s m a -> m a +run iter = runIter iter onDone onCont where - onDone x = return x - onCont k = k (EOF Nothing) >>= \(i,_) -> - runIter i onDone onCont' onErr onReq - onCont' _ = E.throw EofException - onErr _ e = E.throw e - onReq :: m x -> (x -> Iteratee s m a) -> m a - onReq mb doB = mb >>= run . doB -{-# INLINE run #-} + onDone x _ = return x + onCont k Nothing = runIter (k (EOF Nothing)) onDone onCont' + onCont _ (Just e) = E.throw e + onCont' _ Nothing = E.throw EofException + onCont' _ (Just e) = E.throw e -- |Run an iteratee, returning either the result or the iteratee exception. -- Note that only internal iteratee exceptions will be returned; exceptions @@ -273,19 +224,24 @@ -- not be returned. -- -- See 'Data.Iteratee.Exception.IFException' for details. -tryRun :: forall s m a e. (Exception e, Monad m) - => Iteratee s m a - -> m (Either e a) -tryRun iter = runIter iter onD onC onE onR +tryRun :: (Exception e, Monad m) => Iteratee s m a -> m (Either e a) +tryRun iter = runIter iter onDone onCont where - onD x = return $ Right x - onC k = k (EOF Nothing) >>= \(i,_) -> runIter i onD onC' onE onR - onC' _ = return $ maybeExc (toException EofException) - onE _ e = return $ maybeExc e - onR :: m x -> (x -> Iteratee s m a) -> m (Either e a) - onR mb doB = mb >>= tryRun . doB + onDone x _ = return $ Right x + onCont k Nothing = runIter (k (EOF Nothing)) onDone onCont' + onCont _ (Just e) = return $ maybeExc e + onCont' _ Nothing = return $ maybeExc (toException EofException) + onCont' _ (Just e) = return $ maybeExc e maybeExc e = maybe (Left (E.throw e)) Left (fromException e) +-- |Transform a computation inside an @Iteratee@. +mapIteratee :: (NullPoint s, Monad n, Monad m) => + (m a -> n b) + -> Iteratee s m a + -> Iteratee s n b +mapIteratee f = lift . f . run +{-# DEPRECATED mapIteratee "This function will be removed, compare to 'ilift'" #-} + -- | Lift a computation in the inner monad of an iteratee. -- -- A simple use would be to lift a logger iteratee to a monad stack. @@ -298,31 +254,22 @@ -- -- A more complex example would involve lifting an iteratee to work with -- interleaved streams. See the example at 'Data.Iteratee.ListLike.merge'. -ilift :: forall m n s a. +ilift :: (Monad m, Monad n) => (forall r. m r -> n r) -> Iteratee s m a -> Iteratee s n a -ilift f i = runIter i idone onCont onErr onReq - where - onCont k = icont $ \str -> first (ilift f) `liftM` f (k str) - onErr = ierr . ilift f - onReq :: m x -> (x -> Iteratee s m a) -> Iteratee s n a - onReq mb doB = ireq (liftM (ilift f . doB) (f mb)) id +ilift f i = Iteratee $ \od oc -> + let onDone a str = return $ Left (a,str) + onCont k mErr = return $ Right (ilift f . k, mErr) + in f (runIter i onDone onCont) >>= either (uncurry od) (uncurry oc) -- | Lift a computation in the inner monad of an iteratee, while threading -- through an accumulator. -ifold :: forall m n acc s a. (Monad m, Monad n) - => (forall r. m r -> acc -> n (r, acc)) - -> acc - -> Iteratee s m a - -> Iteratee s n (a, acc) -ifold f acc i = runIter i onDone onCont onErr onReq - where - onDone x = ireq (f (return x) acc) idone - onCont k = icont $ \str -> do - ((i', strRes), acc') <- f (k str) acc - return (ifold f acc' i', strRes) - onErr i' e = ierr (ifold f acc i') e - onReq :: m x -> (x -> Iteratee s m a) -> Iteratee s n (a, acc) - onReq mb doB = ireq (f mb acc) (\(b', acc') -> ifold f acc' (doB b')) +ifold :: (Monad m, Monad n) => (forall r. m r -> acc -> n (r, acc)) + -> acc -> Iteratee s m a -> Iteratee s n (a, acc) +ifold f acc i = Iteratee $ \ od oc -> do + (r, acc') <- flip f acc $ + runIter i (curry $ return . Left) (curry $ return . Right) + either (uncurry (od . flip (,) acc')) + (uncurry (oc . (ifold f acc .))) r diff --git a/src/Data/Iteratee/Binary.hs b/src/Data/Iteratee/Binary.hs --- a/src/Data/Iteratee/Binary.hs +++ b/src/Data/Iteratee/Binary.hs @@ -14,12 +14,23 @@ ,endianRead3i ,endianRead4 ,endianRead8 + -- ** bytestring specializations + -- | In current versions of @iteratee@ there is no difference between the + -- bytestring specializations and polymorphic functions. They exist + -- for compatibility. + ,readWord16be_bs + ,readWord16le_bs + ,readWord32be_bs + ,readWord32le_bs + ,readWord64be_bs + ,readWord64le_bs ) where import Data.Iteratee.Base import qualified Data.Iteratee.ListLike as I import qualified Data.ListLike as LL +import qualified Data.ByteString as B import Data.Word import Data.Bits import Data.Int @@ -92,37 +103,58 @@ -> Int -> ([Word8] -> b) -> Iteratee s m b -endianReadN MSB n0 cnct = icontP (step n0 []) +endianReadN MSB n0 cnct = liftI (step n0 []) where step !n acc (Chunk c) - | LL.null c = (icontP (step n acc), Chunk c) + | LL.null c = liftI (step n acc) | LL.length c >= n = let (this,next) = LL.splitAt n c !result = cnct $ acc ++ LL.toList this - in (idone result, Chunk next) - | otherwise = (icontP (step (n - LL.length c) (acc ++ LL.toList c)) - , Chunk empty) - step !n acc (EOF Nothing ) = (icontP (step n acc) - , EOF . Just $ toException EofException) - step !n acc s@(EOF (Just _)) = (icontP (step n acc), s) -endianReadN LSB n0 cnct = icontP (step n0 []) + in idone result (Chunk next) + | otherwise = liftI (step (n - LL.length c) (acc ++ LL.toList c)) + step !n acc (EOF Nothing) = icont (step n acc) (Just $ toException EofException) + step !n acc (EOF (Just e)) = icont (step n acc) (Just e) +endianReadN LSB n0 cnct = liftI (step n0 []) where step !n acc (Chunk c) - | LL.null c = (icontP (step n acc), Chunk c) + | LL.null c = liftI (step n acc) | LL.length c >= n = let (this,next) = LL.splitAt n c !result = cnct $ reverse (LL.toList this) ++ acc - in (idone result, Chunk next) - | otherwise = (icontP (step (n - LL.length c) - (reverse (LL.toList c) ++ acc)) - , Chunk empty) - step !n acc (EOF Nothing) = (icontP (step n acc) - , EOF . Just $ toException EofException) - step !n acc str = (icontP (step n acc), str) + in idone result (Chunk next) + | otherwise = liftI (step (n - LL.length c) + (reverse (LL.toList c) ++ acc)) + step !n acc (EOF Nothing) = icont (step n acc) + (Just $ toException EofException) + step !n acc (EOF (Just e)) = icont (step n acc) (Just e) {-# INLINE endianReadN #-} -- As of now, the polymorphic code is as fast as the best specializations -- I have found, so these just call out. They may be improved in the -- future, or possibly deprecated. -- JWL, 2012-01-16 + +readWord16be_bs :: Monad m => Iteratee B.ByteString m Word16 +readWord16be_bs = endianRead2 MSB +{-# INLINE readWord16be_bs #-} + +readWord16le_bs :: Monad m => Iteratee B.ByteString m Word16 +readWord16le_bs = endianRead2 LSB +{-# INLINE readWord16le_bs #-} + +readWord32be_bs :: Monad m => Iteratee B.ByteString m Word32 +readWord32be_bs = endianRead4 MSB +{-# INLINE readWord32be_bs #-} + +readWord32le_bs :: Monad m => Iteratee B.ByteString m Word32 +readWord32le_bs = endianRead4 LSB +{-# INLINE readWord32le_bs #-} + +readWord64be_bs :: Monad m => Iteratee B.ByteString m Word64 +readWord64be_bs = endianRead8 MSB +{-# INLINE readWord64be_bs #-} + +readWord64le_bs :: Monad m => Iteratee B.ByteString m Word64 +readWord64le_bs = endianRead8 LSB +{-# INLINE readWord64le_bs #-} word16' :: [Word8] -> Word16 word16' [c1,c2] = word16 c1 c2 diff --git a/src/Data/Iteratee/Char.hs b/src/Data/Iteratee/Char.hs --- a/src/Data/Iteratee/Char.hs +++ b/src/Data/Iteratee/Char.hs @@ -78,21 +78,21 @@ Enumeratee s [s] m a enumLines = convStream getter where - getter = icontP step + getter = icont step Nothing lChar = (== '\n') . last . LL.toString step (Chunk xs) - | LL.null xs = (getter, Chunk xs) - | lChar xs = (idone (LL.lines xs), mempty) - | otherwise = (icontP (step' xs), mempty) - step str = (getter, str) + | LL.null xs = getter + | lChar xs = idone (LL.lines xs) mempty + | otherwise = icont (step' xs) Nothing + step _str = getter step' xs (Chunk ys) - | LL.null ys = (icontP (step' xs), Chunk ys) - | lChar ys = (idone (LL.lines . mappend xs $ ys), mempty) + | LL.null ys = icont (step' xs) Nothing + | lChar ys = idone (LL.lines . mappend xs $ ys) mempty | otherwise = let w' = LL.lines $ mappend xs ys ws = init w' ck = last w' - in (idone ws, Chunk ck) - step' xs str = (idone (LL.lines xs), str) + in idone ws (Chunk ck) + step' xs str = idone (LL.lines xs) str -- |Convert the stream of characters to the stream of words, and -- apply the given iteratee to enumerate the latter. @@ -109,21 +109,21 @@ :: (Monad m) => Enumeratee BC.ByteString [BC.ByteString] m a enumWordsBS iter = convStream getter iter where - getter = icontP step + getter = liftI step lChar = isSpace . BC.last step (Chunk xs) - | BC.null xs = (getter, mempty) - | lChar xs = (idone (BC.words xs), Chunk BC.empty) - | otherwise = (icontP (step' xs), mempty) - step str = (idone mempty, str) + | BC.null xs = getter + | lChar xs = idone (BC.words xs) (Chunk BC.empty) + | otherwise = icont (step' xs) Nothing + step str = idone mempty str step' xs (Chunk ys) - | BC.null ys = (icontP (step' xs), mempty) - | lChar ys = (idone (BC.words . BC.append xs $ ys), mempty) + | BC.null ys = icont (step' xs) Nothing + | lChar ys = idone (BC.words . BC.append xs $ ys) mempty | otherwise = let w' = BC.words . BC.append xs $ ys ws = init w' ck = last w' - in (idone ws, Chunk ck) - step' xs str = (idone (BC.words xs), str) + in idone ws (Chunk ck) + step' xs str = idone (BC.words xs) str {-# INLINE enumWordsBS #-} @@ -133,19 +133,19 @@ enumLinesBS :: (Monad m) => Enumeratee BC.ByteString [BC.ByteString] m a enumLinesBS = convStream getter where - getter = icontP step + getter = icont step Nothing lChar = (== '\n') . BC.last step (Chunk xs) - | BC.null xs = (getter, Chunk xs) - | lChar xs = (idone (BC.lines xs), Chunk BC.empty) - | otherwise = (icontP (step' xs), mempty) - step str = (idone mempty, str) + | BC.null xs = getter + | lChar xs = idone (BC.lines xs) (Chunk BC.empty) + | otherwise = icont (step' xs) Nothing + step str = idone mempty str step' xs (Chunk ys) - | BC.null ys = (icontP (step' xs), mempty) - | lChar ys = (idone (BC.lines . BC.append xs $ ys), mempty) + | BC.null ys = icont (step' xs) Nothing + | lChar ys = idone (BC.lines . BC.append xs $ ys) mempty | otherwise = let w' = BC.lines $ BC.append xs ys ws = init w' ck = last w' - in (idone ws, Chunk ck) - step' xs str = (idone (BC.lines xs), str) + in idone ws (Chunk ck) + step' xs str = idone (BC.lines xs) str diff --git a/src/Data/Iteratee/IO.hs b/src/Data/Iteratee/IO.hs --- a/src/Data/Iteratee/IO.hs +++ b/src/Data/Iteratee/IO.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} +{-# LANGUAGE CPP #-} -- |Random and Binary IO with generic Iteratees. @@ -37,8 +37,7 @@ import qualified Data.Iteratee.IO.Fd as FD #endif -import Control.Monad.Trans.Control -import Control.Monad.IO.Class +import Control.Monad.CatchIO -- | The default buffer size. defaultBufSize :: Int @@ -48,14 +47,14 @@ #if defined(USE_POSIX) enumFile - :: (MonadIO m, MonadBaseControl IO m, NullPoint s, ReadableChunk s el) => + :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Int -> FilePath -> Enumerator s m a enumFile = FD.enumFile enumFileRandom - :: (MonadIO m, MonadBaseControl IO m, NullPoint s, ReadableChunk s el) => + :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Int -> FilePath -> Enumerator s m a @@ -64,7 +63,7 @@ -- |Process a file using the given Iteratee. This function wraps -- enumFd as a convenience. fileDriver - :: (MonadIO m, MonadBaseControl IO m, NullPoint s, ReadableChunk s el) => + :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Iteratee s m a -> FilePath -> m a @@ -72,7 +71,7 @@ -- |A version of fileDriver with a user-specified buffer size (in elements). fileDriverVBuf - :: (MonadIO m, MonadBaseControl IO m, NullPoint s, ReadableChunk s el) => + :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Int -> Iteratee s m a -> FilePath @@ -82,14 +81,14 @@ -- |Process a file using the given Iteratee. This function wraps -- enumFdRandom as a convenience. fileDriverRandom - :: (MonadIO m, MonadBaseControl IO m, NullPoint s, ReadableChunk s el) => + :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Iteratee s m a -> FilePath -> m a fileDriverRandom = FD.fileDriverRandomFd defaultBufSize fileDriverRandomVBuf - :: (MonadIO m, MonadBaseControl IO m, NullPoint s, ReadableChunk s el) => + :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Int -> Iteratee s m a -> FilePath @@ -104,7 +103,7 @@ -- |Process a file using the given Iteratee. This function wraps -- @enumHandle@ as a convenience. fileDriver :: - (MonadIO m, MonadBaseControl IO m, NullPoint s, ReadableChunk s el) => + (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Iteratee s m a -> FilePath -> m a @@ -112,7 +111,7 @@ -- |A version of fileDriver with a user-specified buffer size (in elements). fileDriverVBuf :: - (MonadIO m, MonadBaseControl IO m, NullPoint s, ReadableChunk s el) => + (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Int -> Iteratee s m a -> FilePath @@ -122,14 +121,14 @@ -- |Process a file using the given Iteratee. This function wraps -- @enumRandomHandle@ as a convenience. fileDriverRandom - :: (MonadIO m, MonadBaseControl IO m, NullPoint s, ReadableChunk s el) => + :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Iteratee s m a -> FilePath -> m a fileDriverRandom = H.fileDriverRandomHandle defaultBufSize fileDriverRandomVBuf - :: (MonadIO m, MonadBaseControl IO m, NullPoint s, ReadableChunk s el) => + :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Int -> Iteratee s m a -> FilePath @@ -137,14 +136,14 @@ fileDriverRandomVBuf = H.fileDriverRandomHandle enumFile - :: (MonadIO m, MonadBaseControl IO m, NullPoint s, ReadableChunk s el) => + :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Int -> FilePath -> Enumerator s m a enumFile = H.enumFile enumFileRandom - :: (MonadIO m, MonadBaseControl IO m, NullPoint s, ReadableChunk s el) => + :: (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Int -> FilePath -> Enumerator s m a diff --git a/src/Data/Iteratee/IO/Base.hs b/src/Data/Iteratee/IO/Base.hs --- a/src/Data/Iteratee/IO/Base.hs +++ b/src/Data/Iteratee/IO/Base.hs @@ -5,7 +5,7 @@ module Data.Iteratee.IO.Windows, #endif #if defined(USE_POSIX) - module System.Posix, + module Data.Iteratee.IO.Posix, #else FileOffset #endif @@ -19,7 +19,7 @@ -- Provide the FileOffset type, which is available in Posix modules -- and maybe Windows #if defined(USE_POSIX) -import System.Posix +import Data.Iteratee.IO.Posix #else type FileOffset = Integer #endif diff --git a/src/Data/Iteratee/IO/Fd.hs b/src/Data/Iteratee/IO/Fd.hs --- a/src/Data/Iteratee/IO/Fd.hs +++ b/src/Data/Iteratee/IO/Fd.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE CPP - , PackageImports - , ScopedTypeVariables - , FlexibleContexts #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} -- |Random and Binary IO with generic Iteratees, using File Descriptors for IO. -- when available, these are the preferred functions for performing IO as they @@ -31,19 +28,18 @@ import Data.Iteratee.IO.Base import Control.Concurrent (yield) +import Control.Exception import Control.Monad -import Control.Monad.Trans.Control -import Control.Exception.Lifted +import Control.Monad.CatchIO as CIO import Control.Monad.IO.Class -import Foreign.C.Error import Foreign.Ptr import Foreign.Storable import Foreign.Marshal.Alloc import System.IO (SeekMode(..)) -import "unix-bytestring" System.Posix.IO.ByteString +import System.Posix hiding (FileOffset) -- ------------------------------------------------------------------------ -- Binary Random IO enumerators @@ -53,50 +49,48 @@ Ptr el -> ByteCount -> Fd - -> Callback st m s + -> st + -> m (Either SomeException ((Bool, st), s)) makefdCallback p bufsize fd st = do - n <- liftIO $ tryFdReadBuf fd (castPtr p) bufsize + n <- liftIO $ myfdRead fd (castPtr p) bufsize case n of - Left (Errno err) -> return $ Left (error $ "read failed: " ++ show err) - Right 0 -> liftIO yield >> return (Right ((Finished, st), empty)) - Right n' -> liftM (\s -> Right ((HasMore, st), s)) $ - readFromPtr p (fromIntegral n') -{-# INLINABLE makefdCallback #-} + Left _ -> return $ Left (error "myfdRead failed") + Right 0 -> liftIO yield >> return (Right ((False, st), empty)) + Right n' -> liftM (\s -> Right ((True, st), s)) $ + readFromPtr p (fromIntegral n') -- |The enumerator of a POSIX File Descriptor. This version enumerates -- over the entire contents of a file, in order, unless stopped by -- the iteratee. In particular, seeking is not supported. enumFd - :: forall s el m a.(NullPoint s, ReadableChunk s el, MonadIO m, MonadBaseControl IO m) => + :: forall s el m a.(NullPoint s, ReadableChunk s el, MonadCatchIO m) => Int -> Fd -> Enumerator s m a enumFd bs fd iter = let bufsize = bs * (sizeOf (undefined :: el)) - in bracket (liftIO $ mallocBytes bufsize) - (liftIO . free) - (\p -> enumFromCallback (makefdCallback p (fromIntegral bufsize) fd) () iter) -{-# INLINABLE enumFd #-} + in CIO.bracket (liftIO $ mallocBytes bufsize) + (liftIO . free) + (\p -> enumFromCallback (makefdCallback p (fromIntegral bufsize) fd) () iter) -- |A variant of enumFd that catches exceptions raised by the @Iteratee@. enumFdCatch - :: forall e s el m a.(IException e, NullPoint s, ReadableChunk s el, MonadIO m, MonadBaseControl IO m) + :: forall e s el m a.(IException e, NullPoint s, ReadableChunk s el, MonadCatchIO m) => Int -> Fd -> (e -> m (Maybe EnumException)) -> Enumerator s m a enumFdCatch bs fd handler iter = let bufsize = bs * (sizeOf (undefined :: el)) - in bracket (liftIO $ mallocBytes bufsize) - (liftIO . free) - (\p -> enumFromCallbackCatch (makefdCallback p (fromIntegral bufsize) fd) handler () iter) -{-# INLINABLE enumFdCatch #-} + in CIO.bracket (liftIO $ mallocBytes bufsize) + (liftIO . free) + (\p -> enumFromCallbackCatch (makefdCallback p (fromIntegral bufsize) fd) handler () iter) -- |The enumerator of a POSIX File Descriptor: a variation of @enumFd@ that -- supports RandomIO (seek requests). enumFdRandom - :: forall s el m a.(NullPoint s, ReadableChunk s el, MonadIO m, MonadBaseControl IO m) => + :: forall s el m a.(NullPoint s, ReadableChunk s el, MonadCatchIO m) => Int -> Fd -> Enumerator s m a @@ -106,68 +100,61 @@ liftM (either (const . Just $ enStrExc "Error seeking within file descriptor") (const Nothing)) - . liftIO . tryFdSeek fd AbsoluteSeek $ fromIntegral off -{-# INLINABLE enumFdRandom #-} + . liftIO . myfdSeek fd AbsoluteSeek $ fromIntegral off fileDriver - :: (MonadIO m, MonadBaseControl IO m, ReadableChunk s el) => + :: (MonadCatchIO m, ReadableChunk s el) => (Int -> Fd -> Enumerator s m a) -> Int -> Iteratee s m a -> FilePath -> m a -fileDriver enumf bufsize iter filepath = bracket +fileDriver enumf bufsize iter filepath = CIO.bracket (liftIO $ openFd filepath ReadOnly Nothing defaultFileFlags) (liftIO . closeFd) (run <=< flip (enumf bufsize) iter) -{-# INLINABLE fileDriver #-} -- |Process a file using the given @Iteratee@. fileDriverFd - :: (NullPoint s, MonadIO m, MonadBaseControl IO m, ReadableChunk s el) => + :: (NullPoint s, MonadCatchIO m, ReadableChunk s el) => Int -- ^Buffer size (number of elements) -> Iteratee s m a -> FilePath -> m a fileDriverFd = fileDriver enumFd -{-# INLINABLE fileDriverFd #-} -- |A version of fileDriverFd that supports seeking. fileDriverRandomFd - :: (NullPoint s, MonadIO m, MonadBaseControl IO m, ReadableChunk s el) => + :: (NullPoint s, MonadCatchIO m, ReadableChunk s el) => Int -> Iteratee s m a -> FilePath -> m a fileDriverRandomFd = fileDriver enumFdRandom -{-# INLINABLE fileDriverRandomFd #-} -enumFile' :: (NullPoint s, MonadIO m, MonadBaseControl IO m, ReadableChunk s el) => +enumFile' :: (NullPoint s, MonadCatchIO m, ReadableChunk s el) => (Int -> Fd -> Enumerator s m a) -> Int -- ^Buffer size -> FilePath -> Enumerator s m a -enumFile' enumf bufsize filepath iter = bracket +enumFile' enumf bufsize filepath iter = CIO.bracket (liftIO $ openFd filepath ReadOnly Nothing defaultFileFlags) (liftIO . closeFd) (flip (enumf bufsize) iter) -{-# INLINABLE enumFile' #-} enumFile :: - (NullPoint s, MonadIO m, MonadBaseControl IO m, ReadableChunk s el) + (NullPoint s, MonadCatchIO m, ReadableChunk s el) => Int -- ^Buffer size -> FilePath -> Enumerator s m a enumFile = enumFile' enumFd -{-# INLINABLE enumFile #-} enumFileRandom :: - (NullPoint s, MonadIO m, MonadBaseControl IO m, ReadableChunk s el) + (NullPoint s, MonadCatchIO m, ReadableChunk s el) => Int -- ^Buffer size -> FilePath -> Enumerator s m a enumFileRandom = enumFile' enumFdRandom -{-# INLINABLE enumFileRandom #-} #endif diff --git a/src/Data/Iteratee/IO/Handle.hs b/src/Data/Iteratee/IO/Handle.hs --- a/src/Data/Iteratee/IO/Handle.hs +++ b/src/Data/Iteratee/IO/Handle.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} -- |Random and Binary IO with generic Iteratees. These functions use Handles -- for IO operations, and are provided for compatibility. When available, @@ -23,10 +23,9 @@ import Data.Iteratee.Iteratee import Data.Iteratee.Binary() -import Control.Applicative ((<$>)) +import Control.Exception import Control.Monad -import Control.Monad.Trans.Control -import Control.Exception.Lifted +import Control.Monad.CatchIO as CIO import Control.Monad.IO.Class import Foreign.Ptr @@ -39,18 +38,19 @@ -- ------------------------------------------------------------------------ -- Binary Random IO enumerators -makeHandleCallback :: forall st m s el. - (MonadBaseControl IO m, MonadIO m, NullPoint s, ReadableChunk s el) => +makeHandleCallback :: + (MonadCatchIO m, NullPoint s, ReadableChunk s el) => Ptr el -> Int -> Handle - -> Callback st m s + -> st + -> m (Either SomeException ((Bool, st), s)) makeHandleCallback p bsize h st = do - n' <- (try $ liftIO $ hGetBuf h p bsize) :: m (Either SomeException Int) + n' <- liftIO (CIO.try $ hGetBuf h p bsize :: IO (Either SomeException Int)) case n' of Left e -> return $ Left e - Right 0 -> return $ Right ((Finished, st), empty) - Right n -> liftIO $ (\s -> Right ((HasMore, st), s)) <$> + Right 0 -> return $ Right ((False, st), empty) + Right n -> liftM (\s -> Right ((True, st), s)) $ readFromPtr p (fromIntegral n) @@ -58,33 +58,32 @@ -- over the entire contents of a file, in order, unless stopped by -- the iteratee. In particular, seeking is not supported. -- Data is read into a buffer of the specified size. -enumHandle - :: forall s el m a. - (NullPoint s, ReadableChunk s el, MonadBaseControl IO m, MonadIO m) - => Int -- ^Buffer size (number of elements per read) +enumHandle :: + forall s el m a.(NullPoint s, ReadableChunk s el, MonadCatchIO m) => + Int -- ^Buffer size (number of elements per read) -> Handle -> Enumerator s m a enumHandle bs h i = let bufsize = bs * sizeOf (undefined :: el) - in bracket (liftIO $ mallocBytes bufsize) + in CIO.bracket (liftIO $ mallocBytes bufsize) (liftIO . free) (\p -> enumFromCallback (makeHandleCallback p bufsize h) () i) -- |An enumerator of a file handle that catches exceptions raised by -- the Iteratee. enumHandleCatch - :: forall e s el m a.(IException e, + :: + forall e s el m a.(IException e, NullPoint s, ReadableChunk s el, - MonadBaseControl IO m, - MonadIO m) + MonadCatchIO m) => Int -- ^Buffer size (number of elements per read) -> Handle -> (e -> m (Maybe EnumException)) -> Enumerator s m a enumHandleCatch bs h handler i = let bufsize = bs * sizeOf (undefined :: el) - in bracket (liftIO $ mallocBytes bufsize) + in CIO.bracket (liftIO $ mallocBytes bufsize) (liftIO . free) (\p -> enumFromCallbackCatch (makeHandleCallback p bufsize h) handler () i) @@ -92,12 +91,9 @@ -- |The enumerator of a Handle: a variation of enumHandle that -- supports RandomIO (seek requests). -- Data is read into a buffer of the specified size. -enumHandleRandom - :: forall s el m a. (NullPoint s - ,ReadableChunk s el - ,MonadBaseControl IO m - ,MonadIO m) - => Int -- ^ Buffer size (number of elements per read) +enumHandleRandom :: + forall s el m a.(NullPoint s, ReadableChunk s el, MonadCatchIO m) => + Int -- ^ Buffer size (number of elements per read) -> Handle -> Enumerator s m a enumHandleRandom bs h i = enumHandleCatch bs h handler i @@ -106,31 +102,30 @@ liftM (either (Just . EnumException :: IOException -> Maybe EnumException) (const Nothing)) - . liftIO . try $ hSeek h AbsoluteSeek $ fromIntegral off + . liftIO . CIO.try $ hSeek h AbsoluteSeek $ fromIntegral off -- ---------------------------------------------- -- File Driver wrapper functions. -enumFile' - :: (NullPoint s, MonadBaseControl IO m, ReadableChunk s el, MonadIO m) - => (Int -> Handle -> Enumerator s m a) +enumFile' :: (NullPoint s, MonadCatchIO m, ReadableChunk s el) => + (Int -> Handle -> Enumerator s m a) -> Int -- ^Buffer size -> FilePath -> Enumerator s m a -enumFile' enumf bufsize filepath iter = bracket +enumFile' enumf bufsize filepath iter = CIO.bracket (liftIO $ openBinaryFile filepath ReadMode) (liftIO . hClose) (flip (enumf bufsize) iter) -enumFile - :: (NullPoint s, MonadBaseControl IO m, ReadableChunk s el, MonadIO m) +enumFile :: + (NullPoint s, MonadCatchIO m, ReadableChunk s el) => Int -- ^Buffer size -> FilePath -> Enumerator s m a enumFile = enumFile' enumHandle -enumFileRandom - :: (NullPoint s, MonadBaseControl IO m, ReadableChunk s el, MonadIO m) +enumFileRandom :: + (NullPoint s, MonadCatchIO m, ReadableChunk s el) => Int -- ^Buffer size -> FilePath -> Enumerator s m a @@ -139,21 +134,21 @@ -- |Process a file using the given @Iteratee@. This function wraps -- @enumHandle@ as a convenience. fileDriverHandle - :: (NullPoint s, MonadBaseControl IO m, ReadableChunk s el, MonadIO m) - => Int -- ^Buffer size (number of elements) - -> Iteratee s m a - -> FilePath - -> m a + :: (NullPoint s, MonadCatchIO m, ReadableChunk s el) => + Int -- ^Buffer size (number of elements) + -> Iteratee s m a + -> FilePath + -> m a fileDriverHandle bufsize iter filepath = enumFile bufsize filepath iter >>= run -- |A version of @fileDriverHandle@ that supports seeking. fileDriverRandomHandle - :: (NullPoint s, MonadBaseControl IO m, ReadableChunk s el, MonadIO m) - => Int -- ^ Buffer size (number of elements) - -> Iteratee s m a - -> FilePath - -> m a + :: (NullPoint s, MonadCatchIO m, ReadableChunk s el) => + Int -- ^ Buffer size (number of elements) + -> Iteratee s m a + -> FilePath + -> m a fileDriverRandomHandle bufsize iter filepath = enumFileRandom bufsize filepath iter >>= run diff --git a/src/Data/Iteratee/IO/Posix.hs b/src/Data/Iteratee/IO/Posix.hs new file mode 100644 --- /dev/null +++ b/src/Data/Iteratee/IO/Posix.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +-- Low-level IO operations +-- These operations are either missing from the GHC run-time library, +-- or implemented suboptimally or heavy-handedly + +module Data.Iteratee.IO.Posix ( +#if defined(USE_POSIX) + FileOffset, + myfdRead, + myfdSeek, + Errno(..), + select'read'pending +#endif +) + +where + +#if defined(USE_POSIX) + +import Foreign.C +import Foreign.Ptr +import System.Posix +import System.IO (SeekMode(..)) +import Control.Monad +import Data.Bits -- for select +import Foreign.Marshal.Array -- for select + +-- |Alas, GHC provides no function to read from Fd to an allocated buffer. +-- The library function fdRead is not appropriate as it returns a string +-- already. I'd rather get data from a buffer. +-- Furthermore, fdRead (at least in GHC) allocates a new buffer each +-- time it is called. This is a waste. Yet another problem with fdRead +-- is in raising an exception on any IOError or even EOF. I'd rather +-- avoid exceptions altogether. + +myfdRead :: Fd -> Ptr CChar -> ByteCount -> IO (Either Errno ByteCount) +myfdRead (Fd fd) ptr n = do + n' <- cRead fd ptr n + if n' == -1 then liftM Left getErrno + else return . Right . fromIntegral $ n' + +foreign import ccall unsafe "unistd.h read" cRead + :: CInt -> Ptr CChar -> CSize -> IO CInt + +-- |The following fseek procedure throws no exceptions. +myfdSeek:: Fd -> SeekMode -> FileOffset -> IO (Either Errno FileOffset) +myfdSeek (Fd fd) mode off = do + n' <- cLSeek fd off (mode2Int mode) + if n' == -1 then liftM Left getErrno + else return . Right $ n' + where mode2Int :: SeekMode -> CInt -- From GHC source + mode2Int AbsoluteSeek = 0 + mode2Int RelativeSeek = 1 + mode2Int SeekFromEnd = 2 + +foreign import ccall unsafe "unistd.h lseek" cLSeek + :: CInt -> FileOffset -> CInt -> IO FileOffset + + +-- Darn! GHC doesn't provide the real select over several descriptors! +-- We have to implement it ourselves + +type FDSET = CUInt +type TIMEVAL = CLong -- Two longs +foreign import ccall "unistd.h select" c_select + :: CInt -> Ptr FDSET -> Ptr FDSET -> Ptr FDSET -> Ptr TIMEVAL -> IO CInt + +-- Convert a file descriptor to an FDSet (for use with select) +-- essentially encode a file descriptor in a big-endian notation +fd2fds :: CInt -> [FDSET] +fd2fds fd = replicate nb 0 ++ [setBit 0 off] + where + (nb,off) = quotRem (fromIntegral fd) (bitSize (undefined::FDSET)) + +fds2mfd :: [FDSET] -> [CInt] +fds2mfd fds = [fromIntegral (j+i*bitsize) | + (afds,i) <- zip fds [0..], j <- [0..bitsize], + testBit afds j] + where bitsize = bitSize (undefined::FDSET) + +unFd :: Fd -> CInt +unFd (Fd x) = x + +-- |poll if file descriptors have something to read +-- Return the list of read-pending descriptors +select'read'pending :: [Fd] -> IO (Either Errno [Fd]) +select'read'pending mfd = + withArray ([0,1]::[TIMEVAL]) $ \_timeout -> + withArray fds $ \readfs -> do + rc <- c_select (fdmax+1) readfs nullPtr nullPtr nullPtr + if rc == -1 + then liftM Left getErrno + -- because the wait was indefinite, rc must be positive! + else liftM (Right . map Fd . fds2mfd) (peekArray (length fds) readfs) + where + fds :: [FDSET] + fds = foldr ormax [] (map (fd2fds . unFd) mfd) + fdmax = maximum $ map fromIntegral mfd + ormax [] x = x + ormax x [] = x + ormax (a:ar) (b:br) = (a .|. b) : ormax ar br + +#endif diff --git a/src/Data/Iteratee/Iteratee.hs b/src/Data/Iteratee/Iteratee.hs --- a/src/Data/Iteratee/Iteratee.hs +++ b/src/Data/Iteratee/Iteratee.hs @@ -2,6 +2,7 @@ ,RankNTypes ,FlexibleContexts ,ScopedTypeVariables + ,BangPatterns ,DeriveDataTypeable #-} -- |Monadic and General Iteratees: @@ -9,12 +10,10 @@ module Data.Iteratee.Iteratee ( -- * Types - Cont - ,EnumerateeHandler + EnumerateeHandler -- ** Error handling ,throwErr ,throwRecoverableErr - ,throwRec ,checkErr -- ** Basic Iteratees ,identity @@ -30,6 +29,7 @@ ,mapChunksM ,convStream ,unfoldConvStream + ,unfoldConvStreamCheck ,joinI ,joinIM -- * Enumerators @@ -48,17 +48,14 @@ ,(>>>) ,eneeCheckIfDone ,eneeCheckIfDoneHandle - ,eneeCheckIfDonePass ,eneeCheckIfDoneIgnore + ,eneeCheckIfDonePass ,mergeEnums -- ** Enumeratee Combinators ,($=) ,(=$) ,(><>) ,(<><) - -- ** Enumerator creation callbacks - ,CBState (..) - ,Callback -- * Misc. ,seek ,FileOffset @@ -72,9 +69,7 @@ import Data.Iteratee.IO.Base import Data.Iteratee.Base -import Control.Arrow (first, (***)) import Control.Exception -import Control.Monad import Control.Monad.Trans.Class import Data.Maybe import Data.Typeable @@ -91,58 +86,60 @@ -- cannot be handled by 'enumFromCallbackCatch', although it can be cleared -- by 'checkErr'. throwErr :: SomeException -> Iteratee s m a -throwErr e = ierr (throwErr e) e +throwErr e = icont (const (throwErr e)) (Just e) -- |Report and propagate a recoverable error. This error can be handled by -- both 'enumFromCallbackCatch' and 'checkErr'. -throwRecoverableErr :: (Exception e) => e -> Iteratee s m a -> Iteratee s m a -throwRecoverableErr e i = ierr i (toException e) - --- | A shorter name for 'throwRecoverableErr' -throwRec :: (Exception e) => e -> Iteratee s m a -> Iteratee s m a -throwRec = throwRecoverableErr +throwRecoverableErr :: + SomeException + -> (Stream s -> Iteratee s m a) + -> Iteratee s m a +throwRecoverableErr e i = icont i (Just e) -- |Check if an iteratee produces an error. -- Returns @Right a@ if it completes without errors, otherwise -- @Left SomeException@. 'checkErr' is useful for iteratees that may not -- terminate, such as @Data.Iteratee.head@ with an empty stream. -checkErr :: Monad m => Iteratee s m a -> Iteratee s m (Either SomeException a) -checkErr iter = runIter iter (idone . Right) oc oe oR - where - oc k = icont (liftM (first checkErr) . k) - oe _ e = idone (Left e) - oR mb doB = ireq mb (checkErr . doB) +checkErr :: + (NullPoint s) => + Iteratee s m a + -> Iteratee s m (Either SomeException a) +checkErr iter = Iteratee $ \onDone onCont -> + let od = onDone . Right + oc k Nothing = onCont (checkErr . k) Nothing + oc _ (Just e) = onDone (Left e) (Chunk empty) + in runIter iter od oc -- ------------------------------------------------------------------------ -- Parser combinators -- |The identity iteratee. Doesn't do any processing of input. -identity :: Iteratee s m () -identity = idone () +identity :: (NullPoint s) => Iteratee s m () +identity = idone () (Chunk empty) -- |Get the stream status of an iteratee. -isStreamFinished :: (Nullable s, Monad m) => Iteratee s m (Maybe SomeException) -isStreamFinished = icontP check +isStreamFinished :: (Nullable s) => Iteratee s m (Maybe SomeException) +isStreamFinished = liftI check where check s@(Chunk xs) - | nullC xs = (isStreamFinished, s) - | otherwise = (idone Nothing, s) - check s@(EOF e) = (idone (Just $ fromMaybe (toException EofException) e), s) + | nullC xs = isStreamFinished + | otherwise = idone Nothing s + check s@(EOF e) = idone (Just $ fromMaybe (toException EofException) e) s {-# INLINE isStreamFinished #-} -- |Skip the rest of the stream -skipToEof :: (NullPoint s, Monad m) => Iteratee s m () -skipToEof = icontP check +skipToEof :: Iteratee s m () +skipToEof = icont check Nothing where - check (Chunk _) = (skipToEof, Chunk empty) - check s = (idone (), s) + check (Chunk _) = skipToEof + check s = idone () s -- |Seek to a position in the stream seek :: (NullPoint s) => FileOffset -> Iteratee s m () -seek o = throwRec (SeekException o) identity +seek o = throwRecoverableErr (toException $ SeekException o) (const identity) -- | Map a monadic function over the chunks of the stream and ignore the -- result. Useful for creating efficient monadic iteratee consumers, e.g. @@ -151,47 +148,42 @@ -- -- these can be efficiently run in parallel with other iteratees via -- @Data.Iteratee.ListLike.zip@. -mapChunksM_ :: (Monad m, Nullable s, NullPoint s) - => (s -> m b) - -> Iteratee s m () -mapChunksM_ f = icont step +mapChunksM_ :: (Monad m, Nullable s) => (s -> m b) -> Iteratee s m () +mapChunksM_ f = liftI step where - step s@(Chunk xs) - | nullC xs = return (icont step, s) - | otherwise = f xs >> return (icont step, Chunk empty) - step s@(EOF _) = return (idone (), s) + step (Chunk xs) + | nullC xs = liftI step + | otherwise = lift (f xs) >> liftI step + step s@(EOF _) = idone () s {-# INLINE mapChunksM_ #-} -- | A fold over chunks -foldChunksM :: (Monad m, Nullable s, NullPoint s) - => (a -> s -> m a) - -> a - -> Iteratee s m a -foldChunksM f = icont . go +foldChunksM :: (Monad m, Nullable s) => (a -> s -> m a) -> a -> Iteratee s m a +foldChunksM f = liftI . go where - go a (Chunk c) = f a c >>= \a' -> return (icont (go a'), Chunk empty) - go a e = return (idone a, e) + go a (Chunk c) = lift (f a c) >>= liftI . go + go a e = idone a e {-# INLINE foldChunksM #-} -- | Get the current chunk from the stream. -getChunk :: (Monad m, Nullable s, NullPoint s) => Iteratee s m s -getChunk = icontP step +getChunk :: (Nullable s, NullPoint s) => Iteratee s m s +getChunk = liftI step where - step s@(Chunk xs) - | nullC xs = (icontP step, s) - | otherwise = (idone xs, Chunk empty) - step s@(EOF Nothing) = (throwRec EofException getChunk, s) - step s@(EOF (Just e)) = (throwRec e getChunk, s) + step (Chunk xs) + | nullC xs = liftI step + | otherwise = idone xs $ Chunk empty + step (EOF Nothing) = throwErr $ toException EofException + step (EOF (Just e)) = throwErr e {-# INLINE getChunk #-} -- | Get a list of all chunks from the stream. -getChunks :: (Monad m, Nullable s, NullPoint s) => Iteratee s m [s] -getChunks = icontP (step id) +getChunks :: (Nullable s) => Iteratee s m [s] +getChunks = liftI (step id) where - step acc s@(Chunk xs) - | nullC xs = (icontP (step acc), s) - | otherwise = (icontP (step $ acc . (xs:)), s) - step acc stream = (idone (acc []), stream) + step acc (Chunk xs) + | nullC xs = liftI (step acc) + | otherwise = liftI (step $ acc . (xs:)) + step acc stream = idone (acc []) stream {-# INLINE getChunks #-} -- --------------------------------------------------- @@ -212,27 +204,27 @@ -- > :: (Monad m, LL.ListLike s el, NullPoint s) -- > => (el -> Bool) -- > -> Enumeratee s s m a --- > breakE cpred = eneeCheckIfDone (icont . step) +-- > breakE cpred = eneeCheckIfDone (liftI . step) -- > where -- > step k (Chunk s) --- > | LL.null s = icont (step k) +-- > | LL.null s = liftI (step k) -- > | otherwise = case LL.break cpred s of -- > (str', tail') --- > | LL.null tail' -> eneeCheckIfDone (icont . step) . k $ Chunk str' +-- > | LL.null tail' -> eneeCheckIfDone (liftI . step) . k $ Chunk str' -- > | otherwise -> idone (k $ Chunk str') (Chunk tail') -- > step k stream = idone (k stream) stream -- eneeCheckIfDone :: (Monad m, NullPoint elo) => - (Cont eli m a -> Iteratee elo m (Iteratee eli m a)) + ((Stream eli -> Iteratee eli m a) -> Iteratee elo m (Iteratee eli m a)) -> Enumeratee elo eli m a -eneeCheckIfDone = eneeCheckIfDonePass - --- | The continuation type of an incomplete iteratee -type Cont s m a = Stream s -> m (Iteratee s m a, Stream s) +eneeCheckIfDone f = eneeCheckIfDonePass f' + where + f' k Nothing = f k + f' k (Just e) = throwRecoverableErr e (\s -> joinIM $ enumChunk s $ eneeCheckIfDone f (liftI k)) type EnumerateeHandler eli elo m a = - Iteratee eli m a + (Stream eli -> Iteratee eli m a) -> SomeException -> Iteratee elo m (Iteratee eli m a) @@ -240,61 +232,51 @@ -- a handler which is used -- to process any exceptions in a separate method. eneeCheckIfDoneHandle - :: forall m eli elo a. (NullPoint elo) + :: (NullPoint elo) => EnumerateeHandler eli elo m a - -> (Cont eli m a -> Iteratee elo m (Iteratee eli m a)) + -> ((Stream eli -> Iteratee eli m a) + -> Maybe SomeException + -> Iteratee elo m (Iteratee eli m a) + ) -> Enumeratee elo eli m a -eneeCheckIfDoneHandle h fc inner = worker inner - where - worker i = runIter i onDone fc h onReq - onDone x = idone (idone x) - onReq :: forall b. m b - -> (b -> Iteratee eli m a) - -> Iteratee elo m (Iteratee eli m a) - onReq mb doB = ireq mb (worker . doB) +eneeCheckIfDoneHandle h f inner = Iteratee $ \od oc -> + let onDone x s = od (idone x s) (Chunk empty) + onCont k Nothing = runIter (f k Nothing) od oc + onCont k (Just e) = runIter (h k e) od oc + in runIter inner onDone onCont {-# INLINABLE eneeCheckIfDoneHandle #-} --- | Create enumeratees that pass all errors through the outer iteratee. eneeCheckIfDonePass :: (NullPoint elo) - => (Cont eli m a -> Iteratee elo m (Iteratee eli m a)) + => ((Stream eli -> Iteratee eli m a) + -> Maybe SomeException + -> Iteratee elo m (Iteratee eli m a) + ) -> Enumeratee elo eli m a -eneeCheckIfDonePass f = worker - where - worker = eneeCheckIfDoneHandle handler f - handler i = ierr (worker i) +eneeCheckIfDonePass f = eneeCheckIfDoneHandle (\k e -> f k (Just e)) f {-# INLINABLE eneeCheckIfDonePass #-} --- | Create an enumeratee that ignores all errors from the inner iteratee eneeCheckIfDoneIgnore :: (NullPoint elo) - => (Cont eli m a -> Iteratee elo m (Iteratee eli m a)) + => ((Stream eli -> Iteratee eli m a) + -> Maybe SomeException + -> Iteratee elo m (Iteratee eli m a) + ) -> Enumeratee elo eli m a -eneeCheckIfDoneIgnore f = worker - where - worker = eneeCheckIfDoneHandle handler f - handler i _e = worker i -{-# INLINABLE eneeCheckIfDoneIgnore #-} - +eneeCheckIfDoneIgnore f = eneeCheckIfDoneHandle (\k _ -> f k Nothing) f -- | Convert one stream into another with the supplied mapping function. -- This function operates on whole chunks at a time, contrasting to -- @mapStream@ which operates on single elements. -- --- 'mapChunks' is useful for creating high-performance iteratees, however --- the entire input chunk will be consumed even if the inner iteratee doesn't --- make use of all of it. --- -- > unpacker :: Enumeratee B.ByteString [Word8] m a -- > unpacker = mapChunks B.unpack -- -mapChunks :: (Monad m, NullPoint s) => (s -> s') -> Enumeratee s s' m a -mapChunks f = go +mapChunks :: (NullPoint s) => (s -> s') -> Enumeratee s s' m a +mapChunks f = eneeCheckIfDonePass (icont . step) where - go = eneeCheckIfDonePass (icont . step) - step k (Chunk xs) = k (Chunk (f xs)) >>= \(i',_) -> - return (go i', Chunk empty) - step k (EOF mErr) = (idone *** const (EOF mErr)) `liftM` k (EOF mErr) + step k (Chunk xs) = eneeCheckIfDonePass (icont . step) . k . Chunk $ f xs + step k str@(EOF mErr) = idone (k $ EOF mErr) str {-# INLINE mapChunks #-} -- | Convert a stream of @s@ to a stream of @s'@ using the supplied function. @@ -302,12 +284,11 @@ :: (Monad m, NullPoint s, Nullable s) => (s -> m s') -> Enumeratee s s' m a -mapChunksM f = go +mapChunksM f = eneeCheckIfDonePass (icont . step) where - go = eneeCheckIfDonePass (icont . step) - step k (Chunk xs) = f xs >>= k . Chunk >>= \(i', _str) -> - return (go i', Chunk empty) - step k (EOF mErr) = (idone *** const (EOF mErr)) `liftM` k (EOF mErr) + step k (Chunk xs) = lift (f xs) >>= + eneeCheckIfDonePass (icont . step) . k . Chunk + step k str@(EOF mErr) = idone (k $ EOF mErr) str {-# INLINE mapChunksM #-} -- |Convert one stream into another, not necessarily in lockstep. @@ -318,21 +299,17 @@ -- one element of the inner stream, or the other way around. -- The transformation from one stream to the other is specified as -- Iteratee s m s'. -convStream :: forall s s' m a. +convStream :: (Monad m, Nullable s) => Iteratee s m s' -> Enumeratee s s' m a -convStream fi = go +convStream fi = eneeCheckIfDonePass check where - go = eneeCheckIfDonePass check - check k = isStreamFinished >>= maybe (step k) (hndl k) - hndl k e = case fromException e of - Just EofException -> idone (icont k) - _ -> ierr (step k) e - step k = fi >>= lift . k . Chunk >>= go . fst + check k (Just e) = throwRecoverableErr e (const identity) >> check k Nothing + check k _ = isStreamFinished >>= maybe (step k) (idone (liftI k) . EOF . Just) + step k = fi >>= eneeCheckIfDonePass check . k . Chunk {-# INLINABLE convStream #-} - -- |The most general stream converter. Given a function to produce iteratee -- transformers and an initial state, convert the stream using iteratees -- generated by the function while continually updating the internal state. @@ -341,28 +318,36 @@ (acc -> Iteratee s m (acc, s')) -> acc -> Enumeratee s s' m a -unfoldConvStream fi acc0 = unfoldConvStreamCheck eneeCheckIfDonePass fi acc0 +unfoldConvStream f acc0 = eneeCheckIfDonePass (check acc0) + where + check acc k (Just e) = throwRecoverableErr e (const identity) >> check acc k Nothing + check acc k _ = isStreamFinished >>= + maybe (step acc k) (idone (liftI k) . EOF . Just) + step acc k = f acc >>= \(acc', s') -> + eneeCheckIfDonePass (check acc') . k . Chunk $ s' {-# INLINABLE unfoldConvStream #-} unfoldConvStreamCheck :: (Monad m, Nullable elo) - => ((Cont eli m a -> Iteratee elo m (Iteratee eli m a)) + => (((Stream eli -> Iteratee eli m a) + -> Maybe SomeException + -> Iteratee elo m (Iteratee eli m a) + ) -> Enumeratee elo eli m a ) -> (acc -> Iteratee elo m (acc, eli)) -> acc -> Enumeratee elo eli m a -unfoldConvStreamCheck checkDone f acc0 = go acc0 +unfoldConvStreamCheck checkDone f acc0 = checkDone (check acc0) where - go acc = checkDone (check acc) - check acc k = isStreamFinished >>= maybe (step acc k) (hndl acc k) - hndl acc k e = case fromException e of - Just EofException -> idone (icont k) - _ -> ierr (step acc k) e - step acc k = do - (acc', s') <- f acc - (i', _) <- lift . k $ Chunk s' - go acc' i' + check acc k mX = isStreamFinished >>= + maybe (step acc k mX) (idone (icont k mX) . EOF . Just) + step acc k Nothing = f acc >>= \(acc', s') -> + (checkDone (check acc') . k $ Chunk s') + step acc k (Just ex) = throwRecoverableErr ex $ \str' -> + let i = f acc >>= \(acc', s') -> + (checkDone (check acc') . k $ Chunk s') + in joinIM $ enumChunk str' i {-# INLINABLE unfoldConvStreamCheck #-} -- | Collapse a nested iteratee. The inner iteratee is terminated by @EOF@. @@ -370,24 +355,24 @@ -- -- The stream resumes from the point of the outer iteratee; any remaining -- input in the inner iteratee will be lost. --- -- Differs from 'Control.Monad.join' in that the inner iteratee is terminated, -- and may have a different stream type than the result. joinI :: (Monad m, Nullable s) => Iteratee s m (Iteratee s' m a) -> Iteratee s m a -joinI i = runIter i onDone onCont onErr onR - where - onDone i' = ireq (tryRun i') (either throwErr return) - onCont k = icont $ \str -> first joinI `liftM` k str - onErr i' e = throwRec e (joinI i') - onR mb doB = lift mb >>= joinI . doB +joinI = (>>= + \inner -> Iteratee $ \od oc -> + let onDone x _ = od x (Chunk empty) + onCont k Nothing = runIter (k (EOF Nothing)) onDone onCont' + onCont _ (Just e) = runIter (throwErr e) od oc + onCont' _ e = runIter (throwErr (fromMaybe excDivergent e)) od oc + in runIter inner onDone onCont) {-# INLINE joinI #-} -- | Lift an iteratee inside a monad to an iteratee. joinIM :: (Monad m) => m (Iteratee s m a) -> Iteratee s m a -joinIM mIter = ireq mIter id +joinIM mIter = Iteratee $ \od oc -> mIter >>= \iter -> runIter iter od oc -- ------------------------------------------------------------------------ @@ -413,25 +398,24 @@ -- stream. The result is the iteratee in the Done state. It is an error -- if the iteratee does not terminate on EOF. enumEof :: (Monad m) => Enumerator s m a -enumEof iter = runIter iter idoneM onC ierrM onR +enumEof iter = runIter iter onDone onCont where - onC k = k (EOF Nothing) >>= \(i,_) -> runIter i idoneM onC' ierrM onR - onC' _k = return $ throwErr excDivergent - onR mb doB = mb >>= enumEof . doB + onDone x _str = return $ idone x (EOF Nothing) + onCont k Nothing = runIter (k (EOF Nothing)) onDone onCont' + onCont k e = return $ icont k e + onCont' _ Nothing = return $ throwErr excDivergent + onCont' k e = return $ icont k e -- |Another primitive enumerator: tell the Iteratee the stream terminated -- with an error. --- --- If the iteratee is already in an error state, the previous error is --- preserved. enumErr :: (Exception e, Monad m) => e -> Enumerator s m a -enumErr e iter = runIter iter idoneM onCont ierrM onR +enumErr e iter = runIter iter onDone onCont where - onCont k = do - (i',_) <- k . EOF . Just $ toException e - runIter i' idoneM onCont' ierrM onR - onCont' _ = return $ throwErr excDivergent - onR mb doB = mb >>= enumErr e . doB + onDone x _ = return $ idone x (EOF . Just $ toException e) + onCont k Nothing = runIter (k (EOF (Just (toException e)))) onDone onCont' + onCont k e' = return $ icont k e' + onCont' _ Nothing = return $ throwErr excDivergent + onCont' k e' = return $ icont k e' -- |The composition of two enumerators: essentially the functional composition @@ -507,23 +491,22 @@ -- It passes a given list of elements to the iteratee in one chunk -- This enumerator does no IO and is useful for testing of base parsing enumPure1Chunk :: (Monad m) => s -> Enumerator s m a -enumPure1Chunk str iter = runIter iter idoneM onC ierrM onR +enumPure1Chunk str iter = runIter iter idoneM onCont where - onC k = fst `liftM` k (Chunk str) - onR mb doB = mb >>= enumPure1Chunk str . doB + onCont k Nothing = return $ k $ Chunk str + onCont k e = return $ icont k e -- | Enumerate chunks from a list -- enumList :: (Monad m) => [s] -> Enumerator s m a enumList chunks = go chunks where - go [] i = return i - go xs' i = runIter i idoneM (onCont xs') onErr (onReq xs') + go [] i = return i + go xs' i = runIter i idoneM (onCont xs') where - onCont (x:xs) k = k (Chunk x) >>= go xs . fst - onCont [] k = return $ icont k - onErr iRes e = return $ throwRec e iRes - onReq xs mb doB = mb >>= go xs . doB + onCont (x:xs) k Nothing = go xs . k $ Chunk x + onCont _ _ (Just e) = return $ throwErr e + onCont _ k Nothing = return $ icont k Nothing {-# INLINABLE enumList #-} -- | Checks if an iteratee has finished. @@ -531,23 +514,21 @@ -- This enumerator runs the iteratee, performing any monadic actions. -- If the result is True, the returned iteratee is done. enumCheckIfDone :: (Monad m) => Iteratee s m a -> m (Bool, Iteratee s m a) -enumCheckIfDone iter = runIter iter onDone onCont onErr onReq +enumCheckIfDone iter = runIter iter onDone onCont where - onDone x = return (True, idone x) - onCont k = return (False, icont k) - onErr i e = return (False, ierr i e) - onReq mb doB = mb >>= enumCheckIfDone . doB + onDone x str = return (True, idone x str) + onCont k e = return (False, icont k e) {-# INLINE enumCheckIfDone #-} -- |Create an enumerator from a callback function enumFromCallback :: (Monad m, NullPoint s) => - Callback st m s + (st -> m (Either SomeException ((Bool, st), s))) -> st -> Enumerator s m a -enumFromCallback c = - enumFromCallbackCatch c (\NotAnException -> return Nothing) +enumFromCallback c st = + enumFromCallbackCatch c (\NotAnException -> return Nothing) st -- Dummy exception to catch in enumFromCallback -- This never gets thrown, but it lets us @@ -558,35 +539,26 @@ instance Exception NotAnException where instance IException NotAnException where --- | Indicate if a callback should be called again to produce more data. -data CBState = HasMore | Finished deriving (Eq, Show, Ord, Enum) - --- | The type of callback functions to create enumerators. -type Callback st m s = st -> m (Either SomeException ((CBState, st), s)) - -- |Create an enumerator from a callback function with an exception handler. -- The exception handler is called if an iteratee reports an exception. enumFromCallbackCatch - :: forall e m s st a. (IException e, Monad m, NullPoint s) - => Callback st m s + :: (IException e, Monad m, NullPoint s) + => (st -> m (Either SomeException ((Bool, st), s))) -> (e -> m (Maybe EnumException)) -> st -> Enumerator s m a enumFromCallbackCatch c handler = loop where - loop st iter = runIter iter idoneM (onCont st) (onErr st) (onReq st) - onCont st k = c st >>= either (liftM fst . k . EOF . Just) (check k) - onErr st i e = case fromException e of + loop st iter = runIter iter idoneM (onCont st) + check k (True, st') = loop st' . k . Chunk + check k (False,_st') = return . k . Chunk + onCont st k Nothing = c st >>= + either (return . k . EOF . Just) (uncurry (check k)) + onCont st k j@(Just e) = case fromException e of Just e' -> handler e' >>= - maybe (loop st i) - (return . ierr i) . fmap toException - Nothing -> return (ierr i e) - onReq :: st -> m x -> (x -> Iteratee s m a) -> m (Iteratee s m a) - onReq st mb doB = mb >>= loop st . doB - - check :: (Stream s -> m (Iteratee s m a, Stream s)) - -> ((CBState, st), s) - -> m (Iteratee s m a) - check k ((HasMore, st'), s) = k (Chunk s) >>= loop st' . fst - check k ((Finished,_st'), s) = fst `liftM` k (Chunk s) + maybe (loop st . k $ Chunk empty) + (return . icont k . Just) . fmap toException + Nothing -> return (icont k j) {-# INLINE enumFromCallbackCatch #-} + + diff --git a/src/Data/Iteratee/ListLike.hs b/src/Data/Iteratee/ListLike.hs --- a/src/Data/Iteratee/ListLike.hs +++ b/src/Data/Iteratee/ListLike.hs @@ -51,6 +51,7 @@ -- ** Basic enumerators ,enumPureNChunk -- ** Enumerator Combinators + ,enumPair ,enumWith ,zip ,zip3 @@ -58,6 +59,7 @@ ,zip5 ,sequence_ ,countConsumed + ,greedy -- ** Monadic functions ,mapM_ ,foldM @@ -70,14 +72,13 @@ import qualified Prelude as Prelude +import Data.List (partition) import qualified Data.ListLike as LL import qualified Data.ListLike.FoldableLL as FLL import Data.Iteratee.Iteratee import Data.Monoid import Control.Applicative ((<$>), (<*>), (<*)) -import Control.Arrow (first, (***)) -import Control.Monad (liftM, mplus) -import qualified Control.Monad as CM +import Control.Monad (liftM, liftM2, mplus, (<=<)) import Control.Monad.Trans.Class import Data.Word (Word8) import qualified Data.ByteString as B @@ -85,13 +86,13 @@ -- Useful combinators for implementing iteratees and enumerators -- | Check if a stream has received 'EOF'. -isFinished :: (Monad m, Nullable s) => Iteratee s m Bool -isFinished = icontP check +isFinished :: (Nullable s) => Iteratee s m Bool +isFinished = liftI check where check c@(Chunk xs) - | nullC xs = (icontP check, c) - | otherwise = (idone False, c) - check s@(EOF _) = (idone True, s) + | nullC xs = liftI check + | otherwise = idone False c + check s@(EOF _) = idone True s {-# INLINE isFinished #-} -- ------------------------------------------------------------------------ @@ -125,16 +126,16 @@ -- -- The analogue of @List.break@ -break :: (Monad m, LL.ListLike s el) => (el -> Bool) -> Iteratee s m s -break cpred = icontP (step mempty) +break :: (LL.ListLike s el) => (el -> Bool) -> Iteratee s m s +break cpred = icont (step mempty) Nothing where - step bfr c@(Chunk str) - | LL.null str = (icontP (step bfr), c) + step bfr (Chunk str) + | LL.null str = icont (step bfr) Nothing | otherwise = case LL.break cpred str of (str', tail') - | LL.null tail' -> (icontP (step (bfr `mappend` str)), Chunk tail') - | otherwise -> (idone (bfr `mappend` str'), Chunk tail') - step bfr stream = (idone bfr, stream) + | LL.null tail' -> icont (step (bfr `mappend` str)) Nothing + | otherwise -> idone (bfr `mappend` str') (Chunk tail') + step bfr stream = idone bfr stream {-# INLINE break #-} @@ -142,39 +143,42 @@ -- Raise a (recoverable) error if the stream is terminated. -- -- The analogue of @List.head@ -head :: (Monad m, LL.ListLike s el) => Iteratee s m el -head = icontP step +-- +-- Because @head@ can raise an error, it shouldn't be used when constructing +-- iteratees for @convStream@. Use @tryHead@ instead. +head :: (LL.ListLike s el) => Iteratee s m el +head = liftI step where - step c@(Chunk vec) - | LL.null vec = (icontP step, c) - | otherwise = (idone (LL.head vec), Chunk $ LL.tail vec) - step stream = (ierr (icontP step) (setEOF stream), stream) + step (Chunk vec) + | LL.null vec = icont step Nothing + | otherwise = idone (LL.head vec) (Chunk $ LL.tail vec) + step stream = icont step (Just (setEOF stream)) {-# INLINE head #-} -- | Similar to @head@, except it returns @Nothing@ if the stream -- is terminated. -tryHead :: (Monad m, LL.ListLike s el) => Iteratee s m (Maybe el) -tryHead = icontP step +tryHead :: (LL.ListLike s el) => Iteratee s m (Maybe el) +tryHead = liftI step where - step c@(Chunk vec) - | LL.null vec = (icontP step, c) - | otherwise = (idone (Just $ LL.head vec), Chunk $ LL.tail vec) - step stream = (idone Nothing, stream) + step (Chunk vec) + | LL.null vec = liftI step + | otherwise = idone (Just $ LL.head vec) (Chunk $ LL.tail vec) + step stream = idone Nothing stream {-# INLINE tryHead #-} -- |Attempt to read the last element of the stream and return it -- Raise a (recoverable) error if the stream is terminated -- -- The analogue of @List.last@ -last :: (Monad m, LL.ListLike s el, Nullable s) => Iteratee s m el -last = icontP (step Nothing) +last :: (LL.ListLike s el, Nullable s) => Iteratee s m el +last = liftI (step Nothing) where - step l c@(Chunk xs) - | nullC xs = (icontP (step l), c) - | otherwise = (icontP $ step (Just $ LL.last xs), Chunk LL.empty) + step l (Chunk xs) + | nullC xs = liftI (step l) + | otherwise = liftI $ step (Just $ LL.last xs) step l s@(EOF _) = case l of - Nothing -> (ierr (icontP (step l)) (setEOF s), s) - Just x -> (idone x, s) + Nothing -> icont (step l) . Just . setEOF $ s + Just x -> idone x s {-# INLINE last #-} @@ -184,22 +188,20 @@ -- stream. -- For example, if the stream contains 'abd', then (heads 'abc') -- will remove the characters 'ab' and return 2. -heads :: (Monad m, Nullable s, LL.ListLike s el, Eq el) - => s - -> Iteratee s m Int +heads :: (Monad m, Nullable s, LL.ListLike s el, Eq el) => s -> Iteratee s m Int heads st | nullC st = return 0 heads st = loop 0 st where loop cnt xs | nullC xs = return cnt - | otherwise = icontP (step cnt xs) - step cnt str (Chunk xs) | nullC xs = (icontP (step cnt str), Chunk xs) - step cnt str stream | nullC str = (idone cnt, stream) + | otherwise = liftI (step cnt xs) + step cnt str (Chunk xs) | nullC xs = liftI (step cnt str) + step cnt str stream | nullC str = idone cnt stream step cnt str s@(Chunk xs) = if LL.head str == LL.head xs then step (succ cnt) (LL.tail str) (Chunk $ LL.tail xs) - else (idone cnt, s) - step cnt _ stream = (idone cnt, stream) + else idone cnt s + step cnt _ stream = idone cnt stream {-# INLINE heads #-} @@ -207,13 +209,13 @@ -- it from the stream. -- Return @Just c@ if successful, return @Nothing@ if the stream is -- terminated by 'EOF'. -peek :: (Monad m, LL.ListLike s el) => Iteratee s m (Maybe el) -peek = icontP step +peek :: (LL.ListLike s el) => Iteratee s m (Maybe el) +peek = liftI step where step s@(Chunk vec) - | LL.null vec = (icontP step, s) - | otherwise = (idone (Just $ LL.head vec), s) - step stream = (idone Nothing, stream) + | LL.null vec = liftI step + | otherwise = idone (Just $ LL.head vec) s + step stream = idone Nothing stream {-# INLINE peek #-} -- | Return a chunk of @t@ elements length while consuming @d@ elements @@ -224,19 +226,18 @@ => Int -- ^ length of chunk (t) -> Int -- ^ amount to consume (d) -> Iteratee s m s' -roll t d | t > d = icontP step +roll t d | t > d = liftI step where step (Chunk vec) | LL.length vec >= d = - (idone (LL.singleton $ LL.take t vec), Chunk $ LL.drop d vec) + idone (LL.singleton $ LL.take t vec) (Chunk $ LL.drop d vec) | LL.length vec >= t = - (idone (LL.singleton $ LL.take t vec) <* drop (d-LL.length vec) - ,mempty) - | LL.null vec = (icontP step, mempty) - | otherwise = (icontP (step' vec), mempty) - step stream = (idone LL.empty, stream) + idone (LL.singleton $ LL.take t vec) mempty <* drop (d-LL.length vec) + | LL.null vec = liftI step + | otherwise = liftI (step' vec) + step stream = idone LL.empty stream step' v1 (Chunk vec) = step . Chunk $ v1 `mappend` vec - step' v1 stream = (idone (LL.singleton v1), stream) + step' v1 stream = idone (LL.singleton v1) stream roll t d = LL.singleton <$> joinI (take t stream2stream) <* drop (d-t) -- d is >= t, so this version works {-# INLINE roll #-} @@ -245,28 +246,28 @@ -- |Drop n elements of the stream, if there are that many. -- -- The analogue of @List.drop@ -drop :: (Monad m, Nullable s, LL.ListLike s el) => Int -> Iteratee s m () -drop 0 = idone () -drop n' = icontP (step n') +drop :: (Nullable s, LL.ListLike s el) => Int -> Iteratee s m () +drop 0 = idone () (Chunk empty) +drop n' = liftI (step n') where step n (Chunk str) - | LL.length str < n = (icontP (step (n - LL.length str)), mempty) - | otherwise = (idone (), Chunk (LL.drop n str)) - step _ stream = (idone (), stream) + | LL.length str < n = liftI (step (n - LL.length str)) + | otherwise = idone () (Chunk (LL.drop n str)) + step _ stream = idone () stream {-# INLINE drop #-} -- |Skip all elements while the predicate is true. -- -- The analogue of @List.dropWhile@ -dropWhile :: (Monad m, LL.ListLike s el) => (el -> Bool) -> Iteratee s m () -dropWhile p = icontP step +dropWhile :: (LL.ListLike s el) => (el -> Bool) -> Iteratee s m () +dropWhile p = liftI step where step (Chunk str) - | LL.null left = (icontP step, mempty) - | otherwise = (idone (), Chunk left) + | LL.null left = liftI step + | otherwise = idone () (Chunk left) where left = LL.dropWhile p str - step stream = (idone (), stream) + step stream = idone () stream {-# INLINE dropWhile #-} @@ -275,35 +276,34 @@ -- This forces evaluation of the entire stream. -- -- The analogue of @List.length@ -length :: (Monad m, Num a, LL.ListLike s el) => Iteratee s m a -length = icontP (step 0) +length :: (Num a, LL.ListLike s el) => Iteratee s m a +length = liftI (step 0) where - step !i (Chunk xs) = let newL = i + fromIntegral (LL.length xs) - in newL `seq` (icontP (step newL), mempty) - step !i stream = (idone i, stream) + step !i (Chunk xs) = liftI (step $ i + fromIntegral (LL.length xs)) + step !i stream = idone i stream {-# INLINE length #-} -- | Get the length of the current chunk, or @Nothing@ if 'EOF'. -- -- This function consumes no input. -chunkLength :: (Monad m, LL.ListLike s el) => Iteratee s m (Maybe Int) -chunkLength = icontP step +chunkLength :: (LL.ListLike s el) => Iteratee s m (Maybe Int) +chunkLength = liftI step where - step s@(Chunk xs) = (idone (Just $ LL.length xs), s) - step stream = (idone Nothing, stream) + step s@(Chunk xs) = idone (Just $ LL.length xs) s + step stream = idone Nothing stream {-# INLINE chunkLength #-} -- | Take @n@ elements from the current chunk, or the whole chunk if -- @n@ is greater. takeFromChunk :: - (Monad m, Nullable s, LL.ListLike s el) + (Nullable s, LL.ListLike s el) => Int -> Iteratee s m s -takeFromChunk n | n <= 0 = idone empty -takeFromChunk n = icontP step +takeFromChunk n | n <= 0 = idone empty (Chunk empty) +takeFromChunk n = liftI step where - step (Chunk xs) = let (h,t) = LL.splitAt n xs in (idone h, Chunk t) - step stream = (idone empty, stream) + step (Chunk xs) = let (h,t) = LL.splitAt n xs in idone h $ Chunk t + step stream = idone empty stream {-# INLINE takeFromChunk #-} -- --------------------------------------------------- @@ -318,24 +318,18 @@ -- -- @breakE@ should be used in preference to @break@ whenever possible. breakE - :: (LL.ListLike s el, NullPoint s, Monad m, Functor m) + :: (LL.ListLike s el, NullPoint s) => (el -> Bool) -> Enumeratee s s m a -breakE cpred = go +breakE cpred = eneeCheckIfDonePass (icont . step) where - go = eneeCheckIfDonePass (icont . step) step k (Chunk s) - | LL.null s = return (icont (step k), mempty) + | LL.null s = liftI (step k) | otherwise = case LL.break cpred s of (str', tail') - | LL.null tail' -> do - (i', _) <- k (Chunk str') - return (go i' <* dropWhile (not . cpred), Chunk tail') - -- if the inner iteratee completes before - -- the predicate is met, elements still - -- need to be dropped. - | otherwise -> (idone *** const (Chunk tail')) `liftM` k (Chunk str') - step k stream = return (idone (icont k), stream) + | LL.null tail' -> eneeCheckIfDonePass (icont . step) . k $ Chunk str' + | otherwise -> idone (k $ Chunk str') (Chunk tail') + step k stream = idone (liftI k) stream {-# INLINE breakE #-} -- |Read n elements from a stream and apply the given iteratee to the @@ -348,22 +342,19 @@ => Int -- ^ number of elements to consume -> Enumeratee s s m a take n' iter - | n' <= 0 = return iter - | otherwise = runIter iter onDone onCont onErr onReq - where - onDone x = drop n' >> idone (idone x) - onCont k = if n' == 0 then idone (icont k) - else icont (step n' k) - onErr i = ierr (take n' i) - onReq mb doB = ireq mb (take n' . doB) - - step n k c@(Chunk str) - | LL.null str = return (icont (step n k), c) - | LL.length str <= n = (take (n - LL.length str) *** const mempty) - `liftM` k (Chunk str) - | otherwise = (idone *** const (Chunk s2)) `liftM` k (Chunk s1) + | n' <= 0 = return iter + | otherwise = Iteratee $ \od oc -> runIter iter (on_done od oc) (on_cont od oc) + where + on_done od oc x _ = runIter (drop n' >> return (return x)) od oc + on_cont od oc k Nothing = if n' == 0 then od (liftI k) (Chunk mempty) + else runIter (liftI (step n' k)) od oc + on_cont od oc _ (Just e) = runIter (drop n' >> throwErr e) od oc + step n k (Chunk str) + | LL.null str = liftI (step n k) + | LL.length str <= n = take (n - LL.length str) $ k (Chunk str) + | otherwise = idone (k (Chunk s1)) (Chunk s2) where (s1, s2) = LL.splitAt n str - step _n k stream = return (idone (icont k), stream) + step _n k stream = idone (liftI k) stream {-# INLINE take #-} -- |Read n elements from a stream and apply the given iteratee to the @@ -392,35 +383,32 @@ -- 4 elements to the outer stream takeUpTo :: (Monad m, Nullable s, LL.ListLike s el) => Int -> Enumeratee s s m a takeUpTo i iter - | i <= 0 = idone iter - | otherwise = runIter iter onDone onCont onErr onReq + | i <= 0 = idone iter (Chunk empty) + | otherwise = Iteratee $ \od oc -> + runIter iter (onDone od oc) (onCont od oc) where - onDone x = idone (idone x) - onCont k = if i == 0 then idone (icont k) - else icont (step i k) - onErr i' = ierr (takeUpTo i i') - onReq mb doB = ireq mb (takeUpTo i . doB) - - step n k c@(Chunk str) - | LL.null str = return (icont (step n k), c) - | LL.length str < n = first (takeUpTo (n - LL.length str)) - `liftM` k (Chunk str) - | otherwise = do + onDone od oc x str = runIter (idone (return x) str) od oc + onCont od oc k Nothing = if i == 0 then od (liftI k) (Chunk mempty) + else runIter (liftI (step i k)) od oc + onCont od oc _ (Just e) = runIter (throwErr e) od oc + step n k (Chunk str) + | LL.null str = liftI (step n k) + | LL.length str < n = takeUpTo (n - LL.length str) $ k (Chunk str) + | otherwise = -- check to see if the inner iteratee has completed, and if so, -- grab any remaining stream to put it in the outer iteratee. -- the outer iteratee is always complete at this stage, although -- the inner may not be. let (s1, s2) = LL.splitAt n str - (iter', preStr) <- k (Chunk s1) - case preStr of - (Chunk preC) - | LL.null preC -> return (idone iter', Chunk s2) - | otherwise -> return (idone iter' - , Chunk $ preC `LL.append` s2) - -- this case shouldn't ever happen, except possibly - -- with broken iteratees - _ -> return (idone iter', preStr) - step _ k stream = return (idone (icont k), stream) + in Iteratee $ \od' _ -> do + res <- runIter (k (Chunk s1)) (\a s -> return $ Left (a, s)) + (\k' e -> return $ Right (k',e)) + case res of + Left (a,Chunk s1') -> od' (return a) + (Chunk $ s1' `LL.append` s2) + Left (a,s') -> od' (idone a s') (Chunk s2) + Right (k',e) -> od' (icont k' e) (Chunk s2) + step _ k stream = idone (liftI k) stream {-# INLINE takeUpTo #-} -- | Takes an element predicate and returns the (possibly empty) @@ -430,7 +418,7 @@ -- remaining stream will not satisfy the predicate. -- -- The analogue of @List.takeWhile@, see also @break@ and @takeWhileE@ -takeWhile :: (Monad m, LL.ListLike s el ) => (el -> Bool) -> Iteratee s m s +takeWhile :: (LL.ListLike s el ) => (el -> Bool) -> Iteratee s m s takeWhile = break . (not .) {-# INLINEABLE takeWhile #-} @@ -439,7 +427,7 @@ -- -- This is preferred to @takeWhile@. takeWhileE - :: (LL.ListLike s el, NullPoint s, Monad m, Functor m) + :: (LL.ListLike s el, NullPoint s) => (el -> Bool) -> Enumeratee s s m a takeWhileE = breakE . (not .) @@ -452,15 +440,14 @@ -- -- The analog of @List.map@ mapStream - :: (Monad m - ,LL.ListLike (s el) el + :: (LL.ListLike (s el) el ,LL.ListLike (s el') el' ,NullPoint (s el) ,LooseMap s el el') => (el -> el') -> Enumeratee (s el) (s el') m a mapStream f = mapChunks (lMap f) -{-# SPECIALIZE mapStream :: Monad m => (el -> el') -> Enumeratee [el] [el'] m a #-} +{-# SPECIALIZE mapStream :: (el -> el') -> Enumeratee [el] [el'] m a #-} -- |Map the stream rigidly. -- @@ -468,12 +455,12 @@ -- This function is necessary for @ByteString@ and similar types -- that cannot have 'LooseMap' instances, and may be more efficient. rigidMapStream - :: (Monad m, LL.ListLike s el, NullPoint s) + :: (LL.ListLike s el, NullPoint s) => (el -> el) -> Enumeratee s s m a rigidMapStream f = mapChunks (LL.rigidMap f) -{-# SPECIALIZE rigidMapStream :: Monad m => (el -> el) -> Enumeratee [el] [el] m a #-} -{-# SPECIALIZE rigidMapStream :: Monad m => (Word8 -> Word8) -> Enumeratee B.ByteString B.ByteString m a #-} +{-# SPECIALIZE rigidMapStream :: (el -> el) -> Enumeratee [el] [el] m a #-} +{-# SPECIALIZE rigidMapStream :: (Word8 -> Word8) -> Enumeratee B.ByteString B.ByteString m a #-} -- |Creates an 'enumeratee' with only elements from the stream that @@ -494,7 +481,7 @@ :: (LL.ListLike s el, Monad m, Nullable s) => Int -- ^ size of group -> Enumeratee s [s] m a -group cksz iinit = icont (step 0 id iinit) +group cksz iinit = liftI (step 0 id iinit) where -- there are two cases to consider for performance purposes: -- 1 - grouping lots of small chunks into bigger chunks @@ -503,34 +490,32 @@ -- and pass them to the inner iteratee as one list. @gsplit@ does this. -- -- case 1 is a bit harder, need to hold onto each chunk and coalesce them - -- after enough have been received. Currently using a Hughes list + -- after enough have been received. Currently using a difference list -- for this, i.e ([s] -> [s]) -- -- not using eneeCheckIfDone because that loses final chunks at EOF step sz pfxd icur (Chunk s) - | LL.null s = return (icont (step sz pfxd icur), Chunk s) - | LL.length s + sz < cksz = return (icont (step (sz+LL.length s) - (pfxd . (s:)) icur) - , mempty) + | LL.null s = liftI (step sz pfxd icur) + | LL.length s + sz < cksz = liftI (step (sz+LL.length s) (pfxd . (s:)) icur) | otherwise = let (full, rest) = gsplit . mconcat $ pfxd [s] pfxd' = if LL.null rest then id else (rest:) - onDone x = return (idone (idone x), Chunk rest) - onErr i e = return (ierr (icont (step (LL.length rest) pfxd' i)) e - , Chunk rest) - onCont k = (icont . step (LL.length rest) pfxd' - *** const (Chunk rest)) - `liftM` k (Chunk full) - -- since step is a monadic function, the monadic request can be - -- inlined, saving an indirection - onReq mb doB = mb >>= \b -> - step (LL.length rest) pfxd' (doB b) (Chunk rest) - in runIter icur onDone onCont onErr onReq + onDone x str = return $ Left (x,str) + onCont k Nothing = return . Right . Left . k $ Chunk full + onCont k e = return . Right $ Right (liftI k, e) + in do + res <- lift $ runIter icur onDone onCont + case res of + Left (x,str) -> idone (idone x str) (Chunk rest) + Right (Left inext) -> liftI $ step (LL.length rest) pfxd' inext + Right (Right (inext, e)) -> icont (step (LL.length rest) + pfxd' inext) + e step _ pfxd icur mErr = case pfxd [] of - [] -> return (idone icur, mErr) - rest -> ((, mErr) . idone) `liftM` - enumPure1Chunk [mconcat rest] icur - + [] -> idone icur mErr + rest -> do + inext <- lift $ enumPure1Chunk [mconcat rest] icur + idone inext mErr gsplit ls = case LL.splitAt cksz ls of (g, rest) | LL.null rest -> if LL.length g == cksz then ([g], LL.empty) @@ -545,10 +530,10 @@ -- -- The analogue of 'List.groupBy' groupBy - :: forall s el m a. (LL.ListLike s el, Monad m, Nullable s) + :: (LL.ListLike s el, Monad m, Nullable s) => (el -> el -> Bool) -> Enumeratee s [s] m a -groupBy same iinit = icont $ go iinit (const True, id) +groupBy same iinit = liftI $ go iinit (const True, id) where -- As in group, need to handle grouping efficiently when we're fed -- many small chunks. @@ -562,29 +547,24 @@ -- unless the stream was entirely empty and there is no -- accumulator. go icurr pfx (Chunk s) = case gsplit pfx s of - ([], partial) -> return (icont $ go icurr partial, mempty) - (full, partial) -> + ([], partial) -> liftI $ go icurr partial + (full, partial) -> do -- if the inner iteratee is done, the outer iteratee needs to be -- notified to terminate. -- if the inner iteratee is in an error state, that error should -- be lifted to the outer iteratee - let onCont k = k (Chunk full) >>= \(inext, str') -> - case str' of - Chunk rest -> return (icont $ go inext partial - , Chunk $ mconcat rest) - EOF mex -> return (icont $ go inext partial, EOF mex) - onErr inext e = return (ierr (icont (go inext partial)) e - , EOF (Just e)) - onDone :: a -> m (Iteratee s m (Iteratee [s] m a), Stream s) - onDone a = return (idone (idone a) - , Chunk . mconcat $ snd partial []) - onReq mb doB = mb >>= \b -> go (doB b) pfx (Chunk s) - in runIter icurr onDone onCont onErr onReq + let onCont k Nothing = return $ Right $ Left $ k $ Chunk full + onCont k e = return $ Right $ Right (liftI k, e) + onDone x str = return $ Left (x,str) + res <- lift $ runIter icurr onDone onCont + case res of + Left (x,str) -> idone (idone x str) (Chunk (mconcat $ snd partial [])) + Right (Left inext) -> liftI $ go inext partial + Right (Right (inext,e)) -> icont (go inext partial) e go icurr (_inpfx, pfxd) (EOF mex) = case pfxd [] of - [] -> ((,EOF mex) . idone) `liftM` enumChunk (EOF mex) icurr - rest -> ((,EOF mex) . idone) `liftM` - (enumPure1Chunk [mconcat rest] icurr >>= enumChunk (EOF mex)) - + [] -> lift . enumChunk (EOF mex) $ icurr + rest -> do inext <- lift . enumPure1Chunk [mconcat rest] $ icurr + lift . enumChunk (EOF mex) $ inext -- Here, gsplit carries an accumulator consisting of a predicate -- "inpfx" that indicates whether a new element belongs in the -- growing group, and a difference list to ultimately generate the @@ -624,7 +604,7 @@ in ( gdone, (same (LL.head glast), (glast :)) ) llGroupBy eq l -- Copied from Data.ListLike, avoid spurious (Eq el) constraint | LL.null l = [] - | otherwise = LL.cons x ys : llGroupBy eq zs + | otherwise = (LL.cons x ys):(llGroupBy eq zs) where (ys, zs) = LL.span (eq x) xs x = LL.head l xs = LL.tail l @@ -708,16 +688,16 @@ -- -- The analogue of @List.foldl@ foldl - :: (Monad m, LL.ListLike s el, FLL.FoldableLL s el) + :: (LL.ListLike s el, FLL.FoldableLL s el) => (a -> el -> a) -> a -> Iteratee s m a -foldl f i = icontP (step i) +foldl f i = liftI (step i) where - step acc c@(Chunk xs) - | LL.null xs = (icontP (step acc), c) - | otherwise = (icontP (step $ FLL.foldl f acc xs), mempty) - step acc stream = (idone acc, stream) + step acc (Chunk xs) + | LL.null xs = liftI (step acc) + | otherwise = liftI (step $ FLL.foldl f acc xs) + step acc stream = idone acc stream {-# INLINE foldl #-} @@ -726,16 +706,16 @@ -- -- The analogue of @List.foldl'@. foldl' - :: (Monad m, LL.ListLike s el, FLL.FoldableLL s el) + :: (LL.ListLike s el, FLL.FoldableLL s el) => (a -> el -> a) -> a -> Iteratee s m a -foldl' f i = icontP (step i) +foldl' f i = liftI (step i) where - step acc c@(Chunk xs) - | LL.null xs = (icontP (step acc), c) - | otherwise = (icontP (step $! FLL.foldl' f acc xs), mempty) - step acc stream = (idone acc, stream) + step acc (Chunk xs) + | LL.null xs = liftI (step acc) + | otherwise = liftI (step $! FLL.foldl' f acc xs) + step acc stream = idone acc stream {-# INLINE foldl' #-} -- | Variant of foldl with no base case. Requires at least one element @@ -743,55 +723,53 @@ -- -- The analogue of @List.foldl1@. foldl1 - :: (Monad m, LL.ListLike s el, FLL.FoldableLL s el) + :: (LL.ListLike s el, FLL.FoldableLL s el) => (el -> el -> el) -> Iteratee s m el -foldl1 f = icontP step +foldl1 f = liftI step where - step c@(Chunk xs) + step (Chunk xs) -- After the first chunk, just use regular foldl. - | LL.null xs = (icontP step, c) - | otherwise = (foldl f $ FLL.foldl1 f xs, mempty) - step stream = (ierr (icontP step) $ toException EofException - , stream) + | LL.null xs = liftI step + | otherwise = foldl f $ FLL.foldl1 f xs + step stream = icont step (Just (setEOF stream)) {-# INLINE foldl1 #-} -- | Strict variant of 'foldl1'. foldl1' - :: (Monad m, LL.ListLike s el, FLL.FoldableLL s el) + :: (LL.ListLike s el, FLL.FoldableLL s el) => (el -> el -> el) -> Iteratee s m el -foldl1' f = icontP step +foldl1' f = liftI step where - step c@(Chunk xs) + step (Chunk xs) -- After the first chunk, just use regular foldl'. - | LL.null xs = (icontP step, c) - | otherwise = (foldl' f $ FLL.foldl1 f xs, mempty) - step stream = (ierr (icontP step) $ toException EofException - , stream) + | LL.null xs = liftI step + | otherwise = foldl' f $ FLL.foldl1 f xs + step stream = icont step (Just (setEOF stream)) {-# INLINE foldl1' #-} -- | Sum of a stream. -sum :: (Monad m, LL.ListLike s el, Num el) => Iteratee s m el -sum = icontP (step 0) +sum :: (LL.ListLike s el, Num el) => Iteratee s m el +sum = liftI (step 0) where - step acc c@(Chunk xs) - | LL.null xs = (icontP (step acc), c) - | otherwise = (icontP (step $! acc + LL.sum xs), mempty) - step acc str = (idone acc, str) + step acc (Chunk xs) + | LL.null xs = liftI (step acc) + | otherwise = liftI (step $! acc + LL.sum xs) + step acc str = idone acc str {-# INLINE sum #-} -- | Product of a stream. -product :: (Monad m, LL.ListLike s el, Num el) => Iteratee s m el -product = icontP (step 1) +product :: (LL.ListLike s el, Num el) => Iteratee s m el +product = liftI (step 1) where - step acc c@(Chunk xs) - | LL.null xs = (icontP (step acc), c) - | otherwise = (icontP (step $! acc * LL.product xs), mempty) - step acc str = (idone acc, str) + step acc (Chunk xs) + | LL.null xs = liftI (step acc) + | otherwise = liftI (step $! acc * LL.product xs) + step acc str = idone acc str {-# INLINE product #-} @@ -799,37 +777,63 @@ -- Zips -- |Enumerate two iteratees over a single stream simultaneously. +-- Deprecated, use `Data.Iteratee.ListLike.zip` instead. -- +-- Compare to @zip@. +{-# DEPRECATED enumPair "use Data.Iteratee.ListLike.zip" #-} +enumPair + :: (Monad m, Nullable s, LL.ListLike s el) + => Iteratee s m a + -> Iteratee s m b + -> Iteratee s m (a, b) +enumPair = zip + +-- |Enumerate two iteratees over a single stream simultaneously. +-- -- Compare to @List.zip@. zip :: (Monad m, Nullable s, LL.ListLike s el) => Iteratee s m a -> Iteratee s m b -> Iteratee s m (a, b) -zip x0 y0 = runIter x0 (odx y0) (ocx y0) (oex y0) (orx y0) - where - odx yIter a = (a, ) `liftM` yIter - ocx yIter k = runIter yIter (ody k) (ocy k) (oey k) (ory k) - oex yIter i' e = throwRec e (zip i' yIter) - orx yIter ma doA = ireq ma $ (`zip` yIter) . doA +zip x0 y0 = do + -- need to check if both iteratees are initially finished. If so, + -- we don't want to push a chunk which will be dropped + (a', x') <- lift $ runIter x0 od oc + (b', y') <- lift $ runIter y0 od oc + case checkDone a' b' of + Just (Right (a,b,s)) -> idone (a,b) s -- 's' may be EOF, needs to stay + Just (Left (Left a)) -> liftM (a,) y' + Just (Left (Right b)) -> liftM (,b) x' + Nothing -> liftI (step x' y') + where + step x y (Chunk xs) | nullC xs = liftI (step x y) + step x y (Chunk xs) = do + (a', x') <- lift $ (\i -> runIter i od oc) =<< enumPure1Chunk xs x + (b', y') <- lift $ (\i -> runIter i od oc) =<< enumPure1Chunk xs y + case checkDone a' b' of + Just (Right (a,b,s)) -> idone (a,b) s + Just (Left (Left a)) -> liftM (a,) y' + Just (Left (Right b)) -> liftM (,b) x' + Nothing -> liftI (step x' y') + step x y (EOF err) = joinIM $ case err of + Nothing -> (liftM2.liftM2) (,) (enumEof x) (enumEof y) + Just e -> (liftM2.liftM2) (,) (enumErr e x) (enumErr e y) - ody x_k b = (,b) `liftM` icont x_k - ocy xK yK = icont (step xK yK) - oey xK i' e = throwRec e (zip (icont xK) i') - ory xK mb doB = ireq mb (zip (icont xK) . doB) + od a s = return (Just (a, s), idone a s) + oc k e = return (Nothing , icont k e) - step xK yK (Chunk xs) | nullC xs = return (icont (step xK yK), Chunk xs) - step xK yK str = do - (x,xLeft) <- xK str - (y,yLeft) <- yK str - return (zip x y, shorter xLeft yLeft) + checkDone r1 r2 = case (r1, r2) of + (Just (a, s1), Just (b,s2)) -> Just $ Right (a, b, shorter s1 s2) + (Just (a, _), Nothing) -> Just . Left $ Left a + (Nothing, Just (b, _)) -> Just . Left $ Right b + (Nothing, Nothing) -> Nothing - shorter c1@(Chunk xs) c2@(Chunk ys) - | LL.length xs < LL.length ys = c1 - | otherwise = c2 - shorter e@(EOF _) _ = e - shorter _ e@(EOF _) = e - + shorter c1@(Chunk xs) c2@(Chunk ys) + | LL.length xs < LL.length ys = c1 + | otherwise = c2 + shorter e@(EOF _) _ = e + shorter _ e@(EOF _) = e {-# INLINE zip #-} zip3 @@ -871,23 +875,37 @@ => Iteratee s m a -> Iteratee s m b -> Iteratee s m (a, b) -enumWith x0 y0 = runIter x0 (odx y0) (ocx y0) (oex y0) (orx y0) - where - odx yIter a = (a,) `liftM` joinIM (enumEof yIter) - ocx yIter k = runIter yIter (ody k) (ocy k) (oey k) (ory k) - oex yIter i' e = throwRec e (enumWith i' yIter) - orx yIter ma doA = ireq ma $ (`enumWith` yIter) . doA +enumWith i1 i2 = do + -- as with zip, first check to see if the initial iteratee is complete, + -- otherwise data would be dropped. + -- running the second iteratee as well to prevent a monadic effect mismatch + -- although I think that would be highly unlikely to happen in common + -- code + (a', x') <- lift $ runIter i1 od oc + (_, y') <- lift $ runIter i2 od oc + case a' of + Just (a, s) -> flip idone s =<< lift (liftM (a,) $ run i2) + Nothing -> go x' y' + where + od a s = return (Just (a, s), idone a s) + oc k e = return (Nothing , icont k e) - ody x_k b = (,b) `liftM` icont x_k - ocy xK yK = icont (step xK yK) - oey xK i' e = throwRec e (enumWith (icont xK) i') - ory xK mb doB = ireq mb (enumWith (icont xK) . doB) + getUsed xs (Chunk ys) = LL.take (LL.length xs - LL.length ys) xs + getUsed xs (EOF _) = xs - step xK yK (Chunk xs) | nullC xs = return (icont (step xK yK), Chunk xs) - step xK yK str = do - (x, xLeft) <- xK str - (y,_yLeft) <- yK str - return (enumWith x y, xLeft) + go x y = liftI step + where + step (Chunk xs) | nullC xs = liftI step + step (Chunk xs) = do + (a', x') <- lift $ (\i -> runIter i od oc) =<< enumPure1Chunk xs x + case a' of + Just (a, s) -> do + b <- lift $ run =<< enumPure1Chunk (getUsed xs s) y + idone (a, b) s + Nothing -> lift (enumPure1Chunk xs y) >>= go x' + step (EOF err) = joinIM $ case err of + Nothing -> (liftM2.liftM2) (,) (enumEof x) (enumEof y) + Just e -> (liftM2.liftM2) (,) (enumErr e x) (enumErr e y) {-# INLINE enumWith #-} -- |Enumerate a list of iteratees over a single stream simultaneously @@ -896,38 +914,42 @@ -- -- Compare to @Prelude.sequence_@. sequence_ - :: forall el s m a. (Monad m, LL.ListLike s el, Nullable s) + :: (Monad m, LL.ListLike s el, Nullable s) => [Iteratee s m a] -> Iteratee s m () -sequence_ = check [] +sequence_ = self where - -- recursively checks each input iteratee to see if it's finished. - -- all of the unfinished iteratees are run with a single chunk, - -- then checked again. + self is = liftI step + where + step (Chunk xs) | LL.null xs = liftI step + step s@(Chunk _) = do + -- give a chunk to each iteratee + is' <- lift $ mapM (enumChunk s) is + -- filter done iteratees + (done, notDone) <- lift $ partition fst `liftM` mapM enumCheckIfDone is' + if Prelude.null notDone + then idone () <=< remainingStream $ map snd done + else self $ map snd notDone + step s@(EOF _) = do + s' <- remainingStream <=< lift $ mapM (enumChunk s) is + case s' of + EOF (Just e) -> throwErr e + _ -> idone () s' - -- a possible inefficiency is if multiple iteratees are in the - -- Request state (monadic action), as each request is fed to the - -- enumerator separately. An alternative implementation would aggregate - -- all monadic effects (as this version aggregates all continuations) - -- to perform them at once. - check [] [] = idone () - check ks [] = icont (step ks) - check ks (i:iters) = runIter i (\_ -> check ks iters) - (onCont ks iters) - (onErr ks iters) - (onReq ks iters) - onCont ks iters k = check (k:ks) iters - onErr ks iters i e = throwRec e (check ks (i:iters)) - onReq :: [Stream s -> m (Iteratee s m a, Stream s)] - -> [Iteratee s m a] - -> m b - -> (b -> Iteratee s m a) - -> Iteratee s m () - onReq ks iters mb doB = ireq mb (\b -> check ks (doB b:iters)) + -- returns the unconsumed part of the stream; "sequence_ is" consumes as + -- much of the stream as the iteratee in is that consumes the most; e.g. + -- sequence_ [I.head, I.last] consumes whole stream + remainingStream + :: (Monad m, Nullable s, LL.ListLike s el) + => [Iteratee s m a] -> Iteratee s m (Stream s) + remainingStream is = lift $ + return . Prelude.foldl1 shorter <=< mapM (\i -> runIter i od oc) $ is + where + od _ s = return s + oc _ e = return $ case e of + Nothing -> mempty + _ -> EOF e - step ks str = first (check []) `liftM` CM.foldM (accf str) ([], str) ks - accf str (iS, !strs) k = ((:iS) *** flip shorter strs) `liftM` k str - -- return the shorter one of two streams; errors are propagated with the -- priority given to the "left" shorter c1@(Chunk xs) c2@(Chunk ys) @@ -943,26 +965,20 @@ (Monad m, LL.ListLike s el, Nullable s, Integral n) => Iteratee s m a -> Iteratee s m (a, n) -countConsumed = check 0 +countConsumed i = go 0 (const i) (Chunk empty) where - newLen :: n -> s -> s -> n - newLen n c c' = n + fromIntegral (LL.length c - LL.length c') - check :: n -> Iteratee s m a -> Iteratee s m (a,n) - check !n iter = runIter iter (onDone n) - (onCont n) - (onErr n) - (onReq n) - step !n k str@(Chunk c) = k str >>= \res -> return $ case res of - (i, Chunk c') -> (check (newLen n c c') i, Chunk c') - (i, str'@(EOF (Just e))) -> (throwRec e (check (newLen n c mempty) i) - , str') - (i, str') -> (throwRec EofException - (check (newLen n c mempty) i), str') - step n k str = first (liftM (,n)) `liftM` k str - onDone n a = idone (a,n) - onCont n k = icont (step n k) - onErr n i e = throwRec e (check n i) - onReq n mb doB = ireq mb (check n . doB) + go :: n -> (Stream s -> Iteratee s m a) -> Stream s + -> Iteratee s m (a, n) + go !n f str@(EOF _) = (, n) `liftM` f str + go !n f str@(Chunk c) = Iteratee rI + where + newLen = n + fromIntegral (LL.length c) + rI od oc = runIter (f str) onDone onCont + where + onDone a str'@(Chunk c') = + od (a, newLen - fromIntegral (LL.length c')) str' + onDone a str'@(EOF _) = od (a, n) str' + onCont f' mExc = oc (go newLen f') mExc {-# INLINE countConsumed #-} -- ------------------------------------------------------------------------ @@ -978,13 +994,56 @@ where enum' str' iter' | LL.null str' = return iter' - | otherwise = let (s1, s2) = LL.splitAt n str' - onCont k = k (Chunk s1) >>= enum' s2 . fst - onErr i' e = return $ ierr i' e - onReq mb doB = mb >>= enum' str' . doB - in runIter iter' idoneM onCont onErr onReq + | otherwise = let (s1, s2) = LL.splitAt n str' + on_cont k Nothing = enum' s2 . k $ Chunk s1 + on_cont k e = return $ icont k e + in runIter iter' idoneM on_cont {-# INLINE enumPureNChunk #-} +-- | Convert an iteratee to a \"greedy\" version. +-- +-- When a chunk is received, repeatedly run the input iteratee +-- until the entire chunk is consumed, then the outputs +-- are combined (via 'mconcat'). +-- +-- > > let l = [1..5::Int] +-- > > run =<< enumPure1Chunk l (joinI (take 2 stream2list)) +-- > [1,2] +-- > > run =<< enumPure1Chunk l (greedy $ joinI (I.take 2 stream2list)) +-- > [1,2,3,4,5] +-- +-- Note that a greedy iteratee will consume the entire input chunk and force +-- the next chunk before returning a value. A portion of the second chunk may +-- be consumed. +-- +-- 'greedy' may be useful on the first parameter of 'convStream', e.g. +-- +-- > convStream (greedy someIter) +-- +-- to create more efficient converters. +greedy :: + (Monad m, Functor m, LL.ListLike s el', Monoid a) => + Iteratee s m a + -> Iteratee s m a +greedy iter' = liftI (step [] iter') + where + step acc iter (Chunk str) + | LL.null str = liftI (step acc iter) + | otherwise = joinIM $ do + i2 <- enumPure1Chunk str iter + result <- runIter i2 (\a s -> return $ Left (a,s)) + (\k e -> return $ Right (icont k e)) + case result of + Left (a, Chunk resS) + | LL.null resS + || LL.length resS == LL.length str -> return $ + idone (mconcat $ reverse (a:acc)) (Chunk resS) + Left (a, stream) -> return $ step (a:acc) iter stream + Right i -> return $ fmap (mconcat . reverse . (:acc)) i + step acc iter stream = joinIM $ + enumChunk stream (fmap (mconcat . reverse . (:acc)) iter) +{-# INLINE greedy #-} + -- ------------------------------------------------------------------------ -- Monadic functions @@ -994,11 +1053,11 @@ :: (Monad m, LL.ListLike s el, Nullable s) => (el -> m b) -> Iteratee s m () -mapM_ f = icont step +mapM_ f = liftI step where - step c@(Chunk xs) | LL.null xs = return (icont step, c) - step (Chunk xs) = LL.mapM_ f xs >> return (icont step, mempty) - step s@(EOF _) = return (idone (), s) + step (Chunk xs) | LL.null xs = liftI step + step (Chunk xs) = lift (LL.mapM_ f xs) >> liftI step + step s@(EOF _) = idone () s {-# INLINE mapM_ #-} -- |The analogue of @Control.Monad.foldM@ @@ -1007,10 +1066,11 @@ => (a -> b -> m a) -> a -> Iteratee s m a -foldM f e = icont (step e) +foldM f e = liftI step where - step acc c@(Chunk xs) | LL.null xs = return (icont (step acc), c) - step acc (Chunk xs) = CM.foldM f acc (LL.toList xs) >>= \acc' -> - return (icont (step acc'), mempty) - step acc stream = return (idone acc, stream) + step (Chunk xs) | LL.null xs = liftI step + step (Chunk xs) = do + x <- lift $ f e (LL.head xs) + joinIM $ enumPure1Chunk (LL.tail xs) (foldM f x) + step (EOF _) = return e {-# INLINE foldM #-} diff --git a/src/Data/Iteratee/PTerm.hs b/src/Data/Iteratee/PTerm.hs --- a/src/Data/Iteratee/PTerm.hs +++ b/src/Data/Iteratee/PTerm.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE RankNTypes +{-# LANGUAGE KindSignatures + ,RankNTypes ,FlexibleContexts - ,ScopedTypeVariables #-} + ,ScopedTypeVariables + ,BangPatterns + ,DeriveDataTypeable #-} -- | Enumeratees - pass terminals variant. -- @@ -23,12 +26,12 @@ -- In certain cases, this is not the desired behavior. Consider: -- -- > consumer :: Iteratee String IO () --- > consumer = icont (go 0) +-- > consumer = liftI (go 0) -- > where --- > go c (Chunk xs) = liftIO (putStr s) >> icont (go c) +-- > go c (Chunk xs) = liftIO (putStr s) >> liftI (go c) -- > go 10 e = liftIO (putStr "10 loops complete") -- > >> idone () (Chunk "") --- > go n e = I.seek 0 >> icont (go (n+1)) +-- > go n e = I.seek 0 >> liftI (go (n+1)) -- -- The @consumer@ iteratee does not complete until after it has received -- 10 @EOF@s. If you attempt to use it in a standard enumeratee, it will @@ -66,17 +69,14 @@ import qualified Data.ListLike as LL -import Control.Arrow ((***), first) +import Control.Applicative ((<$>)) +import Control.Exception import Control.Monad.Trans.Class -import Control.Monad import qualified Data.ByteString as B import Data.Monoid import Data.Word (Word8) -(<$>) :: Monad m => (a1 -> r) -> m a1 -> m r -(<$>) = liftM - -- --------------------------------------------------- -- The converters show a different way of composing two iteratees: -- `vertical' rather than `horizontal' @@ -85,14 +85,11 @@ -- -- A version of 'mapChunks' that sends 'EOF's to the inner iteratee. -- -mapChunksPT :: (NullPoint s, Monad m) => (s -> s') -> Enumeratee s s' m a -mapChunksPT f = go +mapChunksPT :: (NullPoint s) => (s -> s') -> Enumeratee s s' m a +mapChunksPT f = eneeCheckIfDonePass (icont . step) where - go = eneeCheckIfDonePass (icont . step) - step k (Chunk xs) = k (Chunk (f xs)) >>= \(i',_) -> - return (go i', Chunk empty) - step k (EOF mErr) = k (EOF mErr) >>= (\(i',_) -> - return (go i' , EOF mErr)) + step k (Chunk xs) = eneeCheckIfDonePass (icont . step) . k . Chunk $ f xs + step k (EOF mErr) = eneeCheckIfDonePass (icont . step) . k $ EOF mErr {-# INLINE mapChunksPT #-} -- | Convert a stream of @s@ to a stream of @s'@ using the supplied function. @@ -102,13 +99,11 @@ :: (Monad m, NullPoint s, Nullable s) => (s -> m s') -> Enumeratee s s' m a -mapChunksMPT f = go +mapChunksMPT f = eneeCheckIfDonePass (icont . step) where - go = eneeCheckIfDonePass (icont . step) - step k (Chunk xs) = f xs >>= k . Chunk >>= \(i', _str) -> - return (go i', Chunk empty) - step k (EOF mErr) = k (EOF mErr) >>= \(i',_) -> - return (go i', EOF mErr) + step k (Chunk xs) = lift (f xs) >>= + eneeCheckIfDonePass (icont . step) . k . Chunk + step k (EOF mErr) = eneeCheckIfDonePass (icont . step) . k $ EOF mErr {-# INLINE mapChunksMPT #-} -- |Convert one stream into another, not necessarily in lockstep. @@ -121,11 +116,13 @@ convStreamPT fi = go where go = eneeCheckIfDonePass check - check k = isStreamFinished >>= maybe (step k) + check k (Just e) = throwRecoverableErr e (const identity) + >> go (k $ Chunk empty) + check k _ = isStreamFinished >>= maybe (step k) (\e -> case fromException e of - Just EofException -> lift (k (EOF Nothing)) >>= go . fst - Nothing -> lift (k (EOF (Just e))) >>= go . fst) - step k = fi >>= lift . k . Chunk >>= go . fst + Just EofException -> go . k $ EOF Nothing + Nothing -> go . k . EOF $ Just e) + step k = fi >>= go . k . Chunk {-# INLINABLE convStreamPT #-} -- |The most general stream converter. @@ -139,38 +136,42 @@ unfoldConvStreamPT f acc0 = go acc0 where go acc = eneeCheckIfDonePass (check acc) - check acc k = isStreamFinished >>= maybe (step acc k) + check acc k (Just e) = throwRecoverableErr e (const identity) + >> go acc (k $ Chunk empty) + check acc k _ = isStreamFinished >>= maybe (step acc k) (\e -> case fromException e of - Just EofException -> lift (k (EOF Nothing)) - >>= go acc . fst - Nothing -> lift (k (EOF (Just e))) - >>= go acc . fst ) - step acc k = f acc - >>= \(acc',s') -> lift (k (Chunk s')) - >>= go acc' . fst -{-# INLINABLE unfoldConvStreamPT #-} + Just EofException -> go acc . k $ EOF Nothing + Nothing -> go acc . k . EOF $ Just e) + step acc k = f acc >>= \(acc', s') -> go acc' . k $ Chunk s' +{- + check acc k _ = isStreamFinished >>= + maybe (step acc k) (idone (liftI k) . EOF . Just) + step acc k = f acc >>= \(acc', s') -> + go acc' . k . Chunk $ s' +-} -- | A version of 'unfoldConvStreamCheck' that sends 'EOF's -- to the inner iteratee. unfoldConvStreamCheckPT :: (Monad m, Nullable elo) - => ((Cont eli m a -> Iteratee elo m (Iteratee eli m a)) + => (((Stream eli -> Iteratee eli m a) + -> Maybe SomeException + -> Iteratee elo m (Iteratee eli m a) + ) -> Enumeratee elo eli m a ) -> (acc -> Iteratee elo m (acc, eli)) -> acc -> Enumeratee elo eli m a -unfoldConvStreamCheckPT checkDone f acc0 = go acc0 +unfoldConvStreamCheckPT checkDone f acc0 = checkDone (check acc0) where - go acc = checkDone (check acc) - check acc k = isStreamFinished >>= maybe (step acc k) - (\e -> case fromException e of - Just EofException -> lift (k (EOF Nothing)) - >>= go acc . fst - Nothing -> lift (k (EOF (Just e))) >>= go acc . fst ) - step acc k = do - (acc',s') <- f acc - lift (k (Chunk s')) >>= go acc' . fst + check acc k mX = step acc k mX + step acc k Nothing = f acc >>= \(acc', s') -> + (checkDone (check acc') . k $ Chunk s') + step acc k (Just ex) = throwRecoverableErr ex $ \str' -> + let i = f acc >>= \(acc', s') -> + (checkDone (check acc') . k $ Chunk s') + in joinIM $ enumChunk str' i {-# INLINABLE unfoldConvStreamCheckPT #-} -- ------------------------------------- @@ -178,19 +179,18 @@ -- | A variant of 'Data.Iteratee.ListLike.breakE' that passes 'EOF's. breakEPT - :: (LL.ListLike s el, NullPoint s, Monad m) + :: (LL.ListLike s el, NullPoint s) => (el -> Bool) -> Enumeratee s s m a -breakEPT cpred = go +breakEPT cpred = eneeCheckIfDonePass (icont . step) where - go = eneeCheckIfDonePass (icont . step) - step k s'@(Chunk s) - | LL.null s = return (icont (step k), s') + step k (Chunk s) + | LL.null s = liftI (step k) | otherwise = case LL.break cpred s of (str', tail') - | LL.null tail' -> (go *** const mempty) <$> k (Chunk str') - | otherwise -> (idone *** const (Chunk tail')) <$> k (Chunk str') - step k stream = (idone *** const stream) <$> k stream + | LL.null tail' -> eneeCheckIfDonePass (icont . step) . k $ Chunk str' + | otherwise -> idone (k $ Chunk str') (Chunk tail') + step k stream = idone (k stream) stream {-# INLINE breakEPT #-} -- | A variant of 'Data.Iteratee.ListLike.take' that passes 'EOF's. @@ -199,61 +199,55 @@ => Int -- ^ number of elements to consume -> Enumeratee s s m a takePT n' iter - | n' <= 0 = return iter - | otherwise = runIter iter onDone onCont onErr onReq - where - onDone x = drop n' >> idone (idone x) - onCont k = if n' == 0 then idone (icont k) - else icont (step n' k) - onErr i = ierr (takePT n' i) - onReq mb doB = ireq mb (takePT n' . doB) - - step n k c@(Chunk str) - | LL.null str = return (icont (step n k), c) - | LL.length str <= n = (takePT (n - LL.length str) *** const mempty) - <$> k (Chunk str) - | otherwise = (idone *** const (Chunk s2)) <$> k (Chunk s1) + | n' <= 0 = return iter + | otherwise = Iteratee $ \od oc -> runIter iter (on_done od oc) (on_cont od oc) + where + on_done od oc x _ = runIter (drop n' >> return (return x)) od oc + on_cont od oc k Nothing = if n' == 0 then od (liftI k) (Chunk mempty) + else runIter (liftI (step n' k)) od oc + on_cont od oc _ (Just e) = runIter (drop n' >> throwErr e) od oc + step n k (Chunk str) + | LL.null str = liftI (step n k) + | LL.length str <= n = takePT (n - LL.length str) $ k (Chunk str) + | otherwise = idone (k (Chunk s1)) (Chunk s2) where (s1, s2) = LL.splitAt n str - step _n k stream = (idone *** const stream) <$> k stream + step _n k stream = idone (k stream) stream {-# INLINE takePT #-} -- | A variant of 'Data.Iteratee.ListLike.takeUpTo' that passes 'EOF's. takeUpToPT :: (Monad m, Nullable s, LL.ListLike s el) => Int -> Enumeratee s s m a takeUpToPT i iter - | i <= 0 = idone iter - | otherwise = runIter iter onDone onCont onErr onReq + | i <= 0 = idone iter (Chunk empty) + | otherwise = Iteratee $ \od oc -> + runIter iter (onDone od oc) (onCont od oc) where - onDone x = idone (idone x) - onCont k = if i == 0 then idone (icont k) - else icont (step i k) - onErr i' = ierr (takeUpToPT i i') - onReq mb doB = ireq mb (takeUpToPT i . doB) - - step n k c@(Chunk str) - | LL.null str = return (icont (step n k), c) - | LL.length str < n = first (takeUpToPT (n - LL.length str)) - <$> k (Chunk str) - | otherwise = do + onDone od oc x str = runIter (idone (return x) str) od oc + onCont od oc k Nothing = if i == 0 then od (liftI k) (Chunk mempty) + else runIter (liftI (step i k)) od oc + onCont od oc _ (Just e) = runIter (throwErr e) od oc + step n k (Chunk str) + | LL.null str = liftI (step n k) + | LL.length str < n = takeUpToPT (n - LL.length str) $ k (Chunk str) + | otherwise = -- check to see if the inner iteratee has completed, and if so, -- grab any remaining stream to put it in the outer iteratee. -- the outer iteratee is always complete at this stage, although -- the inner may not be. let (s1, s2) = LL.splitAt n str - (iter', preStr) <- k (Chunk s1) - case preStr of - (Chunk preC) - | LL.null preC -> return (idone iter', Chunk s2) - | otherwise -> return (idone iter' - , Chunk $ preC `LL.append` s2) - -- this case shouldn't ever happen, except possibly - -- with broken iteratees - _ -> return (idone iter', preStr) - step _ k stream = (idone *** const stream) <$> k stream + in Iteratee $ \od' _ -> do + res <- runIter (k (Chunk s1)) (\a s -> return $ Left (a, s)) + (\k' e -> return $ Right (k',e)) + case res of + Left (a,Chunk s1') -> od' (return a) + (Chunk $ s1' `LL.append` s2) + Left (a,s') -> od' (idone a s') (Chunk s2) + Right (k',e) -> od' (icont k' e) (Chunk s2) + step _ k stream = idone (k stream) stream {-# INLINE takeUpToPT #-} -- | A variant of 'Data.Iteratee.ListLike.takeWhileE' that passes 'EOF's. takeWhileEPT - :: (LL.ListLike s el, NullPoint s, Monad m) + :: (LL.ListLike s el, NullPoint s) => (el -> Bool) -> Enumeratee s s m a takeWhileEPT = breakEPT . (not .) @@ -264,25 +258,24 @@ :: (LL.ListLike (s el) el ,LL.ListLike (s el') el' ,NullPoint (s el) - ,Monad m ,LooseMap s el el') => (el -> el') -> Enumeratee (s el) (s el') m a mapStreamPT f = mapChunksPT (lMap f) -{-# SPECIALIZE mapStreamPT :: Monad m => (el -> el') -> Enumeratee [el] [el'] m a #-} +{-# SPECIALIZE mapStreamPT :: (el -> el') -> Enumeratee [el] [el'] m a #-} -- | A variant of 'Data.Iteratee.ListLike.rigidMapStream' that passes 'EOF's. rigidMapStreamPT - :: (LL.ListLike s el, Monad m, NullPoint s) + :: (LL.ListLike s el, NullPoint s) => (el -> el) -> Enumeratee s s m a rigidMapStreamPT f = mapChunksPT (LL.rigidMap f) -{-# SPECIALIZE rigidMapStreamPT :: Monad m => (el -> el) -> Enumeratee [el] [el] m a #-} -{-# SPECIALIZE rigidMapStreamPT :: Monad m => (Word8 -> Word8) -> Enumeratee B.ByteString B.ByteString m a #-} +{-# SPECIALIZE rigidMapStreamPT :: (el -> el) -> Enumeratee [el] [el] m a #-} +{-# SPECIALIZE rigidMapStreamPT :: (Word8 -> Word8) -> Enumeratee B.ByteString B.ByteString m a #-} -- | A variant of 'Data.Iteratee.ListLike.filter' that passes 'EOF's. filterPT - :: (Monad m, Nullable s, LL.ListLike s el) + :: (Monad m, Functor m, Nullable s, LL.ListLike s el) => (el -> Bool) -> Enumeratee s s m a filterPT p = convStreamPT (LL.filter p <$> getChunk) diff --git a/src/Data/Iteratee/Parallel.hs b/src/Data/Iteratee/Parallel.hs --- a/src/Data/Iteratee/Parallel.hs +++ b/src/Data/Iteratee/Parallel.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoMonomorphismRestriction, BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction, BangPatterns #-} module Data.Iteratee.Parallel ( psequence_ @@ -33,15 +33,15 @@ -- parallel Iteratee: E0, E1, E2, .. Ez -- \_ I0\_ I1\_ .. Iy\__ Iz -- -parI :: forall s a. (Nullable s, Monoid s) => Iteratee s IO a -> Iteratee s IO a -parI = icont . firstStep +parI :: (Nullable s, Monoid s) => Iteratee s IO a -> Iteratee s IO a +parI = liftI . firstStep where - -- first step, here we fork separate thread for the next chain and at the + -- first step, here we fork separete thread for the next chain and at the -- same time ask for more date from the previous chain firstStep iter chunk = do var <- liftIO newEmptyMVar _ <- sideStep var chunk iter - return (icont $ go var, mempty) + liftI $ go var -- somewhere in the middle, we are getting iteratee from previous step, -- feeding it with some new data, asking for more data and starting @@ -49,25 +49,19 @@ go var chunk@(Chunk _) = do iter <- liftIO $ takeMVar var _ <- sideStep var chunk iter - return (icont $ go var, mempty) + liftI $ go var -- final step - no more data, so we need to inform our consumer about it go var e = do iter <- liftIO $ takeMVar var - return (join . lift $ enumChunk e iter, e) + join . lift $ enumChunk e iter -- forks away from the main computation, return results via MVar - sideStep var chunk iter = liftIO . forkIO - $ runIter iter onDone onCont onErr onReq + sideStep var chunk iter = liftIO . forkIO $ runIter iter onDone onCont where - onDone a = putMVar var $ idone a - onCont k = k chunk >>= \(i',_) -> - runIter i' onDone onFina onErr onReq - onErr i e = putMVar var $ ierr i e - onReq :: IO x -> (x -> Iteratee s IO a) -> IO () - onReq mb doB = mb >>= \b -> - runIter (doB b) onDone onCont onErr onReq - onFina k = putMVar var $ icont k + onDone a s = putMVar var $ idone a s + onCont k _ = runIter (k chunk) onDone onFina + onFina k e = putMVar var $ icont k e -- | Transform an Enumeratee into a parallel composable one, introducing -- one step extra delay, see 'parI'. @@ -115,19 +109,19 @@ => Int -- ^ maximum number of chunks to read -> (s -> b) -- ^ map function -> Iteratee s m b -mapReduce bufsize f = icontP (step (0, [])) +mapReduce bufsize f = liftI (step (0, [])) where step a@(!buf,acc) (Chunk xs) - | nullC xs = (icontP (step a), Chunk xs) + | nullC xs = liftI (step a) | buf >= bufsize = let acc' = mconcat acc b' = f xs - in b' `par` acc' `pseq` (icontP (step (0,[b' `mappend` acc'])), Chunk empty) + in b' `par` acc' `pseq` liftI (step (0,[b' `mappend` acc'])) | otherwise = let b' = f xs - in b' `par` (icontP (step (succ buf,b':acc)), Chunk empty) + in b' `par` liftI (step (succ buf,b':acc)) step (_,acc) s@(EOF Nothing) = - (idone (mconcat acc), s) - step acc s@(EOF (Just err)) = - (throwRecoverableErr err (icontP $ step acc), s) + idone (mconcat acc) s + step acc (EOF (Just err)) = + throwRecoverableErr err (step acc) diff --git a/tests/benchmarks.hs b/tests/benchmarks.hs --- a/tests/benchmarks.hs +++ b/tests/benchmarks.hs @@ -212,11 +212,11 @@ conv1 = idN "convStream id head chunked" (I.joinI . I.convStream idChunk $ I.head) conv2 = idN "convStream id length chunked" (I.joinI . I.convStream idChunk $ I.length) -idChunk = I.icontP step +idChunk = I.liftI step where step (I.Chunk xs) - | LL.null xs = (idChunk, mempty) - | True = (idone xs, mempty) + | LL.null xs = idChunk + | True = idone xs (I.Chunk mempty) convBenches = [conv1, conv2] instance NFData BS.ByteString where diff --git a/tests/testIteratee.hs b/tests/testIteratee.hs --- a/tests/testIteratee.hs +++ b/tests/testIteratee.hs @@ -297,10 +297,10 @@ where types = (xs :: [Int]) convId :: (LL.ListLike s el, Monad m) => Iteratee s m s -convId = icontP (\str -> case str of - s@(Chunk xs) | LL.null xs -> (convId, s) - s@(Chunk xs) -> (idone xs, Chunk mempty) - s@(EOF e) -> (idone mempty, EOF e) +convId = liftI (\str -> case str of + s@(Chunk xs) | LL.null xs -> convId + s@(Chunk xs) -> idone xs (Chunk mempty) + s@(EOF e) -> idone mempty (EOF e) ) prop_convId xs = runner1 (enumPure1Chunk xs convId) == xs