foldl 1.0.9 → 1.0.10
raw patch · 7 files changed
+1318/−1295 lines, 7 filesdep +mwc-randomsetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: mwc-random
API changes (from Hackage documentation)
+ Control.Foldl: _Fold1 :: (a -> a -> a) -> Fold a (Maybe a)
+ Control.Foldl: random :: FoldM IO a (Maybe a)
Files
- LICENSE +24/−24
- Setup.hs +2/−2
- foldl.cabal +38/−37
- src/Control/Foldl.hs +827/−805
- src/Control/Foldl/ByteString.hs +198/−198
- src/Control/Foldl/Internal.hs +36/−36
- src/Control/Foldl/Text.hs +193/−193
LICENSE view
@@ -1,24 +1,24 @@-Copyright (c) 2013 Gabriel Gonzalez -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON -ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2013 Gabriel Gonzalez+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.+ * Neither the name of Gabriel Gonzalez nor the names of other contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
foldl.cabal view
@@ -1,37 +1,38 @@-Name: foldl -Version: 1.0.9 -Cabal-Version: >=1.8.0.2 -Build-Type: Simple -License: BSD3 -License-File: LICENSE -Copyright: 2013 Gabriel Gonzalez -Author: Gabriel Gonzalez -Maintainer: Gabriel439@gmail.com -Bug-Reports: https://github.com/Gabriel439/Haskell-Foldl-Library/issues -Synopsis: Composable, streaming, and efficient left folds -Description: This library provides strict left folds that stream in constant - memory, and you can combine folds using @Applicative@ style to derive new - folds. Derived folds still traverse the container just once and are often as - efficient as hand-written folds. -Category: Control -Source-Repository head - Type: git - Location: https://github.com/Gabriel439/Haskell-Foldl-Library - -Library - HS-Source-Dirs: src - Build-Depends: - base >= 4 && < 5 , - bytestring >= 0.9.2.1 && < 0.11, - primitive < 0.7 , - text >= 0.11.2.0 && < 1.3 , - transformers >= 0.2.0.0 && < 0.5 , - vector >= 0.7 && < 0.11, - containers < 0.6 - Exposed-Modules: - Control.Foldl, - Control.Foldl.ByteString, - Control.Foldl.Text - Other-Modules: - Control.Foldl.Internal - GHC-Options: -O2 -Wall +Name: foldl+Version: 1.0.10+Cabal-Version: >=1.8.0.2+Build-Type: Simple+License: BSD3+License-File: LICENSE+Copyright: 2013 Gabriel Gonzalez+Author: Gabriel Gonzalez+Maintainer: Gabriel439@gmail.com+Bug-Reports: https://github.com/Gabriel439/Haskell-Foldl-Library/issues+Synopsis: Composable, streaming, and efficient left folds+Description: This library provides strict left folds that stream in constant+ memory, and you can combine folds using @Applicative@ style to derive new+ folds. Derived folds still traverse the container just once and are often as+ efficient as hand-written folds.+Category: Control+Source-Repository head+ Type: git+ Location: https://github.com/Gabriel439/Haskell-Foldl-Library++Library+ HS-Source-Dirs: src+ Build-Depends:+ base >= 4 && < 5 ,+ bytestring >= 0.9.2.1 && < 0.11,+ mwc-random >= 0.13.1.0 && < 0.14,+ primitive < 0.7 ,+ text >= 0.11.2.0 && < 1.3 ,+ transformers >= 0.2.0.0 && < 0.5 ,+ vector >= 0.7 && < 0.11,+ containers < 0.6+ Exposed-Modules:+ Control.Foldl,+ Control.Foldl.ByteString,+ Control.Foldl.Text+ Other-Modules:+ Control.Foldl.Internal+ GHC-Options: -O2 -Wall
src/Control/Foldl.hs view
@@ -1,805 +1,827 @@-{-| This module provides efficient and streaming left folds that you can combine - using 'Applicative' style. - - Import this module qualified to avoid clashing with the Prelude: - ->>> import qualified Control.Foldl as L - - Use 'fold' to apply a 'Fold' to a list: - ->>> L.fold L.sum [1..100] -5050 - - 'Fold's are 'Applicative's, so you can combine them using 'Applicative' - combinators: - ->>> import Control.Applicative ->>> let average = (/) <$> L.sum <*> L.genericLength - - These combined folds will still traverse the list only once, streaming - efficiently over the list in constant space without space leaks: - ->>> L.fold average [1..10000000] -5000000.5 ->>> L.fold ((,) <$> L.minimum <*> L.maximum) [1..10000000] -(Just 1,Just 10000000) - --} - -{-# LANGUAGE ExistentialQuantification, RankNTypes, Trustworthy #-} - -module Control.Foldl ( - -- * Fold Types - Fold(..) - , FoldM(..) - - -- * Folding - , fold - , foldM - , scan - - -- * Folds - , Control.Foldl.mconcat - , Control.Foldl.foldMap - , head - , last - , lastDef - , null - , length - , and - , or - , all - , any - , sum - , product - , maximum - , minimum - , elem - , notElem - , find - , index - , elemIndex - , findIndex - - -- * Generic Folds - , genericLength - , genericIndex - - -- * Container folds - , list - , revList - , nub - , eqNub - , set - , vector - - -- * Utilities - -- $utilities - , purely - , impurely - , generalize - , simplify - , premap - , premapM - , pretraverse - , pretraverseM - - -- * Re-exports - -- $reexports - , module Control.Monad.Primitive - , module Data.Foldable - , module Data.Vector.Generic - ) where - -import Control.Applicative (Applicative(pure, (<*>)),liftA2) -import Control.Foldl.Internal (Maybe'(..), lazy, Either'(..), hush) -import Control.Monad ((<=<)) -import Control.Monad.Primitive (PrimMonad) -import Data.Foldable (Foldable) -import qualified Data.Foldable as F -import Data.Functor.Constant (Constant(Constant, getConstant)) -import Data.Functor.Identity (Identity, runIdentity) -import Data.Monoid (Monoid(mempty, mappend), Endo(Endo, appEndo)) -import Data.Vector.Generic (Vector) -import qualified Data.Vector.Generic as V -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.List as List -import qualified Data.Set as Set -import Prelude hiding - ( head - , last - , null - , length - , and - , or - , all - , any - , sum - , product - , maximum - , minimum - , elem - , notElem - ) - -{-| Efficient representation of a left fold that preserves the fold's step - function, initial accumulator, and extraction function - - This allows the 'Applicative' instance to assemble derived folds that - traverse the container only once - - A \''Fold' a b\' processes elements of type __a__ and results in a - value of type __b__. --} -data Fold a b - -- | @Fold @ @ step @ @ initial @ @ extract@ - = forall x. Fold (x -> a -> x) x (x -> b) - -data Pair a b = Pair !a !b - -instance Functor (Fold a) where - fmap f (Fold step begin done) = Fold step begin (f . done) - {-# INLINABLE fmap #-} - -instance Applicative (Fold a) where - pure b = Fold (\() _ -> ()) () (\() -> b) - {-# INLINABLE pure #-} - - (Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) = - let step (Pair xL xR) a = Pair (stepL xL a) (stepR xR a) - begin = Pair beginL beginR - done (Pair xL xR) = doneL xL (doneR xR) - in Fold step begin done - {-# INLINABLE (<*>) #-} - -instance Monoid b => Monoid (Fold a b) where - mempty = pure mempty - {-# INLINABLE mempty #-} - - mappend = liftA2 mappend - {-# INLINABLE mappend #-} - -instance Num b => Num (Fold a b) where - fromInteger = pure . fromInteger - {-# INLINABLE fromInteger #-} - - negate = fmap negate - {-# INLINABLE negate #-} - - abs = fmap abs - {-# INLINABLE abs #-} - - signum = fmap signum - {-# INLINABLE signum #-} - - (+) = liftA2 (+) - {-# INLINABLE (+) #-} - - (*) = liftA2 (*) - {-# INLINABLE (*) #-} - - (-) = liftA2 (-) - {-# INLINABLE (-) #-} - -instance Fractional b => Fractional (Fold a b) where - fromRational = pure . fromRational - {-# INLINABLE fromRational #-} - - recip = fmap recip - {-# INLINABLE recip #-} - - (/) = liftA2 (/) - {-# INLINABLE (/) #-} - -instance Floating b => Floating (Fold a b) where - pi = pure pi - {-# INLINABLE pi #-} - - exp = fmap exp - {-# INLINABLE exp #-} - - sqrt = fmap sqrt - {-# INLINABLE sqrt #-} - - log = fmap log - {-# INLINABLE log #-} - - sin = fmap sin - {-# INLINABLE sin #-} - - tan = fmap tan - {-# INLINABLE tan #-} - - cos = fmap cos - {-# INLINABLE cos #-} - - asin = fmap sin - {-# INLINABLE asin #-} - - atan = fmap atan - {-# INLINABLE atan #-} - - acos = fmap acos - {-# INLINABLE acos #-} - - sinh = fmap sinh - {-# INLINABLE sinh #-} - - tanh = fmap tanh - {-# INLINABLE tanh #-} - - cosh = fmap cosh - {-# INLINABLE cosh #-} - - asinh = fmap asinh - {-# INLINABLE asinh #-} - - atanh = fmap atanh - {-# INLINABLE atanh #-} - - acosh = fmap acosh - {-# INLINABLE acosh #-} - - (**) = liftA2 (**) - {-# INLINABLE (**) #-} - - logBase = liftA2 logBase - {-# INLINABLE logBase #-} - -{-| Like 'Fold', but monadic. - - A \''FoldM' m a b\' processes elements of type __a__ and - results in a monadic value of type __m b__. --} -data FoldM m a b = - -- | @FoldM @ @ step @ @ initial @ @ extract@ - forall x . FoldM (x -> a -> m x) (m x) (x -> m b) - -instance Monad m => Functor (FoldM m a) where - fmap f (FoldM step start done) = FoldM step start done' - where - done' x = do - b <- done x - return $! f b - {-# INLINABLE fmap #-} - -instance Monad m => Applicative (FoldM m a) where - pure b = FoldM (\() _ -> return ()) (return ()) (\() -> return b) - {-# INLINABLE pure #-} - - (FoldM stepL beginL doneL) <*> (FoldM stepR beginR doneR) = - let step (Pair xL xR) a = do - xL' <- stepL xL a - xR' <- stepR xR a - return $! Pair xL' xR' - begin = do - xL <- beginL - xR <- beginR - return $! Pair xL xR - done (Pair xL xR) = do - f <- doneL xL - x <- doneR xR - return $! f x - in FoldM step begin done - {-# INLINABLE (<*>) #-} - -instance (Monoid b, Monad m) => Monoid (FoldM m a b) where - mempty = pure mempty - {-# INLINABLE mempty #-} - - mappend = liftA2 mappend - {-# INLINABLE mappend #-} - -instance (Monad m, Num b) => Num (FoldM m a b) where - fromInteger = pure . fromInteger - {-# INLINABLE fromInteger #-} - - negate = fmap negate - {-# INLINABLE negate #-} - - abs = fmap abs - {-# INLINABLE abs #-} - - signum = fmap signum - {-# INLINABLE signum #-} - - (+) = liftA2 (+) - {-# INLINABLE (+) #-} - - (*) = liftA2 (*) - {-# INLINABLE (*) #-} - - (-) = liftA2 (-) - {-# INLINABLE (-) #-} - -instance (Monad m, Fractional b) => Fractional (FoldM m a b) where - fromRational = pure . fromRational - {-# INLINABLE fromRational #-} - - recip = fmap recip - {-# INLINABLE recip #-} - - (/) = liftA2 (/) - {-# INLINABLE (/) #-} - -instance (Monad m, Floating b) => Floating (FoldM m a b) where - pi = pure pi - {-# INLINABLE pi #-} - - exp = fmap exp - {-# INLINABLE exp #-} - - sqrt = fmap sqrt - {-# INLINABLE sqrt #-} - - log = fmap log - {-# INLINABLE log #-} - - sin = fmap sin - {-# INLINABLE sin #-} - - tan = fmap tan - {-# INLINABLE tan #-} - - cos = fmap cos - {-# INLINABLE cos #-} - - asin = fmap sin - {-# INLINABLE asin #-} - - atan = fmap atan - {-# INLINABLE atan #-} - - acos = fmap acos - {-# INLINABLE acos #-} - - sinh = fmap sinh - {-# INLINABLE sinh #-} - - tanh = fmap tanh - {-# INLINABLE tanh #-} - - cosh = fmap cosh - {-# INLINABLE cosh #-} - - asinh = fmap asinh - {-# INLINABLE asinh #-} - - atanh = fmap atanh - {-# INLINABLE atanh #-} - - acosh = fmap acosh - {-# INLINABLE acosh #-} - - (**) = liftA2 (**) - {-# INLINABLE (**) #-} - - logBase = liftA2 logBase - {-# INLINABLE logBase #-} - --- | Apply a strict left 'Fold' to a 'Foldable' container -fold :: Foldable f => Fold a b -> f a -> b -fold (Fold step begin done) as = F.foldr cons done as begin - where - cons a k x = k $! step x a -{-# INLINE fold #-} - --- | Like 'fold', but monadic -foldM :: (Foldable f, Monad m) => FoldM m a b -> f a -> m b -foldM (FoldM step begin done) as0 = do - x0 <- begin - F.foldr step' done as0 $! x0 - where - step' a k x = do - x' <- step x a - k $! x' -{-# INLINE foldM #-} - --- | Convert a strict left 'Fold' into a scan -scan :: Fold a b -> [a] -> [b] -scan (Fold step begin done) as = foldr cons nil as begin - where - nil x = done x:[] - cons a k x = done x:(k $! step x a) -{-# INLINE scan #-} - --- | Fold all values within a container using 'mappend' and 'mempty' -mconcat :: Monoid a => Fold a a -mconcat = Fold mappend mempty id -{-# INLINABLE mconcat #-} - --- | Convert a \"@foldMap@\" to a 'Fold' -foldMap :: Monoid w => (a -> w) -> (w -> b) -> Fold a b -foldMap to = Fold (\x a -> mappend x (to a)) mempty -{-# INLINABLE foldMap #-} - -{-| Get the first element of a container or return 'Nothing' if the container is - empty --} -head :: Fold a (Maybe a) -head = Fold step Nothing' lazy - where - step x a = case x of - Nothing' -> Just' a - _ -> x -{-# INLINABLE head #-} - -{-| Get the last element of a container or return 'Nothing' if the container is - empty --} -last :: Fold a (Maybe a) -last = Fold (const Just') Nothing' lazy -{-# INLINABLE last #-} - -{-| Get the last element of a container or return a default value if the container - is empty --} -lastDef :: a -> Fold a a -lastDef a = Fold (\_ a' -> a') a id -{-# INLINABLE lastDef #-} - --- | Returns 'True' if the container is empty, 'False' otherwise -null :: Fold a Bool -null = Fold (\_ _ -> False) True id -{-# INLINABLE null #-} - --- | Return the length of the container -length :: Fold a Int -length = genericLength -{- Technically, 'length' is just 'genericLength' specialized to 'Int's. I keep - the two separate so that I can later provide an 'Int'-specialized - implementation of 'length' for performance reasons like "GHC.List" does - without breaking backwards compatibility. --} -{-# INLINABLE length #-} - --- | Returns 'True' if all elements are 'True', 'False' otherwise -and :: Fold Bool Bool -and = Fold (&&) True id -{-# INLINABLE and #-} - --- | Returns 'True' if any element is 'True', 'False' otherwise -or :: Fold Bool Bool -or = Fold (||) False id -{-# INLINABLE or #-} - -{-| @(all predicate)@ returns 'True' if all elements satisfy the predicate, - 'False' otherwise --} -all :: (a -> Bool) -> Fold a Bool -all predicate = Fold (\x a -> x && predicate a) True id -{-# INLINABLE all #-} - -{-| @(any predicate)@ returns 'True' if any element satisfies the predicate, - 'False' otherwise --} -any :: (a -> Bool) -> Fold a Bool -any predicate = Fold (\x a -> x || predicate a) False id -{-# INLINABLE any #-} - --- | Computes the sum of all elements -sum :: Num a => Fold a a -sum = Fold (+) 0 id -{-# INLINABLE sum #-} - --- | Computes the product all elements -product :: Num a => Fold a a -product = Fold (*) 1 id -{-# INLINABLE product #-} - --- | Computes the maximum element -maximum :: Ord a => Fold a (Maybe a) -maximum = Fold step Nothing' lazy - where - step x a = Just' (case x of - Nothing' -> a - Just' a' -> max a' a) -{-# INLINABLE maximum #-} - --- | Computes the minimum element -minimum :: Ord a => Fold a (Maybe a) -minimum = Fold step Nothing' lazy - where - step x a = Just' (case x of - Nothing' -> a - Just' a' -> min a' a) -{-# INLINABLE minimum #-} - -{-| @(elem a)@ returns 'True' if the container has an element equal to @a@, - 'False' otherwise --} -elem :: Eq a => a -> Fold a Bool -elem a = any (a ==) -{-# INLINABLE elem #-} - -{-| @(notElem a)@ returns 'False' if the container has an element equal to @a@, - 'True' otherwise --} -notElem :: Eq a => a -> Fold a Bool -notElem a = all (a /=) -{-# INLINABLE notElem #-} - -{-| @(find predicate)@ returns the first element that satisfies the predicate or - 'Nothing' if no element satisfies the predicate --} -find :: (a -> Bool) -> Fold a (Maybe a) -find predicate = Fold step Nothing' lazy - where - step x a = case x of - Nothing' -> if predicate a then Just' a else Nothing' - _ -> x -{-# INLINABLE find #-} - -{-| @(index n)@ returns the @n@th element of the container, or 'Nothing' if the - container has an insufficient number of elements --} -index :: Int -> Fold a (Maybe a) -index = genericIndex -{-# INLINABLE index #-} - -{-| @(elemIndex a)@ returns the index of the first element that equals @a@, or - 'Nothing' if no element matches --} -elemIndex :: Eq a => a -> Fold a (Maybe Int) -elemIndex a = findIndex (a ==) -{-# INLINABLE elemIndex #-} - -{-| @(findIndex predicate)@ returns the index of the first element that - satisfies the predicate, or 'Nothing' if no element satisfies the predicate --} -findIndex :: (a -> Bool) -> Fold a (Maybe Int) -findIndex predicate = Fold step (Left' 0) hush - where - step x a = case x of - Left' i -> - if predicate a - then Right' i - else Left' (i + 1) - _ -> x -{-# INLINABLE findIndex #-} - --- | Like 'length', except with a more general 'Num' return value -genericLength :: Num b => Fold a b -genericLength = Fold (\n _ -> n + 1) 0 id -{-# INLINABLE genericLength #-} - --- | Like 'index', except with a more general 'Integral' argument -genericIndex :: Integral i => i -> Fold a (Maybe a) -genericIndex i = Fold step (Left' 0) done - where - step x a = case x of - Left' j -> if i == j then Right' a else Left' (j + 1) - _ -> x - done x = case x of - Left' _ -> Nothing - Right' a -> Just a -{-# INLINABLE genericIndex #-} - --- | Fold all values into a list -list :: Fold a [a] -list = Fold (\x a -> x . (a:)) id ($ []) -{-# INLINABLE list #-} - --- | Fold all values into a list, in reverse order -revList :: Fold a [a] -revList = Fold (\x a -> a:x) [] id -{-# INLINABLE revList #-} - -{-| /O(n log n)/. Fold values into a list with duplicates removed, while - preserving their first occurrences --} -nub :: Ord a => Fold a [a] -nub = Fold step (Pair Set.empty id) fin - where - step (Pair s r) a = if Set.member a s - then Pair s r - else Pair (Set.insert a s) (r . (a :)) - fin (Pair _ r) = r [] -{-# INLINABLE nub #-} - -{-| /O(n^2)/. Fold values into a list with duplicates removed, while preserving - their first occurrences --} -eqNub :: Eq a => Fold a [a] -eqNub = Fold step (Pair [] id) fin - where - step (Pair known r) a = if List.elem a known - then Pair known r - else Pair (a : known) (r . (a :)) - fin (Pair _ r) = r [] -{-# INLINABLE eqNub #-} - --- | Fold values into a set -set :: Ord a => Fold a (Set.Set a) -set = Fold (flip Set.insert) Set.empty id -{-# INLINABLE set #-} - -maxChunkSize :: Int -maxChunkSize = 8 * 1024 * 1024 - --- | Fold all values into a vector -vector :: (PrimMonad m, Vector v a) => FoldM m a (v a) -vector = FoldM step begin done - where - begin = do - mv <- M.unsafeNew 10 - return (Pair mv 0) - step (Pair mv idx) a = do - let len = M.length mv - mv' <- if idx >= len - then M.unsafeGrow mv (min len maxChunkSize) - else return mv - M.unsafeWrite mv' idx a - return (Pair mv' (idx + 1)) - done (Pair mv idx) = do - v <- V.unsafeFreeze mv - return (V.unsafeTake idx v) -{-# INLINABLE vector #-} - -{- $utilities - 'purely' and 'impurely' allow you to write folds compatible with the @foldl@ - library without incurring a @foldl@ dependency. Write your fold to accept - three parameters corresponding to the step function, initial - accumulator, and extraction function and then users can upgrade your - function to accept a 'Fold' or 'FoldM' using the 'purely' or 'impurely' - combinators. - - For example, the @pipes@ library implements a @foldM@ function in - @Pipes.Prelude@ with the following type: - -> foldM -> :: Monad m -> => (x -> a -> m x) -> m x -> (x -> m b) -> Producer a m () -> m b - - @foldM@ is set up so that you can wrap it with 'impurely' to accept a - 'FoldM' instead: - -> impurely foldM :: Monad m => FoldM m a b -> Producer a m () -> m b --} - --- | Upgrade a fold to accept the 'Fold' type -purely :: (forall x . (x -> a -> x) -> x -> (x -> b) -> r) -> Fold a b -> r -purely f (Fold step begin done) = f step begin done -{-# INLINABLE purely #-} - --- | Upgrade a monadic fold to accept the 'FoldM' type -impurely - :: Monad m - => (forall x . (x -> a -> m x) -> m x -> (x -> m b) -> r) - -> FoldM m a b - -> r -impurely f (FoldM step begin done) = f step begin done -{-# INLINABLE impurely #-} - -{-| Generalize a `Fold` to a `FoldM` - -> generalize (pure r) = pure r -> -> generalize (f <*> x) = generalize f <*> generalize x --} -generalize :: Monad m => Fold a b -> FoldM m a b -generalize (Fold step begin done) = FoldM step' begin' done' - where - step' x a = return (step x a) - begin' = return begin - done' x = return (done x) -{-# INLINABLE generalize #-} - -{-| Simplify a pure `FoldM` to a `Fold` - -> simplify (pure r) = pure r -> -> simplify (f <*> x) = simplify f <*> simplify x --} -simplify :: FoldM Identity a b -> Fold a b -simplify (FoldM step begin done) = Fold step' begin' done' - where - step' x a = runIdentity (step x a) - begin' = runIdentity begin - done' x = runIdentity (done x) -{-# INLINABLE simplify #-} - -{-| @(premap f folder)@ returns a new 'Fold' where f is applied at each step - -> fold (premap f folder) list = fold folder (map f list) - ->>> fold (premap Sum mconcat) [1..10] -Sum {getSum = 55} - ->>> fold mconcat (map Sum [1..10]) -Sum {getSum = 55} - -> premap id = id -> -> premap (f . g) = premap g . premap f - -> premap k (pure r) = pure r -> -> premap k (f <*> x) = premap k f <*> premap k x --} -premap :: (a -> b) -> Fold b r -> Fold a r -premap f (Fold step begin done) = Fold step' begin done - where - step' x a = step x (f a) -{-# INLINABLE premap #-} - -{-| @(premapM f folder)@ returns a new 'FoldM' where f is applied to each input - element - -> foldM (premapM f folder) list = foldM folder (map f list) - -> premapM id = id -> -> premapM (f . g) = premap g . premap f - -> premapM k (pure r) = pure r -> -> premapM k (f <*> x) = premapM k f <*> premapM k x --} -premapM :: Monad m => (a -> b) -> FoldM m b r -> FoldM m a r -premapM f (FoldM step begin done) = FoldM step' begin done - where - step' x a = step x (f a) -{-# INLINABLE premapM #-} - -type Traversal' a b = forall f . Applicative f => (b -> f b) -> a -> f a - -{-| @(pretraverse t folder)@ traverses each incoming element using @Traversal'@ - @t@ and folds every target of the @Traversal'@ - ->>> fold (pretraverse traverse sum) [[1..5],[6..10]] -55 - ->>> fold (pretraverse (traverse.traverse) sum) [[Nothing, Just 2, Just 7],[Just 13, Nothing, Just 20]] -42 - ->>> fold (pretraverse (filtered even) sum) [1,3,5,7,21,21] -42 - ->>> fold (pretraverse _2 mconcat) [(1,"Hello "),(2,"World"),(3,"!")] -"Hello World!" - -> pretraverse id = id -> -> pretraverse (f . g) = pretraverse f . pretraverse g - -> pretraverse t (pure r) = pure r -> -> pretraverse t (f <*> x) = pretraverse t f <*> pretraverse t x --} -pretraverse :: Traversal' a b -> Fold b r -> Fold a r -pretraverse k (Fold step begin done) = Fold step' begin done - where - step' = flip (appEndo . getConstant . k (Constant . Endo . flip step)) -{-# INLINABLE pretraverse #-} - -newtype EndoM m a = EndoM { appEndoM :: a -> m a } - -instance Monad m => Monoid (EndoM m a) where - mempty = EndoM return - mappend (EndoM f) (EndoM g) = EndoM (f <=< g) - -{-| @(pretraverseM t folder)@ traverses each incoming element using @Traversal'@ - @t@ and folds every target of the @Traversal'@ - -> pretraverseM id = id -> -> pretraverseM (f . g) = pretraverseM f . pretraverseM g - -> pretraverseM t (pure r) = pure r -> -> pretraverseM t (f <*> x) = pretraverseM t f <*> pretraverseM t x --} -pretraverseM :: Monad m => Traversal' a b -> FoldM m b r -> FoldM m a r -pretraverseM k (FoldM step begin done) = FoldM step' begin done - where - step' = flip (appEndoM . getConstant . k (Constant . EndoM . flip step)) -{-# INLINABLE pretraverseM #-} - -{- $reexports - @Control.Monad.Primitive@ re-exports the 'PrimMonad' type class - - @Data.Foldable@ re-exports the 'Foldable' type class - - @Data.Vector.Generic@ re-exports the 'Vector' type class --} +{-| This module provides efficient and streaming left folds that you can combine+ using 'Applicative' style.++ Import this module qualified to avoid clashing with the Prelude:++>>> import qualified Control.Foldl as L++ Use 'fold' to apply a 'Fold' to a list:++>>> L.fold L.sum [1..100]+5050++ 'Fold's are 'Applicative's, so you can combine them using 'Applicative'+ combinators:++>>> import Control.Applicative+>>> let average = (/) <$> L.sum <*> L.genericLength++ These combined folds will still traverse the list only once, streaming+ efficiently over the list in constant space without space leaks:++>>> L.fold average [1..10000000]+5000000.5+>>> L.fold ((,) <$> L.minimum <*> L.maximum) [1..10000000]+(Just 1,Just 10000000)++-}++{-# LANGUAGE ExistentialQuantification, RankNTypes, Trustworthy #-}++module Control.Foldl (+ -- * Fold Types+ Fold(..)+ , FoldM(..)++ -- * Folding+ , fold+ , foldM+ , scan++ -- * Folds+ , Control.Foldl.mconcat+ , Control.Foldl.foldMap+ , head+ , last+ , lastDef+ , null+ , length+ , and+ , or+ , all+ , any+ , sum+ , product+ , maximum+ , minimum+ , elem+ , notElem+ , find+ , index+ , elemIndex+ , findIndex+ , random++ -- * Generic Folds+ , genericLength+ , genericIndex++ -- * Container folds+ , list+ , revList+ , nub+ , eqNub+ , set+ , vector++ -- * Utilities+ -- $utilities+ , purely+ , impurely+ , generalize+ , simplify+ , _Fold1+ , premap+ , premapM+ , pretraverse+ , pretraverseM++ -- * Re-exports+ -- $reexports+ , module Control.Monad.Primitive+ , module Data.Foldable+ , module Data.Vector.Generic+ ) where++import Control.Applicative (Applicative(pure, (<*>)),liftA2)+import Control.Foldl.Internal (Maybe'(..), lazy, Either'(..), hush)+import Control.Monad ((<=<))+import Control.Monad.Primitive (PrimMonad)+import Data.Foldable (Foldable)+import qualified Data.Foldable as F+import Data.Functor.Constant (Constant(Constant, getConstant))+import Data.Functor.Identity (Identity, runIdentity)+import Data.Monoid (Monoid(mempty, mappend), Endo(Endo, appEndo))+import Data.Vector.Generic (Vector)+import qualified Data.Vector.Generic as V+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.List as List+import qualified Data.Set as Set+import System.Random.MWC (createSystemRandom, uniformR)+import Prelude hiding+ ( head+ , last+ , null+ , length+ , and+ , or+ , all+ , any+ , sum+ , product+ , maximum+ , minimum+ , elem+ , notElem+ )++{-| Efficient representation of a left fold that preserves the fold's step+ function, initial accumulator, and extraction function++ This allows the 'Applicative' instance to assemble derived folds that+ traverse the container only once++ A \''Fold' a b\' processes elements of type __a__ and results in a+ value of type __b__.+-}+data Fold a b+ -- | @Fold @ @ step @ @ initial @ @ extract@+ = forall x. Fold (x -> a -> x) x (x -> b)++data Pair a b = Pair !a !b++instance Functor (Fold a) where+ fmap f (Fold step begin done) = Fold step begin (f . done)+ {-# INLINABLE fmap #-}++instance Applicative (Fold a) where+ pure b = Fold (\() _ -> ()) () (\() -> b)+ {-# INLINABLE pure #-}++ (Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) =+ let step (Pair xL xR) a = Pair (stepL xL a) (stepR xR a)+ begin = Pair beginL beginR+ done (Pair xL xR) = doneL xL (doneR xR)+ in Fold step begin done+ {-# INLINABLE (<*>) #-}++instance Monoid b => Monoid (Fold a b) where+ mempty = pure mempty+ {-# INLINABLE mempty #-}++ mappend = liftA2 mappend+ {-# INLINABLE mappend #-}++instance Num b => Num (Fold a b) where+ fromInteger = pure . fromInteger+ {-# INLINABLE fromInteger #-}++ negate = fmap negate+ {-# INLINABLE negate #-}++ abs = fmap abs+ {-# INLINABLE abs #-}++ signum = fmap signum+ {-# INLINABLE signum #-}++ (+) = liftA2 (+)+ {-# INLINABLE (+) #-}++ (*) = liftA2 (*)+ {-# INLINABLE (*) #-}++ (-) = liftA2 (-)+ {-# INLINABLE (-) #-}++instance Fractional b => Fractional (Fold a b) where+ fromRational = pure . fromRational+ {-# INLINABLE fromRational #-}++ recip = fmap recip+ {-# INLINABLE recip #-}++ (/) = liftA2 (/)+ {-# INLINABLE (/) #-}++instance Floating b => Floating (Fold a b) where+ pi = pure pi+ {-# INLINABLE pi #-}++ exp = fmap exp+ {-# INLINABLE exp #-}++ sqrt = fmap sqrt+ {-# INLINABLE sqrt #-}++ log = fmap log+ {-# INLINABLE log #-}++ sin = fmap sin+ {-# INLINABLE sin #-}++ tan = fmap tan+ {-# INLINABLE tan #-}++ cos = fmap cos+ {-# INLINABLE cos #-}++ asin = fmap sin+ {-# INLINABLE asin #-}++ atan = fmap atan+ {-# INLINABLE atan #-}++ acos = fmap acos+ {-# INLINABLE acos #-}++ sinh = fmap sinh+ {-# INLINABLE sinh #-}++ tanh = fmap tanh+ {-# INLINABLE tanh #-}++ cosh = fmap cosh+ {-# INLINABLE cosh #-}++ asinh = fmap asinh+ {-# INLINABLE asinh #-}++ atanh = fmap atanh+ {-# INLINABLE atanh #-}++ acosh = fmap acosh+ {-# INLINABLE acosh #-}++ (**) = liftA2 (**)+ {-# INLINABLE (**) #-}++ logBase = liftA2 logBase+ {-# INLINABLE logBase #-}++{-| Like 'Fold', but monadic.++ A \''FoldM' m a b\' processes elements of type __a__ and+ results in a monadic value of type __m b__.+-}+data FoldM m a b =+ -- | @FoldM @ @ step @ @ initial @ @ extract@+ forall x . FoldM (x -> a -> m x) (m x) (x -> m b)++instance Monad m => Functor (FoldM m a) where+ fmap f (FoldM step start done) = FoldM step start done'+ where+ done' x = do+ b <- done x+ return $! f b+ {-# INLINABLE fmap #-}++instance Monad m => Applicative (FoldM m a) where+ pure b = FoldM (\() _ -> return ()) (return ()) (\() -> return b)+ {-# INLINABLE pure #-}++ (FoldM stepL beginL doneL) <*> (FoldM stepR beginR doneR) =+ let step (Pair xL xR) a = do+ xL' <- stepL xL a+ xR' <- stepR xR a+ return $! Pair xL' xR'+ begin = do+ xL <- beginL+ xR <- beginR+ return $! Pair xL xR+ done (Pair xL xR) = do+ f <- doneL xL+ x <- doneR xR+ return $! f x+ in FoldM step begin done+ {-# INLINABLE (<*>) #-}++instance (Monoid b, Monad m) => Monoid (FoldM m a b) where+ mempty = pure mempty+ {-# INLINABLE mempty #-}++ mappend = liftA2 mappend+ {-# INLINABLE mappend #-}++instance (Monad m, Num b) => Num (FoldM m a b) where+ fromInteger = pure . fromInteger+ {-# INLINABLE fromInteger #-}++ negate = fmap negate+ {-# INLINABLE negate #-}++ abs = fmap abs+ {-# INLINABLE abs #-}++ signum = fmap signum+ {-# INLINABLE signum #-}++ (+) = liftA2 (+)+ {-# INLINABLE (+) #-}++ (*) = liftA2 (*)+ {-# INLINABLE (*) #-}++ (-) = liftA2 (-)+ {-# INLINABLE (-) #-}++instance (Monad m, Fractional b) => Fractional (FoldM m a b) where+ fromRational = pure . fromRational+ {-# INLINABLE fromRational #-}++ recip = fmap recip+ {-# INLINABLE recip #-}++ (/) = liftA2 (/)+ {-# INLINABLE (/) #-}++instance (Monad m, Floating b) => Floating (FoldM m a b) where+ pi = pure pi+ {-# INLINABLE pi #-}++ exp = fmap exp+ {-# INLINABLE exp #-}++ sqrt = fmap sqrt+ {-# INLINABLE sqrt #-}++ log = fmap log+ {-# INLINABLE log #-}++ sin = fmap sin+ {-# INLINABLE sin #-}++ tan = fmap tan+ {-# INLINABLE tan #-}++ cos = fmap cos+ {-# INLINABLE cos #-}++ asin = fmap sin+ {-# INLINABLE asin #-}++ atan = fmap atan+ {-# INLINABLE atan #-}++ acos = fmap acos+ {-# INLINABLE acos #-}++ sinh = fmap sinh+ {-# INLINABLE sinh #-}++ tanh = fmap tanh+ {-# INLINABLE tanh #-}++ cosh = fmap cosh+ {-# INLINABLE cosh #-}++ asinh = fmap asinh+ {-# INLINABLE asinh #-}++ atanh = fmap atanh+ {-# INLINABLE atanh #-}++ acosh = fmap acosh+ {-# INLINABLE acosh #-}++ (**) = liftA2 (**)+ {-# INLINABLE (**) #-}++ logBase = liftA2 logBase+ {-# INLINABLE logBase #-}++-- | Apply a strict left 'Fold' to a 'Foldable' container+fold :: Foldable f => Fold a b -> f a -> b+fold (Fold step begin done) as = F.foldr cons done as begin+ where+ cons a k x = k $! step x a+{-# INLINE fold #-}++-- | Like 'fold', but monadic+foldM :: (Foldable f, Monad m) => FoldM m a b -> f a -> m b+foldM (FoldM step begin done) as0 = do+ x0 <- begin+ F.foldr step' done as0 $! x0+ where+ step' a k x = do+ x' <- step x a+ k $! x'+{-# INLINE foldM #-}++-- | Convert a strict left 'Fold' into a scan+scan :: Fold a b -> [a] -> [b]+scan (Fold step begin done) as = foldr cons nil as begin+ where+ nil x = done x:[]+ cons a k x = done x:(k $! step x a)+{-# INLINE scan #-}++-- | Fold all values within a container using 'mappend' and 'mempty'+mconcat :: Monoid a => Fold a a+mconcat = Fold mappend mempty id+{-# INLINABLE mconcat #-}++-- | Convert a \"@foldMap@\" to a 'Fold'+foldMap :: Monoid w => (a -> w) -> (w -> b) -> Fold a b+foldMap to = Fold (\x a -> mappend x (to a)) mempty+{-# INLINABLE foldMap #-}++{-| Get the first element of a container or return 'Nothing' if the container is+ empty+-}+head :: Fold a (Maybe a)+head = _Fold1 const+{-# INLINABLE head #-}++{-| Get the last element of a container or return 'Nothing' if the container is+ empty+-}+last :: Fold a (Maybe a)+last = _Fold1 (flip const)+{-# INLINABLE last #-}++{-| Get the last element of a container or return a default value if the container+ is empty+-}+lastDef :: a -> Fold a a+lastDef a = Fold (\_ a' -> a') a id+{-# INLINABLE lastDef #-}++-- | Returns 'True' if the container is empty, 'False' otherwise+null :: Fold a Bool+null = Fold (\_ _ -> False) True id+{-# INLINABLE null #-}++-- | Return the length of the container+length :: Fold a Int+length = genericLength+{- Technically, 'length' is just 'genericLength' specialized to 'Int's. I keep+ the two separate so that I can later provide an 'Int'-specialized+ implementation of 'length' for performance reasons like "GHC.List" does+ without breaking backwards compatibility.+-}+{-# INLINABLE length #-}++-- | Returns 'True' if all elements are 'True', 'False' otherwise+and :: Fold Bool Bool+and = Fold (&&) True id+{-# INLINABLE and #-}++-- | Returns 'True' if any element is 'True', 'False' otherwise+or :: Fold Bool Bool+or = Fold (||) False id+{-# INLINABLE or #-}++{-| @(all predicate)@ returns 'True' if all elements satisfy the predicate,+ 'False' otherwise+-}+all :: (a -> Bool) -> Fold a Bool+all predicate = Fold (\x a -> x && predicate a) True id+{-# INLINABLE all #-}++{-| @(any predicate)@ returns 'True' if any element satisfies the predicate,+ 'False' otherwise+-}+any :: (a -> Bool) -> Fold a Bool+any predicate = Fold (\x a -> x || predicate a) False id+{-# INLINABLE any #-}++-- | Computes the sum of all elements+sum :: Num a => Fold a a+sum = Fold (+) 0 id+{-# INLINABLE sum #-}++-- | Computes the product all elements+product :: Num a => Fold a a+product = Fold (*) 1 id+{-# INLINABLE product #-}++-- | Computes the maximum element+maximum :: Ord a => Fold a (Maybe a)+maximum = _Fold1 max+{-# INLINABLE maximum #-}++-- | Computes the minimum element+minimum :: Ord a => Fold a (Maybe a)+minimum = _Fold1 min+{-# INLINABLE minimum #-}++{-| @(elem a)@ returns 'True' if the container has an element equal to @a@,+ 'False' otherwise+-}+elem :: Eq a => a -> Fold a Bool+elem a = any (a ==)+{-# INLINABLE elem #-}++{-| @(notElem a)@ returns 'False' if the container has an element equal to @a@,+ 'True' otherwise+-}+notElem :: Eq a => a -> Fold a Bool+notElem a = all (a /=)+{-# INLINABLE notElem #-}++{-| @(find predicate)@ returns the first element that satisfies the predicate or+ 'Nothing' if no element satisfies the predicate+-}+find :: (a -> Bool) -> Fold a (Maybe a)+find predicate = Fold step Nothing' lazy+ where+ step x a = case x of+ Nothing' -> if predicate a then Just' a else Nothing'+ _ -> x+{-# INLINABLE find #-}++{-| @(index n)@ returns the @n@th element of the container, or 'Nothing' if the+ container has an insufficient number of elements+-}+index :: Int -> Fold a (Maybe a)+index = genericIndex+{-# INLINABLE index #-}++{-| @(elemIndex a)@ returns the index of the first element that equals @a@, or+ 'Nothing' if no element matches+-}+elemIndex :: Eq a => a -> Fold a (Maybe Int)+elemIndex a = findIndex (a ==)+{-# INLINABLE elemIndex #-}++{-| @(findIndex predicate)@ returns the index of the first element that+ satisfies the predicate, or 'Nothing' if no element satisfies the predicate+-}+findIndex :: (a -> Bool) -> Fold a (Maybe Int)+findIndex predicate = Fold step (Left' 0) hush+ where+ step x a = case x of+ Left' i ->+ if predicate a+ then Right' i+ else Left' (i + 1)+ _ -> x+{-# INLINABLE findIndex #-}++data Pair3 a b c = Pair3 !a !b !c++-- | Pick a random element, using reservoir sampling+random :: FoldM IO a (Maybe a)+random = FoldM step begin done+ where+ begin = do+ gen <- createSystemRandom+ return $! Pair3 gen Nothing' (1 :: Int)++ step (Pair3 gen Nothing' _) a = return $! Pair3 gen (Just' a) 2+ step (Pair3 gen (Just' a) m) b = do+ n <- uniformR (1, m) gen+ let c = if n == 1 then b else a+ return $! Pair3 gen (Just' c) (m + 1)++ done (Pair3 _ ma _) = return (lazy ma)+{-# INLINABLE random #-}++-- | Like 'length', except with a more general 'Num' return value+genericLength :: Num b => Fold a b+genericLength = Fold (\n _ -> n + 1) 0 id+{-# INLINABLE genericLength #-}++-- | Like 'index', except with a more general 'Integral' argument+genericIndex :: Integral i => i -> Fold a (Maybe a)+genericIndex i = Fold step (Left' 0) done+ where+ step x a = case x of+ Left' j -> if i == j then Right' a else Left' (j + 1)+ _ -> x+ done x = case x of+ Left' _ -> Nothing+ Right' a -> Just a+{-# INLINABLE genericIndex #-}++-- | Fold all values into a list+list :: Fold a [a]+list = Fold (\x a -> x . (a:)) id ($ [])+{-# INLINABLE list #-}++-- | Fold all values into a list, in reverse order+revList :: Fold a [a]+revList = Fold (\x a -> a:x) [] id+{-# INLINABLE revList #-}++{-| /O(n log n)/. Fold values into a list with duplicates removed, while+ preserving their first occurrences+-}+nub :: Ord a => Fold a [a]+nub = Fold step (Pair Set.empty id) fin+ where+ step (Pair s r) a = if Set.member a s+ then Pair s r+ else Pair (Set.insert a s) (r . (a :))+ fin (Pair _ r) = r []+{-# INLINABLE nub #-}++{-| /O(n^2)/. Fold values into a list with duplicates removed, while preserving+ their first occurrences+-}+eqNub :: Eq a => Fold a [a]+eqNub = Fold step (Pair [] id) fin+ where+ step (Pair known r) a = if List.elem a known+ then Pair known r+ else Pair (a : known) (r . (a :))+ fin (Pair _ r) = r []+{-# INLINABLE eqNub #-}++-- | Fold values into a set+set :: Ord a => Fold a (Set.Set a)+set = Fold (flip Set.insert) Set.empty id+{-# INLINABLE set #-}++maxChunkSize :: Int+maxChunkSize = 8 * 1024 * 1024++-- | Fold all values into a vector+vector :: (PrimMonad m, Vector v a) => FoldM m a (v a)+vector = FoldM step begin done+ where+ begin = do+ mv <- M.unsafeNew 10+ return (Pair mv 0)+ step (Pair mv idx) a = do+ let len = M.length mv+ mv' <- if idx >= len+ then M.unsafeGrow mv (min len maxChunkSize)+ else return mv+ M.unsafeWrite mv' idx a+ return (Pair mv' (idx + 1))+ done (Pair mv idx) = do+ v <- V.unsafeFreeze mv+ return (V.unsafeTake idx v)+{-# INLINABLE vector #-}++{- $utilities+ 'purely' and 'impurely' allow you to write folds compatible with the @foldl@+ library without incurring a @foldl@ dependency. Write your fold to accept+ three parameters corresponding to the step function, initial+ accumulator, and extraction function and then users can upgrade your+ function to accept a 'Fold' or 'FoldM' using the 'purely' or 'impurely'+ combinators.++ For example, the @pipes@ library implements a @foldM@ function in+ @Pipes.Prelude@ with the following type:++> foldM+> :: Monad m+> => (x -> a -> m x) -> m x -> (x -> m b) -> Producer a m () -> m b++ @foldM@ is set up so that you can wrap it with 'impurely' to accept a+ 'FoldM' instead:++> impurely foldM :: Monad m => FoldM m a b -> Producer a m () -> m b+-}++-- | Upgrade a fold to accept the 'Fold' type+purely :: (forall x . (x -> a -> x) -> x -> (x -> b) -> r) -> Fold a b -> r+purely f (Fold step begin done) = f step begin done+{-# INLINABLE purely #-}++-- | Upgrade a monadic fold to accept the 'FoldM' type+impurely+ :: Monad m+ => (forall x . (x -> a -> m x) -> m x -> (x -> m b) -> r)+ -> FoldM m a b+ -> r+impurely f (FoldM step begin done) = f step begin done+{-# INLINABLE impurely #-}++{-| Generalize a `Fold` to a `FoldM`++> generalize (pure r) = pure r+>+> generalize (f <*> x) = generalize f <*> generalize x+-}+generalize :: Monad m => Fold a b -> FoldM m a b+generalize (Fold step begin done) = FoldM step' begin' done'+ where+ step' x a = return (step x a)+ begin' = return begin+ done' x = return (done x)+{-# INLINABLE generalize #-}++{-| Simplify a pure `FoldM` to a `Fold`++> simplify (pure r) = pure r+>+> simplify (f <*> x) = simplify f <*> simplify x+-}+simplify :: FoldM Identity a b -> Fold a b+simplify (FoldM step begin done) = Fold step' begin' done'+ where+ step' x a = runIdentity (step x a)+ begin' = runIdentity begin+ done' x = runIdentity (done x)+{-# INLINABLE simplify #-}++{-| @_Fold1 step@ returns a new 'Fold' using just a step function that has the+same type for the accumulator and the element. The result type is the+accumulator type wrapped in 'Maybe'. The initial accumulator is retrieved from+the 'Foldable', the result is 'None' for empty containers.+ -}+_Fold1 :: (a -> a -> a) -> Fold a (Maybe a)+_Fold1 step = Fold step_ Nothing' lazy+ where+ step_ mx a = Just' (case mx of+ Nothing' -> a+ Just' x -> step x a)++{-| @(premap f folder)@ returns a new 'Fold' where f is applied at each step++> fold (premap f folder) list = fold folder (map f list)++>>> fold (premap Sum mconcat) [1..10]+Sum {getSum = 55}++>>> fold mconcat (map Sum [1..10])+Sum {getSum = 55}++> premap id = id+>+> premap (f . g) = premap g . premap f++> premap k (pure r) = pure r+>+> premap k (f <*> x) = premap k f <*> premap k x+-}+premap :: (a -> b) -> Fold b r -> Fold a r+premap f (Fold step begin done) = Fold step' begin done+ where+ step' x a = step x (f a)+{-# INLINABLE premap #-}++{-| @(premapM f folder)@ returns a new 'FoldM' where f is applied to each input+ element++> foldM (premapM f folder) list = foldM folder (map f list)++> premapM id = id+>+> premapM (f . g) = premap g . premap f++> premapM k (pure r) = pure r+>+> premapM k (f <*> x) = premapM k f <*> premapM k x+-}+premapM :: Monad m => (a -> b) -> FoldM m b r -> FoldM m a r+premapM f (FoldM step begin done) = FoldM step' begin done+ where+ step' x a = step x (f a)+{-# INLINABLE premapM #-}++type Traversal' a b = forall f . Applicative f => (b -> f b) -> a -> f a++{-| @(pretraverse t folder)@ traverses each incoming element using @Traversal'@+ @t@ and folds every target of the @Traversal'@++>>> fold (pretraverse traverse sum) [[1..5],[6..10]]+55++>>> fold (pretraverse (traverse.traverse) sum) [[Nothing, Just 2, Just 7],[Just 13, Nothing, Just 20]]+42++>>> fold (pretraverse (filtered even) sum) [1,3,5,7,21,21]+42++>>> fold (pretraverse _2 mconcat) [(1,"Hello "),(2,"World"),(3,"!")]+"Hello World!"++> pretraverse id = id+>+> pretraverse (f . g) = pretraverse f . pretraverse g++> pretraverse t (pure r) = pure r+>+> pretraverse t (f <*> x) = pretraverse t f <*> pretraverse t x+-}+pretraverse :: Traversal' a b -> Fold b r -> Fold a r+pretraverse k (Fold step begin done) = Fold step' begin done+ where+ step' = flip (appEndo . getConstant . k (Constant . Endo . flip step))+{-# INLINABLE pretraverse #-}++newtype EndoM m a = EndoM { appEndoM :: a -> m a }++instance Monad m => Monoid (EndoM m a) where+ mempty = EndoM return+ mappend (EndoM f) (EndoM g) = EndoM (f <=< g)++{-| @(pretraverseM t folder)@ traverses each incoming element using @Traversal'@+ @t@ and folds every target of the @Traversal'@++> pretraverseM id = id+>+> pretraverseM (f . g) = pretraverseM f . pretraverseM g++> pretraverseM t (pure r) = pure r+>+> pretraverseM t (f <*> x) = pretraverseM t f <*> pretraverseM t x+-}+pretraverseM :: Monad m => Traversal' a b -> FoldM m b r -> FoldM m a r+pretraverseM k (FoldM step begin done) = FoldM step' begin done+ where+ step' = flip (appEndoM . getConstant . k (Constant . EndoM . flip step))+{-# INLINABLE pretraverseM #-}++{- $reexports+ @Control.Monad.Primitive@ re-exports the 'PrimMonad' type class++ @Data.Foldable@ re-exports the 'Foldable' type class++ @Data.Vector.Generic@ re-exports the 'Vector' type class+-}
src/Control/Foldl/ByteString.hs view
@@ -1,198 +1,198 @@--- | Folds for byte streams - -module Control.Foldl.ByteString ( - -- * Folding - fold - - -- * Folds - , head - , last - , null - , length - , any - , all - , maximum - , minimum - , elem - , notElem - , find - , index - , elemIndex - , findIndex - , count - - -- * Re-exports - -- $reexports - , module Control.Foldl - , module Data.ByteString - , module Data.Word - ) where - -import Control.Foldl (Fold) -import Control.Foldl.Internal (Maybe'(..), lazy, strict, Either'(..), hush) -import qualified Control.Foldl as L -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy.Internal as Lazy -import qualified Data.ByteString.Unsafe as BU -import Data.Word (Word8) -import Prelude hiding ( - head, last, null, length, any, all, maximum, minimum, elem, notElem ) - --- | Appply a strict left 'Fold' to a lazy bytestring -fold :: Fold ByteString a -> Lazy.ByteString -> a -fold (L.Fold step begin done) as = done (Lazy.foldlChunks step begin as) -{-# INLINABLE fold #-} - -{-| Get the first byte of a byte stream or return 'Nothing' if the stream is - empty --} -head :: Fold ByteString (Maybe Word8) -head = L.Fold step Nothing' lazy - where - step mw8 bs = - if B.null bs - then mw8 - else case mw8 of - Just' _ -> mw8 - Nothing' -> Just' (BU.unsafeHead bs) -{-# INLINABLE head #-} - -{-| Get the last byte of a byte stream or return 'Nothing' if the byte stream is - empty --} -last :: Fold ByteString (Maybe Word8) -last = L.Fold step Nothing' lazy - where - step mw8 bs = - if B.null bs - then mw8 - else Just' (B.last bs) - -- TODO: Use `unsafeLast` when Debian Stable Haskell Platform has it -{-# INLINABLE last #-} - --- | Returns 'True' if the byte stream is empty, 'False' otherwise -null :: Fold ByteString Bool -null = L.Fold step True id - where - step isNull bs = isNull && B.null bs -{-# INLINABLE null #-} - --- | Return the length of the byte stream in bytes -length :: Num n => Fold ByteString n -length = L.Fold (\n bs -> n + fromIntegral (B.length bs)) 0 id -{-# INLINABLE length #-} - -{-| @(all predicate)@ returns 'True' if all bytes satisfy the predicate, 'False' - otherwise --} -all :: (Word8 -> Bool) -> Fold ByteString Bool -all predicate = L.Fold (\b bs -> b && B.all predicate bs) True id -{-# INLINABLE all #-} - -{-| @(any predicate)@ returns 'True' if any byte satisfies the predicate, - 'False' otherwise --} -any :: (Word8 -> Bool) -> Fold ByteString Bool -any predicate = L.Fold (\b bs -> b || B.any predicate bs) False id -{-# INLINABLE any #-} - --- | Computes the maximum byte -maximum :: Fold ByteString (Maybe Word8) -maximum = L.Fold step Nothing' lazy - where - step mw8 bs = - if B.null bs - then mw8 - else Just' (case mw8 of - Nothing' -> B.maximum bs - Just' w8 -> max w8 (B.maximum bs) ) -{-# INLINABLE maximum #-} - --- | Computes the minimum byte -minimum :: Fold ByteString (Maybe Word8) -minimum = L.Fold step Nothing' lazy - where - step mw8 bs = - if B.null bs - then mw8 - else Just' (case mw8 of - Nothing' -> B.minimum bs - Just' w8 -> min w8 (B.minimum bs) ) -{-# INLINABLE minimum #-} - -{-| @(elem w8)@ returns 'True' if the byte stream has a byte equal to @w8@, - 'False' otherwise --} -elem :: Word8 -> Fold ByteString Bool -elem w8 = any (w8 ==) -{-# INLINABLE elem #-} - -{-| @(notElem w8)@ returns 'False' if the byte stream has a byte equal to @w8@, - 'True' otherwise --} -notElem :: Word8 -> Fold ByteString Bool -notElem w8 = all (w8 /=) -{-# INLINABLE notElem #-} - -{-| @(find predicate)@ returns the first byte that satisfies the predicate or - 'Nothing' if no byte satisfies the predicate --} -find :: (Word8 -> Bool) -> Fold ByteString (Maybe Word8) -find predicate = L.Fold step Nothing' lazy - where - step mw8 bs = case mw8 of - Nothing' -> strict (B.find predicate bs) - Just' _ -> mw8 -{-# INLINABLE find #-} - -{-| @(index n)@ returns the @n@th byte of the byte stream, or 'Nothing' if the - stream has an insufficient number of bytes --} -index :: Integral n => n -> Fold ByteString (Maybe Word8) -index i = L.Fold step (Left' (fromIntegral i)) hush - where - step x bs = case x of - Left' remainder -> - let len = B.length bs - in if remainder < len - then Right' (BU.unsafeIndex bs remainder) - else Left' (remainder - len) - _ -> x -{-# INLINABLE index #-} - -{-| @(elemIndex w8)@ returns the index of the first byte that equals @w8@, or - 'Nothing' if no byte matches --} -elemIndex :: Num n => Word8 -> Fold ByteString (Maybe n) -elemIndex w8 = findIndex (w8 ==) -{-# INLINABLE elemIndex #-} - -{-| @(findIndex predicate)@ returns the index of the first byte that satisfies - the predicate, or 'Nothing' if no byte satisfies the predicate --} -findIndex :: Num n => (Word8 -> Bool) -> Fold ByteString (Maybe n) -findIndex predicate = L.Fold step (Left' 0) hush - where - step x bs = case x of - Left' m -> case B.findIndex predicate bs of - Nothing -> Left' (m + fromIntegral (B.length bs)) - Just n -> Right' (m + fromIntegral n) - _ -> x -{-# INLINABLE findIndex #-} - --- | @count w8@ returns the number of times @w8@ appears -count :: Num n => Word8 -> Fold ByteString n -count w8 = L.Fold step 0 id - where - step n bs = n + fromIntegral (B.count w8 bs) -{-# INLINABLE count #-} - -{- $reexports - - "Control.Foldl" re-exports the 'Fold' type - - @Data.ByteString@ re-exports the 'ByteString' type - - @Data.Word@ re-exports the 'Word8' type --} +-- | Folds for byte streams++module Control.Foldl.ByteString (+ -- * Folding+ fold++ -- * Folds+ , head+ , last+ , null+ , length+ , any+ , all+ , maximum+ , minimum+ , elem+ , notElem+ , find+ , index+ , elemIndex+ , findIndex+ , count++ -- * Re-exports+ -- $reexports+ , module Control.Foldl+ , module Data.ByteString+ , module Data.Word+ ) where++import Control.Foldl (Fold)+import Control.Foldl.Internal (Maybe'(..), lazy, strict, Either'(..), hush)+import qualified Control.Foldl as L+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy.Internal as Lazy+import qualified Data.ByteString.Unsafe as BU+import Data.Word (Word8)+import Prelude hiding (+ head, last, null, length, any, all, maximum, minimum, elem, notElem )++-- | Apply a strict left 'Fold' to a lazy bytestring+fold :: Fold ByteString a -> Lazy.ByteString -> a+fold (L.Fold step begin done) as = done (Lazy.foldlChunks step begin as)+{-# INLINABLE fold #-}++{-| Get the first byte of a byte stream or return 'Nothing' if the stream is+ empty+-}+head :: Fold ByteString (Maybe Word8)+head = L.Fold step Nothing' lazy+ where+ step mw8 bs =+ if B.null bs+ then mw8+ else case mw8 of+ Just' _ -> mw8+ Nothing' -> Just' (BU.unsafeHead bs)+{-# INLINABLE head #-}++{-| Get the last byte of a byte stream or return 'Nothing' if the byte stream is+ empty+-}+last :: Fold ByteString (Maybe Word8)+last = L.Fold step Nothing' lazy+ where+ step mw8 bs =+ if B.null bs+ then mw8+ else Just' (B.last bs)+ -- TODO: Use `unsafeLast` when Debian Stable Haskell Platform has it+{-# INLINABLE last #-}++-- | Returns 'True' if the byte stream is empty, 'False' otherwise+null :: Fold ByteString Bool+null = L.Fold step True id+ where+ step isNull bs = isNull && B.null bs+{-# INLINABLE null #-}++-- | Return the length of the byte stream in bytes+length :: Num n => Fold ByteString n+length = L.Fold (\n bs -> n + fromIntegral (B.length bs)) 0 id+{-# INLINABLE length #-}++{-| @(all predicate)@ returns 'True' if all bytes satisfy the predicate, 'False'+ otherwise+-}+all :: (Word8 -> Bool) -> Fold ByteString Bool+all predicate = L.Fold (\b bs -> b && B.all predicate bs) True id+{-# INLINABLE all #-}++{-| @(any predicate)@ returns 'True' if any byte satisfies the predicate,+ 'False' otherwise+-}+any :: (Word8 -> Bool) -> Fold ByteString Bool+any predicate = L.Fold (\b bs -> b || B.any predicate bs) False id+{-# INLINABLE any #-}++-- | Computes the maximum byte+maximum :: Fold ByteString (Maybe Word8)+maximum = L.Fold step Nothing' lazy+ where+ step mw8 bs =+ if B.null bs+ then mw8+ else Just' (case mw8 of+ Nothing' -> B.maximum bs+ Just' w8 -> max w8 (B.maximum bs) )+{-# INLINABLE maximum #-}++-- | Computes the minimum byte+minimum :: Fold ByteString (Maybe Word8)+minimum = L.Fold step Nothing' lazy+ where+ step mw8 bs =+ if B.null bs+ then mw8+ else Just' (case mw8 of+ Nothing' -> B.minimum bs+ Just' w8 -> min w8 (B.minimum bs) )+{-# INLINABLE minimum #-}++{-| @(elem w8)@ returns 'True' if the byte stream has a byte equal to @w8@,+ 'False' otherwise+-}+elem :: Word8 -> Fold ByteString Bool+elem w8 = any (w8 ==)+{-# INLINABLE elem #-}++{-| @(notElem w8)@ returns 'False' if the byte stream has a byte equal to @w8@,+ 'True' otherwise+-}+notElem :: Word8 -> Fold ByteString Bool+notElem w8 = all (w8 /=)+{-# INLINABLE notElem #-}++{-| @(find predicate)@ returns the first byte that satisfies the predicate or+ 'Nothing' if no byte satisfies the predicate+-}+find :: (Word8 -> Bool) -> Fold ByteString (Maybe Word8)+find predicate = L.Fold step Nothing' lazy+ where+ step mw8 bs = case mw8 of+ Nothing' -> strict (B.find predicate bs)+ Just' _ -> mw8+{-# INLINABLE find #-}++{-| @(index n)@ returns the @n@th byte of the byte stream, or 'Nothing' if the+ stream has an insufficient number of bytes+-}+index :: Integral n => n -> Fold ByteString (Maybe Word8)+index i = L.Fold step (Left' (fromIntegral i)) hush+ where+ step x bs = case x of+ Left' remainder ->+ let len = B.length bs+ in if remainder < len+ then Right' (BU.unsafeIndex bs remainder)+ else Left' (remainder - len)+ _ -> x+{-# INLINABLE index #-}++{-| @(elemIndex w8)@ returns the index of the first byte that equals @w8@, or+ 'Nothing' if no byte matches+-}+elemIndex :: Num n => Word8 -> Fold ByteString (Maybe n)+elemIndex w8 = findIndex (w8 ==)+{-# INLINABLE elemIndex #-}++{-| @(findIndex predicate)@ returns the index of the first byte that satisfies+ the predicate, or 'Nothing' if no byte satisfies the predicate+-}+findIndex :: Num n => (Word8 -> Bool) -> Fold ByteString (Maybe n)+findIndex predicate = L.Fold step (Left' 0) hush+ where+ step x bs = case x of+ Left' m -> case B.findIndex predicate bs of+ Nothing -> Left' (m + fromIntegral (B.length bs))+ Just n -> Right' (m + fromIntegral n)+ _ -> x+{-# INLINABLE findIndex #-}++-- | @count w8@ returns the number of times @w8@ appears+count :: Num n => Word8 -> Fold ByteString n+count w8 = L.Fold step 0 id+ where+ step n bs = n + fromIntegral (B.count w8 bs)+{-# INLINABLE count #-}++{- $reexports++ "Control.Foldl" re-exports the 'Fold' type++ @Data.ByteString@ re-exports the 'ByteString' type++ @Data.Word@ re-exports the 'Word8' type+-}
src/Control/Foldl/Internal.hs view
@@ -1,36 +1,36 @@--- | Strict data types for use as internal accumulators that don't space leak - -module Control.Foldl.Internal ( - -- * Strict maybe - Maybe'(..) - , lazy - , strict - - -- * Strict Either - , Either'(..) - , hush - ) where - --- | A strict 'Maybe' -data Maybe' a = Just' !a | Nothing' - --- | Convert 'Maybe'' to 'Maybe' -lazy :: Maybe' a -> Maybe a -lazy Nothing' = Nothing -lazy (Just' a) = Just a -{-# INLINABLE lazy #-} - --- | Convert 'Maybe' to 'Maybe'' -strict :: Maybe a -> Maybe' a -strict Nothing = Nothing' -strict (Just a ) = Just' a -{-# INLINABLE strict #-} - --- | A strict 'Either' -data Either' a b = Left' !a | Right' !b - --- | Convert 'Either'' to 'Maybe' -hush :: Either' a b -> Maybe b -hush (Left' _) = Nothing -hush (Right' b) = Just b -{-# INLINABLE hush #-} +-- | Strict data types for use as internal accumulators that don't space leak++module Control.Foldl.Internal (+ -- * Strict maybe+ Maybe'(..)+ , lazy+ , strict++ -- * Strict Either+ , Either'(..)+ , hush+ ) where++-- | A strict 'Maybe'+data Maybe' a = Just' !a | Nothing'++-- | Convert 'Maybe'' to 'Maybe'+lazy :: Maybe' a -> Maybe a+lazy Nothing' = Nothing+lazy (Just' a) = Just a+{-# INLINABLE lazy #-}++-- | Convert 'Maybe' to 'Maybe''+strict :: Maybe a -> Maybe' a+strict Nothing = Nothing'+strict (Just a ) = Just' a+{-# INLINABLE strict #-}++-- | A strict 'Either'+data Either' a b = Left' !a | Right' !b++-- | Convert 'Either'' to 'Maybe'+hush :: Either' a b -> Maybe b+hush (Left' _) = Nothing+hush (Right' b) = Just b+{-# INLINABLE hush #-}
src/Control/Foldl/Text.hs view
@@ -1,193 +1,193 @@--- | Folds for text streams - -module Control.Foldl.Text ( - -- * Folding - fold - - -- * Folds - , head - , last - , null - , length - , any - , all - , maximum - , minimum - , elem - , notElem - , find - , index - , elemIndex - , findIndex - , count - - -- * Re-exports - -- $reexports - , module Control.Foldl - , module Data.Text - ) where - -import Control.Foldl (Fold) -import Control.Foldl.Internal (Maybe'(..), lazy, strict, Either'(..), hush) -import qualified Control.Foldl as L -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as Lazy -import Prelude hiding ( - head, last, null, length, any, all, maximum, minimum, elem, notElem ) - --- | Apply a strict left 'Fold' to lazy text -fold :: Fold Text a -> Lazy.Text -> a -fold (L.Fold step begin done) as = done (Lazy.foldlChunks step begin as) -{-# INLINABLE fold #-} - -{-| Get the first character of a text stream or return 'Nothing' if the stream - is empty --} -head :: Fold Text (Maybe Char) -head = L.Fold step Nothing' lazy - where - step mc txt = - if T.null txt - then mc - else case mc of - Just' _ -> mc - Nothing' -> Just' (T.head txt) -{-# INLINABLE head #-} - -{-| Get the last character of a text stream or return 'Nothing' if the text - stream is empty --} -last :: Fold Text (Maybe Char) -last = L.Fold step Nothing' lazy - where - step mc txt = - if T.null txt - then mc - else Just' (T.last txt) - -- TODO: Use `unsafeLast` when Debian Stable Haskell Platform has it -{-# INLINABLE last #-} - --- | Returns 'True' if the text stream is empty, 'False' otherwise -null :: Fold Text Bool -null = L.Fold step True id - where - step isNull txt = isNull && T.null txt -{-# INLINABLE null #-} - --- | Return the length of the text stream in characters -length :: Num n => Fold Text n -length = L.Fold (\n txt -> n + fromIntegral (T.length txt)) 0 id -{-# INLINABLE length #-} - -{-| @(all predicate)@ returns 'True' if all characters satisfy the predicate, - 'False' otherwise --} -all :: (Char -> Bool) -> Fold Text Bool -all predicate = L.Fold (\b txt -> b && T.all predicate txt) True id -{-# INLINABLE all #-} - -{-| @(any predicate)@ returns 'True' if any character satisfies the predicate, - 'False' otherwise --} -any :: (Char -> Bool) -> Fold Text Bool -any predicate = L.Fold (\b txt -> b || T.any predicate txt) False id -{-# INLINABLE any #-} - --- | Computes the maximum character -maximum :: Fold Text (Maybe Char) -maximum = L.Fold step Nothing' lazy - where - step mc txt = - if T.null txt - then mc - else Just' (case mc of - Nothing' -> T.maximum txt - Just' c -> max c (T.maximum txt) ) -{-# INLINABLE maximum #-} - --- | Computes the minimum character -minimum :: Fold Text (Maybe Char) -minimum = L.Fold step Nothing' lazy - where - step mc txt = - if T.null txt - then mc - else Just' (case mc of - Nothing' -> T.minimum txt - Just' c -> min c (T.minimum txt) ) -{-# INLINABLE minimum #-} - -{-| @(elem c)@ returns 'True' if the text stream has a character equal to @c@, - 'False' otherwise --} -elem :: Char -> Fold Text Bool -elem c = any (c ==) -{-# INLINABLE elem #-} - -{-| @(notElem c)@ returns 'False' if the text stream has a character equal to - @c@, 'True' otherwise --} -notElem :: Char -> Fold Text Bool -notElem c = all (c /=) -{-# INLINABLE notElem #-} - -{-| @(find predicate)@ returns the first character that satisfies the predicate - or 'Nothing' if no character satisfies the predicate --} -find :: (Char -> Bool) -> Fold Text (Maybe Char) -find predicate = L.Fold step Nothing' lazy - where - step mc txt = case mc of - Nothing' -> strict (T.find predicate txt) - Just' _ -> mc -{-# INLINABLE find #-} - -{-| @(index n)@ returns the @n@th character of the text stream, or 'Nothing' if - the stream has an insufficient number of characters --} -index :: Integral n => n -> Fold Text (Maybe Char) -index i = L.Fold step (Left' (fromIntegral i)) hush - where - step x txt = case x of - Left' remainder -> - let len = T.length txt - in if remainder < len - then Right' (T.index txt remainder) - else Left' (remainder - len) - _ -> x -{-# INLINABLE index #-} - -{-| @(elemIndex c)@ returns the index of the first character that equals @c@, - or 'Nothing' if no character matches --} -elemIndex :: Num n => Char -> Fold Text (Maybe n) -elemIndex c = findIndex (c ==) -{-# INLINABLE elemIndex #-} - -{-| @(findIndex predicate)@ returns the index of the first character that - satisfies the predicate, or 'Nothing' if no character satisfies the - predicate --} -findIndex :: Num n => (Char -> Bool) -> Fold Text (Maybe n) -findIndex predicate = L.Fold step (Left' 0) hush - where - step x txt = case x of - Left' m -> case T.findIndex predicate txt of - Nothing -> Left' (m + fromIntegral (T.length txt)) - Just n -> Right' (m + fromIntegral n) - _ -> x -{-# INLINABLE findIndex #-} - --- | @(count c)@ returns the number of times @c@ appears -count :: Num n => Char -> Fold Text n -count c = L.Fold step 0 id - where - step n txt = n + fromIntegral (T.count (T.singleton c) txt) -{-# INLINABLE count #-} - -{- $reexports - "Control.Foldl" re-exports the 'Fold' type - - @Data.Text@ re-exports the 'Text' type --} +-- | Folds for text streams++module Control.Foldl.Text (+ -- * Folding+ fold++ -- * Folds+ , head+ , last+ , null+ , length+ , any+ , all+ , maximum+ , minimum+ , elem+ , notElem+ , find+ , index+ , elemIndex+ , findIndex+ , count++ -- * Re-exports+ -- $reexports+ , module Control.Foldl+ , module Data.Text+ ) where++import Control.Foldl (Fold)+import Control.Foldl.Internal (Maybe'(..), lazy, strict, Either'(..), hush)+import qualified Control.Foldl as L+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as Lazy+import Prelude hiding (+ head, last, null, length, any, all, maximum, minimum, elem, notElem )++-- | Apply a strict left 'Fold' to lazy text+fold :: Fold Text a -> Lazy.Text -> a+fold (L.Fold step begin done) as = done (Lazy.foldlChunks step begin as)+{-# INLINABLE fold #-}++{-| Get the first character of a text stream or return 'Nothing' if the stream+ is empty+-}+head :: Fold Text (Maybe Char)+head = L.Fold step Nothing' lazy+ where+ step mc txt =+ if T.null txt+ then mc+ else case mc of+ Just' _ -> mc+ Nothing' -> Just' (T.head txt)+{-# INLINABLE head #-}++{-| Get the last character of a text stream or return 'Nothing' if the text+ stream is empty+-}+last :: Fold Text (Maybe Char)+last = L.Fold step Nothing' lazy+ where+ step mc txt =+ if T.null txt+ then mc+ else Just' (T.last txt)+ -- TODO: Use `unsafeLast` when Debian Stable Haskell Platform has it+{-# INLINABLE last #-}++-- | Returns 'True' if the text stream is empty, 'False' otherwise+null :: Fold Text Bool+null = L.Fold step True id+ where+ step isNull txt = isNull && T.null txt +{-# INLINABLE null #-}++-- | Return the length of the text stream in characters+length :: Num n => Fold Text n+length = L.Fold (\n txt -> n + fromIntegral (T.length txt)) 0 id+{-# INLINABLE length #-}++{-| @(all predicate)@ returns 'True' if all characters satisfy the predicate,+ 'False' otherwise+-}+all :: (Char -> Bool) -> Fold Text Bool+all predicate = L.Fold (\b txt -> b && T.all predicate txt) True id+{-# INLINABLE all #-}++{-| @(any predicate)@ returns 'True' if any character satisfies the predicate,+ 'False' otherwise+-}+any :: (Char -> Bool) -> Fold Text Bool+any predicate = L.Fold (\b txt -> b || T.any predicate txt) False id+{-# INLINABLE any #-}++-- | Computes the maximum character+maximum :: Fold Text (Maybe Char)+maximum = L.Fold step Nothing' lazy+ where+ step mc txt =+ if T.null txt+ then mc+ else Just' (case mc of+ Nothing' -> T.maximum txt+ Just' c -> max c (T.maximum txt) )+{-# INLINABLE maximum #-}++-- | Computes the minimum character+minimum :: Fold Text (Maybe Char)+minimum = L.Fold step Nothing' lazy+ where+ step mc txt =+ if T.null txt+ then mc+ else Just' (case mc of+ Nothing' -> T.minimum txt+ Just' c -> min c (T.minimum txt) )+{-# INLINABLE minimum #-}++{-| @(elem c)@ returns 'True' if the text stream has a character equal to @c@,+ 'False' otherwise+-}+elem :: Char -> Fold Text Bool+elem c = any (c ==)+{-# INLINABLE elem #-}++{-| @(notElem c)@ returns 'False' if the text stream has a character equal to+ @c@, 'True' otherwise+-}+notElem :: Char -> Fold Text Bool+notElem c = all (c /=)+{-# INLINABLE notElem #-}++{-| @(find predicate)@ returns the first character that satisfies the predicate+ or 'Nothing' if no character satisfies the predicate+-}+find :: (Char -> Bool) -> Fold Text (Maybe Char)+find predicate = L.Fold step Nothing' lazy+ where+ step mc txt = case mc of+ Nothing' -> strict (T.find predicate txt)+ Just' _ -> mc+{-# INLINABLE find #-}++{-| @(index n)@ returns the @n@th character of the text stream, or 'Nothing' if+ the stream has an insufficient number of characters+-}+index :: Integral n => n -> Fold Text (Maybe Char)+index i = L.Fold step (Left' (fromIntegral i)) hush+ where+ step x txt = case x of+ Left' remainder ->+ let len = T.length txt+ in if remainder < len+ then Right' (T.index txt remainder)+ else Left' (remainder - len)+ _ -> x+{-# INLINABLE index #-}++{-| @(elemIndex c)@ returns the index of the first character that equals @c@,+ or 'Nothing' if no character matches+-}+elemIndex :: Num n => Char -> Fold Text (Maybe n)+elemIndex c = findIndex (c ==)+{-# INLINABLE elemIndex #-}++{-| @(findIndex predicate)@ returns the index of the first character that+ satisfies the predicate, or 'Nothing' if no character satisfies the+ predicate+-}+findIndex :: Num n => (Char -> Bool) -> Fold Text (Maybe n)+findIndex predicate = L.Fold step (Left' 0) hush+ where+ step x txt = case x of+ Left' m -> case T.findIndex predicate txt of+ Nothing -> Left' (m + fromIntegral (T.length txt))+ Just n -> Right' (m + fromIntegral n)+ _ -> x+{-# INLINABLE findIndex #-}++-- | @(count c)@ returns the number of times @c@ appears+count :: Num n => Char -> Fold Text n+count c = L.Fold step 0 id+ where+ step n txt = n + fromIntegral (T.count (T.singleton c) txt)+{-# INLINABLE count #-}++{- $reexports+ "Control.Foldl" re-exports the 'Fold' type++ @Data.Text@ re-exports the 'Text' type+-}