foldl-1.2.1/src/0000755000000000000000000000000012276360746011605 5ustar0000000000000000foldl-1.2.1/src/Control/0000755000000000000000000000000012722234503013210 5ustar0000000000000000foldl-1.2.1/src/Control/Foldl/0000755000000000000000000000000012522407375014257 5ustar0000000000000000foldl-1.2.1/src/Control/Foldl.hs0000644000000000000000000006770512722234503014623 0ustar0000000000000000{-| 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 Taking the sum, the sum of squares, ..., upto the sum of x^5 >>> import Data.Traversable >>> let powerSums = sequenceA [L.premap (^n) L.sum | n <- [1..5]] >>> L.fold powerSums [1..10] [55,385,3025,25333,220825] 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 #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} module Control.Foldl ( -- * Fold Types Fold(..) , FoldM(..) -- * Folding , fold , foldM , scan -- * Folds , Control.Foldl.mconcat , Control.Foldl.foldMap , head , last , lastDef , lastN , null , length , and , or , all , any , sum , product , maximum , maximumBy , minimum , minimumBy , elem , notElem , find , index , elemIndex , findIndex , random , randomN , Control.Foldl.mapM_ , sink -- * Generic Folds , genericLength , genericIndex -- * Container folds , list , revList , nub , eqNub , set , vector -- * Utilities -- $utilities , purely , purely_ , impurely , impurely_ , generalize , simplify , hoists , duplicateM , _Fold1 , premap , premapM , Handler , handles , EndoM(..) , HandlerM , handlesM , folded , filtered -- * Re-exports -- $reexports , module Control.Monad.Primitive , module Data.Foldable , module Data.Vector.Generic ) where import Control.Applicative import Control.Foldl.Internal (Maybe'(..), lazy, Either'(..), hush) import Control.Monad ((<=<)) import Control.Monad.Primitive (PrimMonad, RealWorld) import Control.Comonad import Data.Foldable (Foldable) import Data.Functor.Identity (Identity, runIdentity) import Data.Functor.Contravariant (Contravariant(..)) import Data.Monoid import Data.Profunctor import Data.Sequence ((|>)) import Data.Vector.Generic (Vector, Mutable) import Data.Vector.Generic.Mutable (MVector) import System.Random.MWC (GenIO, createSystemRandom, uniformR) import Prelude hiding ( head , last , null , length , and , or , all , any , sum , product , maximum , minimum , elem , notElem ) import qualified Data.Foldable as F import qualified Data.List as List import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as M {-| 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) {-# INLINE fmap #-} instance Profunctor Fold where lmap = premap rmap = fmap instance Comonad (Fold a) where extract (Fold _ begin done) = done begin {-# INLINABLE extract #-} duplicate (Fold step begin done) = Fold step begin (\x -> Fold step x done) {-# INLINABLE duplicate #-} instance Applicative (Fold a) where pure b = Fold (\() _ -> ()) () (\() -> b) {-# INLINE 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 {-# INLINE (<*>) #-} 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 Monad m => Profunctor (FoldM m) where rmap = fmap lmap = premapM 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 #-} {-| Return the last N elements -} lastN :: Int -> Fold a [a] lastN n = Fold step begin done where step s a = s' |> a where s' = if Seq.length s < n then s else Seq.drop 1 s begin = Seq.empty done = F.toList {-# INLINABLE lastN #-} -- | 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 maximum element with respect to the given comparison function -} maximumBy :: (a -> a -> Ordering) -> Fold a (Maybe a) maximumBy cmp = _Fold1 max' where max' x y = case cmp x y of GT -> x _ -> y {-# INLINABLE maximumBy #-} -- | Computes the minimum element minimum :: Ord a => Fold a (Maybe a) minimum = _Fold1 min {-# INLINABLE minimum #-} {-| Computes the minimum element with respect to the given comparison function -} minimumBy :: (a -> a -> Ordering) -> Fold a (Maybe a) minimumBy cmp = _Fold1 min' where min' x y = case cmp x y of GT -> y _ -> x {-# INLINABLE minimumBy #-} {-| @(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 g <- createSystemRandom return $! Pair3 g Nothing' (1 :: Int) step (Pair3 g Nothing' _) a = return $! Pair3 g (Just' a) 2 step (Pair3 g (Just' a) m) b = do n <- uniformR (1, m) g let c = if n == 1 then b else a return $! Pair3 g (Just' c) (m + 1) done (Pair3 _ ma _) = return (lazy ma) {-# INLINABLE random #-} data VectorState = Incomplete {-# UNPACK #-} !Int | Complete data RandomNState v a = RandomNState { _size :: !VectorState , _reservoir :: !(Mutable v RealWorld a) , _position :: {-# UNPACK #-} !Int , _gen :: {-# UNPACK #-} !GenIO } -- | Pick several random elements, using reservoir sampling randomN :: Vector v a => Int -> FoldM IO a (Maybe (v a)) randomN n = FoldM step begin done where step :: MVector (Mutable v) a => RandomNState v a -> a -> IO (RandomNState v a) step (RandomNState (Incomplete m) mv i g) a = do M.write mv m a let m' = m + 1 let s = if n <= m' then Complete else Incomplete m' return $! RandomNState s mv (i + 1) g step (RandomNState Complete mv i g) a = do r <- uniformR (0, i - 1) g if r < n then M.unsafeWrite mv r a else return () return (RandomNState Complete mv (i + 1) g) begin = do mv <- M.new n gen <- createSystemRandom let s = if n <= 0 then Complete else Incomplete 0 return (RandomNState s mv 1 gen) done :: Vector v a => RandomNState v a -> IO (Maybe (v a)) done (RandomNState (Incomplete _) _ _ _) = return Nothing done (RandomNState Complete mv _ _) = do v <- V.freeze mv return (Just v) -- | Converts an effectful function to a fold. Specialized version of 'sink'. mapM_ :: Monad m => (a -> m ()) -> FoldM m a () mapM_ = sink {-# INLINABLE mapM_ #-} {-| Converts an effectful function to a fold > sink (f <> g) = sink f <> sink g -- if `(<>)` is commutative > sink mempty = mempty -} sink :: (Monoid w, Monad m) => (a -> m w) -> FoldM m a w sink act = FoldM step begin done where done = return begin = return mempty step m a = do m' <- act a return $! mappend m m' {-# INLINABLE sink #-} -- | 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.freeze 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 @fold@ and @foldM@ functions in @Pipes.Prelude@ with the following type: > Pipes.Prelude.fold > :: Monad m > -> (x -> a -> x) -> x -> (x -> b) -> Producer a m () -> m b > > Pipes.Prelude.foldM > :: Monad m > => (x -> a -> m x) -> m x -> (x -> m b) -> Producer a m () -> m b Both @fold@ and @foldM@ is set up so that you can wrap them with either 'purely' or 'impurely' to accept a 'Fold' or 'FoldM', respectively: > purely Pipes.Prelude.fold > :: Monad m => Fold a b -> Producer a m () -> m b > > impurely Pipes.Prelude.foldM > :: Monad m => FoldM m a b -> Producer a m () -> m b Similarly the @ofoldlUnwrap@ and @ofoldMUnwrap@ functions from the @monotraversable@ package are written to interoperate with this library: > ofoldlUnwrap > :: MonoFoldable mono > => (x -> Element mono -> x) -> x -> (x -> b) -> mono -> b > > ofoldMUnwrap > :: (Monad m, MonoFoldable mono) > => (x -> Element mono -> m x) -> m x -> (x -> m b) -> mono -> m b You can wrap these to accept 'Fold' or 'FoldM', too: > purely ofoldlUnwrap > :: MonoFoldable mono > => Fold (Element mono) b -> mono -> b > > impurely ofoldMUnwrap > :: MonoFoldable mono > => FoldM m (Element mono) b -> mono -> 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 more traditional fold to accept the `Fold` type purely_ :: (forall x . (x -> a -> x) -> x -> x) -> Fold a b -> b purely_ f (Fold step begin done) = done (f step begin) {-# 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 #-} -- | Upgrade a more traditional monadic fold to accept the `FoldM` type impurely_ :: Monad m => (forall x . (x -> a -> m x) -> m x -> m x) -> FoldM m a b -> m b impurely_ f (FoldM step begin done) = do x <- f step begin done x {-# 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 #-} {- | Shift a 'FoldM' from one monad to another with a morphism such as 'lift' or 'liftIO'; the effect is the same as 'Control.Monad.Morph.hoist'. -} hoists :: Monad m => (forall x . m x -> n x) -> FoldM m a b -> FoldM n a b hoists phi (FoldM step begin done) = FoldM (\a b -> phi (step a b)) (phi begin) (phi . done) {-| Allows to continue feeding a 'FoldM' even after passing it to a function that closes it. For pure 'Fold's, this is provided by the 'Control.Comonad.Comonad' instance. -} duplicateM :: Applicative m => FoldM m a b -> FoldM m a (FoldM m a b) duplicateM (FoldM step begin done) = FoldM step begin (\x -> pure (FoldM step (pure x) done)) {-# INLINABLE duplicateM #-} {-| @_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 :: (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 #-} {-| A handler for the upstream input of a `Fold` Any lens, traversal, or prism will type-check as a `Handler` -} type Handler a b = forall x . (b -> Const (Dual (Endo x)) b) -> a -> Const (Dual (Endo x)) a {-| @(handles t folder)@ transforms the input of a `Fold` using a lens, traversal, or prism: > handles _1 :: Fold a r -> Fold (a, b) r > handles _Left :: Fold a r -> Fold (Either a b) r > handles traverse :: Traversable t => Fold a r -> Fold (t a) r > handles folded :: Foldable t => Fold a r -> Fold (t a) r >>> fold (handles traverse sum) [[1..5],[6..10]] 55 >>> fold (handles (traverse.traverse) sum) [[Nothing, Just 2, Just 7],[Just 13, Nothing, Just 20]] 42 >>> fold (handles (filtered even) sum) [1..10] 30 >>> fold (handles _2 mconcat) [(1,"Hello "),(2,"World"),(3,"!")] "Hello World!" > handles id = id > > handles (f . g) = handles f . handles g > handles t (pure r) = pure r > > handles t (f <*> x) = handles t f <*> handles t x -} handles :: Handler a b -> Fold b r -> Fold a r handles k (Fold step begin done) = Fold step' begin done where step' = flip (appEndo . getDual . getConst . k (Const . Dual . Endo . flip step)) {-# INLINABLE handles #-} {-| > instance Monad m => Monoid (EndoM m a) where > mempty = EndoM return > mappend (EndoM f) (EndoM g) = EndoM (f <=< g) -} 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) {-| A Handler for the upstream input of `FoldM` Any lens, traversal, or prism will type-check as a `HandlerM` -} type HandlerM m a b = forall x . (b -> Const (Dual (EndoM m x)) b) -> a -> Const (Dual (EndoM m x)) a {-| @(handlesM t folder)@ transforms the input of a `FoldM` using a lens, traversal, or prism: > handlesM _1 :: FoldM m a r -> FoldM (a, b) r > handlesM _Left :: FoldM m a r -> FoldM (Either a b) r > handlesM traverse :: Traversable t => FoldM m a r -> FoldM m (t a) r > handlesM folded :: Foldable t => FoldM m a r -> FoldM m (t a) r `handlesM` obeys these laws: > handlesM id = id > > handlesM (f . g) = handlesM f . handlesM g > handlesM t (pure r) = pure r > > handlesM t (f <*> x) = handlesM t f <*> handlesM t x -} handlesM :: Monad m => HandlerM m a b -> FoldM m b r -> FoldM m a r handlesM k (FoldM step begin done) = FoldM step' begin done where step' = flip (appEndoM . getDual . getConst . k (Const . Dual . EndoM . flip step)) {-# INLINABLE handlesM #-} {-| > folded :: Foldable t => Fold (t a) a > > handles folded :: Foldable t => Fold a r -> Fold (t a) r -} folded :: (Contravariant f, Applicative f, Foldable t) => (a -> f a) -> (t a -> f (t a)) folded k ts = contramap (\_ -> ()) (F.traverse_ k ts) {-| >>> fold (handles (filtered even) sum) [1..10] 30 >>> foldM (handlesM (filtered even) (mapM_ print)) [1..10] 2 4 6 8 10 -} filtered :: Monoid m => (a -> Bool) -> (a -> m) -> a -> m filtered p k x | p x = k x | otherwise = mempty {-# INLINABLE filtered #-} {- $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 -} foldl-1.2.1/src/Control/Foldl/ByteString.hs0000644000000000000000000001302212522312402016665 0ustar0000000000000000-- | 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 -} foldl-1.2.1/src/Control/Foldl/Text.hs0000644000000000000000000001245212405076144015537 0ustar0000000000000000-- | 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 -} foldl-1.2.1/src/Control/Foldl/Internal.hs0000644000000000000000000000141412276360746016375 0ustar0000000000000000-- | 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 #-} foldl-1.2.1/LICENSE0000644000000000000000000000275712276360746012036 0ustar0000000000000000Copyright (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. foldl-1.2.1/Setup.hs0000644000000000000000000000005612276360746012453 0ustar0000000000000000import Distribution.Simple main = defaultMain foldl-1.2.1/foldl.cabal0000644000000000000000000000273412722237301013072 0ustar0000000000000000Name: foldl Version: 1.2.1 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 Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1 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 && < 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.6 , vector >= 0.7 && < 0.12, containers < 0.6 , contravariant < 1.5 , profunctors < 5.3 , comonad >= 4.0 && < 6 Exposed-Modules: Control.Foldl, Control.Foldl.ByteString, Control.Foldl.Text Other-Modules: Control.Foldl.Internal GHC-Options: -O2 -Wall