foldl 1.0.10 → 1.0.11
raw patch · 7 files changed
+1324/−1318 lines, 7 filesdep +profunctorssetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: profunctors
API changes (from Hackage documentation)
+ Control.Foldl: instance Profunctor Fold
Files
- LICENSE +24/−24
- Setup.hs +2/−2
- foldl.cabal +39/−38
- src/Control/Foldl.hs +832/−827
- 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,38 +1,39 @@-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+Name: foldl +Version: 1.0.11 +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, + profunctors < 5.2 + 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,827 +1,832 @@-{-| 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--}+{-| 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.Profunctor +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 Profunctor Fold where + lmap = premap + rmap = 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 )---- | 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--}+-- | 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 +-}