foldl-1.4.15/0000755000000000000000000000000007346545000011073 5ustar0000000000000000foldl-1.4.15/CHANGELOG.md0000644000000000000000000000746307346545000012716 0ustar00000000000000001.4.14 - Add [`Control.Foldl.NonEmpty.nonEmpty`](https://github.com/Gabriella439/foldl/pull/186) - Add [`Control.Foldl.NonEmpty.toFold`](https://github.com/Gabriella439/foldl/pull/191) - [Generalize `fold1` to work with `Foldable1`](https://github.com/Gabriella439/foldl/pull/185) 1.4.13 * New "Control.Foldl.NonEmpty" module for folding non-empty containers 1.4.12 * `Data.Functor.Extend.Extended` instances for `Fold` / `FoldM` * Remove dependency on `mwc-random` 1.4.11 * Fix doctest failure when built against newer versions of the `hashable` package 1.4.10 * Fix space leaks in `scan` / `scanM` 1.4.9 * Implement `vector` utility more efficiently 1.4.8 * Only depend on `semigroups` for older GHC versions 1.4.7 * Add `foldByKey{,Hash}Map` functions 1.4.6 * Add `nest`/`predropWhile`/`drop`/`dropM` 1.4.5 * Increase upper bound on `containers` * Add `either`/`eitherM` 1.4.4 * Increase lower bound on `base` * Change `mean` to be more numerically stable 1.4.3 * Add `Control.Scanl.scanr` * Increase upper bound on `mwc-random` 1.4.2 * Add `Semigroupoid` instance for `Fold` * Increase upper bound on `contravariant` and `profunctors` 1.4.1 * Add `Control.Scanl` * Drop support for GHC 7.8 and older 1.4.0 * BREAKING CHANGE: Change type of `premapM` to accept a monadic function 1.3.7 * Add `groupBy` 1.3.6 * Documentation improvements 1.3.5 * Add `Choice` instance for `Fold` 1.3.4 * Add `prefilter` and `prefilterM` 1.3.3 * Add back the old `vector` as `vectorM` 1.3.2 * Compatibility with `Semigroup` becoming a super-class of `Monoid` * Fix `asin` for `Fold` 1.3.1 * Fix `asin` for `FoldM` 1.3.0 * BREAKING CHANGE: Change `vector` to be a pure `Fold` (which is faster, too!) 1.2.5 * Add support for folding new containers: `hashSet`, `map`, and `hashMap` * Add `prescan`/`postscan` which generalize `scan` to `Traversable` types 1.2.4 * Add `lazy` folds for `Text` and `ByteString` * Documentation fixes and improvements 1.2.3 * Add `lookup` 1.2.2 * Add numerically stable `mean`, `variance`, and `std` folds * Add `Control.Foldl.{Text,ByteString}.foldM` * Add `foldOver`/`foldOverM` 1.2.1 * Performance improvements * Re-export `filtered` 1.2.0 * Breaking change: Fix `handles` to fold things in the correct order (was previously folding things backwards and also leaking space as a result). No change to behavior of `handlesM`, which was folding things in the right order * Breaking change: Change the `Monoid` used by `Handler`/`HandlerM` * Add `folded` 1.1.6 * Add `maximumBy` and `minimumBy` 1.1.5 * Increase lower bound on `base` from `< 4` to `< 4.5` 1.1.4 * Increase upper bound on `comonad` from `< 5` to `< 6` 1.1.3 * Increase upper bound on `profunctors` from `< 5.2` to `< 5.3` * Add `mapM_`, `hoists`, `purely`, and `impurely` 1.1.2 * Add `lastN`, `randomN`, `sink`, and `duplicateM` * Add `Comonad` instance for `Fold` * Add `Profunctor` instance for `FoldM` 1.1.1 * Increase upper bound on `vector` from `< 0.11` to `< 0.12` 1.1.0 * Breaking change: Rename `pretraverse`/`pretraverseM` to `handles`/`handlesM` * Add `Handler` * Export `EndoM` 1.0.11 * Add `Profunctor` instance for `Fold` 1.0.10 * Add `random` and `_Fold1` 1.0.9 * Increase upper bound on `primitive` from `< 0.6` to `< 0.7` 1.0.8 * Add `revList` 1.0.7 * Add `Num` and `Fractional` instances for `Fold`/`FoldM` * Add `count` fold for `Text` and `ByteString` 1.0.6 * Add `pretraverse` and `pretraverseM` 1.0.5 * Add `lastDef` 1.0.4 * Increase upper bounds on `transformers` from `< 0.4` to `< 0.6` * Add `nub`, `eqNub`, and `set` 1.0.3 * Add `scan`, `generalize`, `simplify`, and `premapM` 1.0.2 * Add `list` and `vector` folds * Add `fold` function for `Text` and `ByteString` 1.0.1 * Add support for `ByteString` and `Text` folds * Add `Monoid` instance for `Fold`/`FoldM` 1.0.0 * Initial release foldl-1.4.15/LICENSE0000644000000000000000000000276307346545000012110 0ustar0000000000000000Copyright (c) 2013 Gabriella 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 Gabriella 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.4.15/README.md0000644000000000000000000001321507346545000012354 0ustar0000000000000000# `foldl` Use this `foldl` library when you want to compute multiple folds over a collection in one pass over the data without space leaks. For example, suppose that you want to simultaneously compute the sum of the list and the length of the list. Many Haskell beginners might write something like this: ```haskell sumAndLength :: Num a => [a] -> (a, Int) sumAndLength xs = (sum xs, length xs) ``` However, this solution will leak space because it goes over the list in two passes. If you demand the result of `sum` the Haskell runtime will materialize the entire list. However, the runtime cannot garbage collect the list because the list is still required for the call to `length`. Usually people work around this by hand-writing a strict left fold that looks something like this: ```haskell {-# LANGUAGE BangPatterns #-} import Data.List (foldl') sumAndLength :: Num a => [a] -> (a, Int) sumAndLength xs = foldl' step (0, 0) xs where step (x, y) n = (x + n, y + 1) ``` That now goes over the list in one pass, but will still leak space because the tuple is not strict in both fields! You have to define a strict `Pair` type to fix this: ```haskell {-# LANGUAGE BangPatterns #-} import Data.List (foldl') data Pair a b = Pair !a !b sumAndLength :: Num a => [a] -> (a, Int) sumAndLength xs = done (foldl' step (Pair 0 0) xs) where step (Pair x y) n = Pair (x + n) (y + 1) done (Pair x y) = (x, y) ``` However, this is not satisfactory because you have to reimplement the guts of every fold that you care about and also define a custom strict data type for your fold. Hand-writing the step function, accumulator, and strict data type for every fold that you want to use gets tedious fast. For example, implementing something like reservoir sampling over and over is very error prone. What if you just stored the step function and accumulator for each individual fold and let some high-level library do the combining for you? That's exactly what this library does! Using this library you can instead write: ```haskell import qualified Control.Foldl as Fold sumAndLength :: Num a => [a] -> (a, Int) sumAndLength xs = Fold.fold ((,) <$> Fold.sum <*> Fold.length) xs -- or, more concisely: sumAndLength = Fold.fold ((,) <$> Fold.sum <*> Fold.length) ``` To see how this works, the `Fold.sum` value is just a datatype storing the step function and the starting state (and a final extraction function): ```haskell sum :: Num a => Fold a a sum = Fold (+) 0 id ``` Same thing for the `Fold.length` value: ```haskell length :: Fold a Int length = Fold (\n _ -> n + 1) 0 id ``` ... and the `Applicative` operators combine them into a new datatype storing the composite step function and starting state: ```haskell (,) <$> Fold.sum <*> Fold.length = Fold step (Pair 0 0) done where step (Pair x y) n = Pair (x + n) (y + 1) done (Pair x y) = (x, y) ``` ... and then `fold` just transforms that to a strict left fold: ```haskell fold (Fold step begin done) = done (foldl' step begin) ``` Since we preserve the step function and accumulator, we can use the `Fold` type to fold things other than pure collections. For example, we can fold a `Producer` from `pipes` using the same `Fold`: ```haskell Fold.purely Pipes.Prelude.fold ((,) <$> sum <*> length) :: (Monad m, Num a) => Producer a m () -> m (a, Int) ``` To learn more about this library, read the documentation in [the main `Control.Foldl` module](http://hackage.haskell.org/package/foldl/docs/Control-Foldl.html). ## Quick start Install [the `stack` tool](http://haskellstack.org/) and then run: ```bash $ stack setup $ stack ghci foldl Prelude> import qualified Control.Foldl as Fold Prelude Fold> Fold.fold ((,) <$> Fold.sum <*> Fold.length) [1..1000000] (500000500000,1000000) ``` ## How to contribute Contribute a pull request if you have a `Fold` that you believe other people would find useful. ## Development Status [![Build Status](https://travis-ci.org/Gabriella439/Haskell-Foldl-Library.png)](https://travis-ci.org/Gabriella439/Haskell-Foldl-Library) The `foldl` library is pretty stable at this point. I don't expect there to be breaking changes to the API from this point forward unless people discover new bugs. ## License (BSD 3-clause) Copyright (c) 2016 Gabriella 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 Gabriella 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.4.15/Setup.hs0000644000000000000000000000005607346545000012530 0ustar0000000000000000import Distribution.Simple main = defaultMain foldl-1.4.15/bench/0000755000000000000000000000000007346545000012152 5ustar0000000000000000foldl-1.4.15/bench/Foldl.hs0000644000000000000000000000447407346545000013557 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Main (main) where import Control.Foldl hiding (map) import Criterion.Main import qualified Data.List import Prelude hiding (length, sum) import qualified Prelude import qualified Data.Foldable as Foldable main :: IO () main = defaultMain [ env (return [1..10000 :: Int]) $ \ns -> bgroup "[1..10000 :: Int]" [ bgroup "sum" $ map ($ ns) [ bench "fold sum" . whnf (fold sum) , bench "foldM (generalize sum)" . whnfIO . foldM (generalize sum) , bench "Prelude.sum" . whnf Prelude.sum , bench "Data.List.foldl' (+) 0" . whnf (Data.List.foldl' (+) 0) ] , bgroup "filtered" $ map ($ ns) [ bench "fold (handles (filtered even) list)" . nf (fold (handles (filtered even) list)) , bench "foldM (handlesM (filtered even) (generalize list))" . nfIO . foldM (handlesM (filtered even) (generalize list)) , bench "filter even" . nf (filter even) ] , bgroup "length" $ map ($ ns) [ bench "fold length" . whnf (fold length) , bench "foldM (generalize length)" . whnfIO . foldM (generalize length) , bench "Prelude.length" . whnf Prelude.length ] , bgroup "sumAndLength" $ map ($ ns) [ bench "naive sumAndLength" . nf sumAndLength , bench "foldl' sumAndLength" . nf sumAndLength' , bench "strict pair sumAndLength" . nf sumAndLength_Pair , bench "foldl sumAndLength" . nf sumAndLength_foldl ] ] ] sumAndLength :: Num a => [a] -> (a, Int) sumAndLength xs = (Prelude.sum xs, Prelude.length xs) sumAndLength' :: Num a => [a] -> (a, Int) sumAndLength' xs = Foldable.foldl' step (0, 0) xs where step (x, y) n = (x + n, y + 1) data Pair a b = Pair !a !b sumAndLength_Pair :: Num a => [a] -> (a, Int) sumAndLength_Pair xs = done (Foldable.foldl' step (Pair 0 0) xs) where step (Pair x y) n = Pair (x + n) (y + 1) done (Pair x y) = (x, y) sumAndLength_foldl :: Num a => [a] -> (a, Int) sumAndLength_foldl = fold ((,) <$> sum <*> length) foldl-1.4.15/bench/Scanl.hs0000644000000000000000000000624407346545000013554 0ustar0000000000000000-- Copyright (c) 2020 Google LLC -- | Benchmarks for the 'Control.Scanl' module. -- -- These benchmarks can also be used to detect space leaks via the "limited -- stack size" method. For example, to check all of the pure left scan -- benchmarks via 'stack': -- -- % stack bench :Scanl \ -- --benchmark-arguments='"[1..10000 :: Int]/sum of scan/" +RTS -K1K' module Main (main) where import Control.Category ((.)) import qualified Control.Foldl as Foldl import Control.Scanl import Criterion.Main import Data.Foldable (foldl') import Data.Functor.Identity (Identity(..)) import Prelude hiding ((.), scanr, sum) -- A sum function guaranteed not to leak space on strict data types. sum :: (Foldable t, Num a) => t a -> a sum = foldl' (+) 0 scanSum :: Scan Int Int scanSum = postscan Foldl.sum scanMSum :: Monad m => ScanM m Int Int scanMSum = generalize scanSum scanProduct :: Scan Int Int scanProduct = postscan Foldl.product scanMProduct :: Monad m => ScanM m Int Int scanMProduct = generalize scanProduct main :: IO () main = defaultMain [ env (return [1..10000 :: Int]) $ \ns -> bgroup "[1..10000 :: Int]" [ bgroup "sum of scan" $ map ($ ns) [ bench "1" . whnf (sum . scan (1 :: Scan Int Int)) , bench "scanSum" . whnf (sum . scan scanSum) , bench "scanProduct" . whnf (sum . scan scanProduct) , bench "fmap (+1) scanSum" . whnf (sum . scan (fmap (+1) scanSum)) , bench "scanProduct / scanSum" . whnf (sum . scan (scanProduct + scanSum)) , bench "scanProduct . scanSum" . whnf (sum . scan (scanProduct . scanSum)) ] , bgroup "sum of scanM @Identity" $ map ($ ns) [ bench "1" . whnf (runIdentity . fmap sum . scanM (1 :: ScanM Identity Int Int)) , bench "scanMSum" . whnf (runIdentity . fmap sum . scanM scanMSum) , bench "scanMProduct" . whnf (runIdentity . fmap sum . scanM scanMProduct) , bench "fmap (+1) scanMSum" . whnf (runIdentity . fmap sum . scanM (fmap (+1) scanMSum)) , bench "scanMProduct / scanMSum" . whnf (runIdentity . fmap sum . scanM (scanMProduct + scanMSum)) , bench "scanMProduct . scanMSum)" . whnf (runIdentity . fmap sum . scanM (scanMProduct . scanMSum)) ] -- These right scans cannot be processed in constant space, so the -- "limited stack size" space leak test will always fail. , bgroup "sum of scanr" $ map ($ ns) [ bench "1" . whnf (sum . scanr (1 :: Scan Int Int)) , bench "scanSum" . whnf (sum . scanr scanSum) , bench "scanProduct" . whnf (sum . scanr scanProduct) , bench "fmap (+1) scanSum" . whnf (sum . scanr (fmap (+1) scanSum)) , bench "scanProduct / scanSum" . whnf (sum . scanr (scanProduct + scanSum)) , bench "scanProduct . scanSum" . whnf (sum . scanr (scanProduct . scanSum)) ] ] ] foldl-1.4.15/foldl.cabal0000644000000000000000000000506307346545000013163 0ustar0000000000000000Name: foldl Version: 1.4.15 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 License-File: LICENSE Copyright: 2013 Gabriella Gonzalez Author: Gabriella Gonzalez Maintainer: GenuineGabriella@gmail.com Bug-Reports: https://github.com/Gabriella439/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 Extra-Source-Files: CHANGELOG.md README.md Source-Repository head Type: git Location: https://github.com/Gabriella439/Haskell-Foldl-Library Library HS-Source-Dirs: src Build-Depends: base >= 4.11.0.0 && < 5 , bytestring >= 0.9.2.1 && < 0.12, random >= 1.2 && < 1.3 , primitive < 0.9 , text >= 0.11.2.0 && < 2.1 , transformers >= 0.2.0.0 && < 0.7 , vector >= 0.7 && < 0.14, containers >= 0.5.0.0 && < 0.7 , unordered-containers < 0.3 , hashable < 1.5 , contravariant < 1.6 , profunctors >= 4.3.2 && < 5.7 , semigroupoids >= 1.0 && < 6.1 , comonad >= 4.0 && < 6 if impl(ghc < 8.0) Build-Depends: semigroups >= 0.17 && < 1.20 Exposed-Modules: Control.Foldl, Control.Foldl.ByteString, Control.Foldl.NonEmpty Control.Foldl.Text, Control.Scanl Other-Modules: Control.Foldl.Optics Control.Foldl.Internal Control.Foldl.Util.Vector Control.Foldl.Util.MVector GHC-Options: -O2 -Wall Default-Language: Haskell2010 Benchmark Foldl Type: exitcode-stdio-1.0 HS-Source-Dirs: bench Main-Is: Foldl.hs Build-Depends: base, criterion, foldl GHC-Options: -O2 -Wall -rtsopts -with-rtsopts=-T Default-Language: Haskell2010 Benchmark Scanl Type: exitcode-stdio-1.0 HS-Source-Dirs: bench Main-Is: Scanl.hs Build-Depends: base, criterion, foldl GHC-Options: -O2 -Wall -rtsopts -with-rtsopts=-T Default-Language: Haskell2010 Test-Suite doctest Type: exitcode-stdio-1.0 HS-Source-Dirs: test Main-Is: doctest.hs Build-Depends: base, doctest >= 0.16 GHC-Options: -threaded Default-Language: Haskell2010 foldl-1.4.15/src/Control/0000755000000000000000000000000007346545000013302 5ustar0000000000000000foldl-1.4.15/src/Control/Foldl.hs0000644000000000000000000011765007346545000014710 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 Foldl Use 'fold' to apply a 'Fold' to a list: >>> Foldl.fold Foldl.sum [1..100] 5050 'Fold's are 'Applicative's, so you can combine them using 'Applicative' combinators: >>> import Control.Applicative >>> let average = (/) <$> Foldl.sum <*> Foldl.genericLength … or you can use @do@ notation if you enable the @ApplicativeDo@ language extension: >>> :set -XApplicativeDo >>> let average = do total <- Foldl.sum; count <- Foldl.genericLength; return (total / count) … or you can use the fact that the `Fold` type implements `Num` to do this: >>> let average = Foldl.sum / Foldl.genericLength These combined folds will still traverse the list only once, streaming efficiently over the list in constant space without space leaks: >>> Foldl.fold average [1..10000000] 5000000.5 >>> Foldl.fold ((,) <$> Foldl.minimum <*> Foldl.maximum) [1..10000000] (Just 1,Just 10000000) You might want to try enabling the @-flate-dmd-anal@ flag when compiling executables that use this library to further improve performance. -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} module Control.Foldl ( -- * Fold Types Fold(..) , FoldM(..) -- * Folding , fold , foldM , scan , prescan , postscan -- * Folds , Control.Foldl.mconcat , Control.Foldl.foldMap , head , last , lastDef , lastN , null , length , and , or , all , any , sum , product , mean , variance , std , maximum , maximumBy , minimum , minimumBy , elem , notElem , find , index , lookup , elemIndex , findIndex , random , randomN , Control.Foldl.mapM_ , sink -- * Generic Folds , genericLength , genericIndex -- * Container folds , list , revList , nub , eqNub , set , hashSet , map , foldByKeyMap , hashMap , foldByKeyHashMap , vector , vectorM -- * Utilities -- $utilities , purely , purely_ , impurely , impurely_ , generalize , simplify , hoists , duplicateM , _Fold1 , premap , premapM , prefilter , prefilterM , predropWhile , drop , dropM , Handler , handles , foldOver , EndoM(..) , HandlerM , handlesM , foldOverM , folded , filtered , groupBy , either , eitherM , nest -- * Re-exports -- $reexports , module Control.Monad.Primitive , module Data.Foldable , module Data.Vector.Generic ) where import Control.Foldl.Optics (_Left, _Right) import Control.Applicative import Control.Foldl.Internal (Maybe'(..), lazy, Either'(..), Pair(..), 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.HashMap.Strict (HashMap) import Data.Map.Strict (Map, alter) import Data.Maybe (fromMaybe) import Data.Monoid hiding ((<>)) import Data.Semigroupoid (Semigroupoid) import Data.Functor.Extend (Extend(..)) import Data.Profunctor import Data.Profunctor.Sieve import Data.Sequence ((|>)) import Data.Vector.Generic (Vector, Mutable) import Data.Vector.Generic.Mutable (MVector) import Data.Hashable (Hashable) import Data.Traversable import Numeric.Natural (Natural) import System.Random (StdGen, newStdGen, uniformR) import Prelude hiding ( head , last , null , length , and , or , all , any , sum , product , maximum , minimum , elem , notElem , lookup , map , either , drop ) 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.Map.Strict as Map import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet import qualified Data.Vector.Generic as V import qualified Control.Foldl.Util.Vector as V import qualified Data.Vector.Generic.Mutable as M import qualified Data.Semigroupoid {- $setup >>> import qualified Control.Foldl as Foldl >>> _2 f (x, y) = fmap (\i -> (x, i)) (f y) >>> :{ >>> _Just = let maybeEither Nothing = Left Nothing >>> maybeEither (Just x) = Right x >>> in Control.Foldl.Optics.prism Just maybeEither >>> :} >>> both f (x, y) = (,) <$> f x <*> f y -} {-| 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) 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 Choice Fold where right' (Fold step begin done) = Fold (liftA2 step) (Right begin) (fmap done) {-# INLINE right' #-} instance Cosieve Fold [] where cosieve = fold {-# INLINE cosieve #-} instance Costrong Fold where unfirst p = fmap f list where f as = b where (b, d) = fold p [ (a, d) | a <- as ] {-# INLINE unfirst #-} instance Comonad (Fold a) where extract (Fold _ begin done) = done begin {-# INLINE extract #-} duplicate (Fold step begin done) = Fold step begin (\x -> Fold step x done) {-# INLINE 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 Extend (Fold a) where duplicated = duplicate {-# INLINE duplicated #-} instance Semigroup b => Semigroup (Fold a b) where (<>) = liftA2 (<>) {-# INLINE (<>) #-} instance Semigroupoid Fold where o (Fold step1 begin1 done1) (Fold step2 begin2 done2) = Fold step (Pair begin1 begin2) (\(Pair x _) -> done1 x) where step (Pair c1 c2) a = let c2' = step2 c2 a c1' = step1 c1 (done2 c2') in Pair c1' c2' {-# INLINE o #-} instance Monoid b => Monoid (Fold a b) where mempty = pure mempty {-# INLINE mempty #-} mappend = liftA2 mappend {-# INLINE mappend #-} instance Num b => Num (Fold a b) where fromInteger = pure . fromInteger {-# INLINE fromInteger #-} negate = fmap negate {-# INLINE negate #-} abs = fmap abs {-# INLINE abs #-} signum = fmap signum {-# INLINE signum #-} (+) = liftA2 (+) {-# INLINE (+) #-} (*) = liftA2 (*) {-# INLINE (*) #-} (-) = liftA2 (-) {-# INLINE (-) #-} instance Fractional b => Fractional (Fold a b) where fromRational = pure . fromRational {-# INLINE fromRational #-} recip = fmap recip {-# INLINE recip #-} (/) = liftA2 (/) {-# INLINE (/) #-} instance Floating b => Floating (Fold a b) where pi = pure pi {-# INLINE pi #-} exp = fmap exp {-# INLINE exp #-} sqrt = fmap sqrt {-# INLINE sqrt #-} log = fmap log {-# INLINE log #-} sin = fmap sin {-# INLINE sin #-} tan = fmap tan {-# INLINE tan #-} cos = fmap cos {-# INLINE cos #-} asin = fmap asin {-# INLINE asin #-} atan = fmap atan {-# INLINE atan #-} acos = fmap acos {-# INLINE acos #-} sinh = fmap sinh {-# INLINE sinh #-} tanh = fmap tanh {-# INLINE tanh #-} cosh = fmap cosh {-# INLINE cosh #-} asinh = fmap asinh {-# INLINE asinh #-} atanh = fmap atanh {-# INLINE atanh #-} acosh = fmap acosh {-# INLINE acosh #-} (**) = liftA2 (**) {-# INLINE (**) #-} logBase = liftA2 logBase {-# INLINE 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 Functor m => Functor (FoldM m a) where fmap f (FoldM step start done) = FoldM step start done' where done' x = fmap f $! done x {-# INLINE fmap #-} instance Applicative m => Applicative (FoldM m a) where pure b = FoldM (\() _ -> pure ()) (pure ()) (\() -> pure b) {-# INLINE pure #-} (FoldM stepL beginL doneL) <*> (FoldM 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 FoldM step begin done {-# INLINE (<*>) #-} instance Monad m => Extend (FoldM m a) where duplicated = duplicateM {-# INLINE duplicated #-} instance Functor m => Profunctor (FoldM m) where rmap = fmap lmap f (FoldM step begin done) = FoldM step' begin done where step' x a = step x (f a) instance (Semigroup b, Monad m) => Semigroup (FoldM m a b) where (<>) = liftA2 (<>) {-# INLINE (<>) #-} instance (Monoid b, Monad m) => Monoid (FoldM m a b) where mempty = pure mempty {-# INLINE mempty #-} mappend = liftA2 mappend {-# INLINE mappend #-} instance (Monad m, Num b) => Num (FoldM m a b) where fromInteger = pure . fromInteger {-# INLINE fromInteger #-} negate = fmap negate {-# INLINE negate #-} abs = fmap abs {-# INLINE abs #-} signum = fmap signum {-# INLINE signum #-} (+) = liftA2 (+) {-# INLINE (+) #-} (*) = liftA2 (*) {-# INLINE (*) #-} (-) = liftA2 (-) {-# INLINE (-) #-} instance (Monad m, Fractional b) => Fractional (FoldM m a b) where fromRational = pure . fromRational {-# INLINE fromRational #-} recip = fmap recip {-# INLINE recip #-} (/) = liftA2 (/) {-# INLINE (/) #-} instance (Monad m, Floating b) => Floating (FoldM m a b) where pi = pure pi {-# INLINE pi #-} exp = fmap exp {-# INLINE exp #-} sqrt = fmap sqrt {-# INLINE sqrt #-} log = fmap log {-# INLINE log #-} sin = fmap sin {-# INLINE sin #-} tan = fmap tan {-# INLINE tan #-} cos = fmap cos {-# INLINE cos #-} asin = fmap asin {-# INLINE asin #-} atan = fmap atan {-# INLINE atan #-} acos = fmap acos {-# INLINE acos #-} sinh = fmap sinh {-# INLINE sinh #-} tanh = fmap tanh {-# INLINE tanh #-} cosh = fmap cosh {-# INLINE cosh #-} asinh = fmap asinh {-# INLINE asinh #-} atanh = fmap atanh {-# INLINE atanh #-} acosh = fmap acosh {-# INLINE acosh #-} (**) = liftA2 (**) {-# INLINE (**) #-} logBase = liftA2 logBase {-# INLINE 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 >>> Foldl.scan Foldl.length [1..5] [0,1,2,3,4,5] -} 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 #-} {-| Convert a `Fold` into a prescan for any `Traversable` type \"Prescan\" means that the last element of the scan is not included >>> Foldl.prescan Foldl.length [1..5] [0,1,2,3,4] -} prescan :: Traversable t => Fold a b -> t a -> t b prescan (Fold step begin done) as = bs where step' x a = (x', b) where x' = step x a b = done x (_, bs) = mapAccumL step' begin as {-# INLINE prescan #-} {-| Convert a `Fold` into a postscan for any `Traversable` type \"Postscan\" means that the first element of the scan is not included >>> Foldl.postscan Foldl.length [1..5] [1,2,3,4,5] -} postscan :: Traversable t => Fold a b -> t a -> t b postscan (Fold step begin done) as = bs where step' x a = (x', b) where x' = step x a b = done x' (_, bs) = mapAccumL step' begin as {-# INLINE postscan #-} -- | 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 of all elements product :: Num a => Fold a a product = Fold (*) 1 id {-# INLINABLE product #-} -- | Compute a numerically stable arithmetic mean of all elements mean :: Fractional a => Fold a a mean = Fold step begin done where begin = Pair 0 0 step (Pair x n) y = let n' = n+1 in Pair (x + (y - x) /n') n' done (Pair x _) = x {-# INLINABLE mean #-} -- | Compute a numerically stable (population) variance over all elements variance :: Fractional a => Fold a a variance = Fold step begin done where begin = Pair3 0 0 0 step (Pair3 n mean_ m2) x = Pair3 n' mean' m2' where n' = n + 1 mean' = (n * mean_ + x) / (n + 1) delta = x - mean_ m2' = m2 + delta * delta * n / (n + 1) done (Pair3 n _ m2) = m2 / n {-# INLINABLE variance #-} {-| Compute a numerically stable (population) standard deviation over all elements -} std :: Floating a => Fold a a std = sqrt variance {-# INLINABLE std #-} -- | 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 #-} {-| @(lookup a)@ returns the element paired with the first matching item, or 'Nothing' if none matches -} lookup :: Eq a => a -> Fold (a,b) (Maybe b) lookup a0 = Fold step Nothing' lazy where step x (a,b) = case x of Nothing' -> if a == a0 then Just' b else Nothing' _ -> x {-# INLINABLE lookup #-} 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 <- newStdGen 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 let (n, g') = 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 #-} !StdGen } -- | 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 let (r, g') = 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 <- newStdGen 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 #-} -- | Fold values into a hash-set hashSet :: (Eq a, Hashable a) => Fold a (HashSet.HashSet a) hashSet = Fold (flip HashSet.insert) HashSet.empty id {-# INLINABLE hashSet #-} {-| Fold pairs into a map. -} map :: Ord a => Fold (a, b) (Map.Map a b) map = Fold step begin done where begin = mempty step m (k, v) = Map.insert k v m done = id {-# INLINABLE map #-} {- | Given a 'Fold', produces a 'Map' which applies that fold to each @a@ separated by key @k@. >>> fold (foldByKeyMap Control.Foldl.sum) [("a",1), ("b",2), ("b",20), ("a",10)] fromList [("a",11),("b",22)] -} foldByKeyMap :: forall k a b. Ord k => Fold a b -> Fold (k, a) (Map k b) foldByKeyMap f = case f of Fold (step0 :: x -> a -> x) (ini0 :: x) (end0 :: x -> b) -> let step :: Map k x -> (k,a) -> Map k x step mp (k,a) = Map.alter addToMap k mp where addToMap Nothing = Just $ step0 ini0 a addToMap (Just existing) = Just $ step0 existing a ini :: Map k x ini = Map.empty end :: Map k x -> Map k b end = fmap end0 in Fold step ini end where {-| Fold pairs into a hash-map. -} hashMap :: (Eq a, Hashable a) => Fold (a, b) (HashMap.HashMap a b) hashMap = Fold step begin done where begin = mempty step m (k, v) = HashMap.insert k v m done = id {-# INLINABLE hashMap #-} {- | Given a 'Fold', produces a 'HashMap' which applies that fold to each @a@ separated by key @k@. >>> List.sort (HashMap.toList (fold (foldByKeyHashMap Control.Foldl.sum) [("a",1), ("b",2), ("b",20), ("a",10)])) [("a",11),("b",22)] -} foldByKeyHashMap :: forall k a b. (Hashable k, Eq k) => Fold a b -> Fold (k, a) (HashMap k b) foldByKeyHashMap f = case f of Fold (step0 :: x -> a -> x) (ini0 :: x) (end0 :: x -> b) -> let step :: HashMap k x -> (k,a) -> HashMap k x step mp (k,a) = HashMap.alter addToHashMap k mp where addToHashMap Nothing = Just $ step0 ini0 a addToHashMap (Just existing) = Just $ step0 existing a ini :: HashMap k x ini = HashMap.empty end :: HashMap k x -> HashMap k b end = fmap end0 in Fold step ini end where -- | Fold all values into a vector vector :: Vector v a => Fold a (v a) vector = V.fromReverseListN <$> length <*> revList {-# INLINABLE vector #-} maxChunkSize :: Int maxChunkSize = 8 * 1024 * 1024 {-| Fold all values into a vector This is more efficient than `vector` but is impure -} vectorM :: (PrimMonad m, Vector v a) => FoldM m a (v a) vectorM = 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 vectorM #-} {- $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 Other streaming libraries supporting 'purely' and 'impurely' include @io-streams@ and @streaming@. So for example we have: > purely System.IO.Streams.fold_ > :: Fold a b -> Streams.InputStream a -> IO b > > impurely System.IO.Streams.foldM_ > :: FoldM IO a b -> Streams.InputStream a -> IO b The @monotraversable@ package makes it convenient to apply a 'Fold' or 'FoldM' to pure containers that do not allow a general 'Foldable' instance, like unboxed vectors: > 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 :: (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 :: (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) {-# INLINABLE hoists #-} {-| 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) {-# INLINABLE _Fold1 #-} {-| @(premap f folder)@ returns a new 'Fold' where f is applied at each step > fold (premap f folder) list = fold folder (List.map f list) >>> fold (premap Sum Foldl.mconcat) [1..10] Sum {getSum = 55} >>> fold Foldl.mconcat (List.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 > premapM return = 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 -> m b) -> FoldM m b r -> FoldM m a r premapM f (FoldM step begin done) = FoldM step' begin done where step' x a = f a >>= step x {-# INLINABLE premapM #-} {-| @(prefilter f folder)@ returns a new 'Fold' where the folder's input is used only when the input satisfies a predicate f This can also be done with 'handles' (@handles (filtered f)@) but @prefilter@ does not need you to depend on a lens library. > fold (prefilter p folder) list = fold folder (filter p list) >>> fold (prefilter (>5) Control.Foldl.sum) [1..10] 40 >>> fold Control.Foldl.sum (filter (>5) [1..10]) 40 -} prefilter :: (a -> Bool) -> Fold a r -> Fold a r prefilter f (Fold step begin done) = Fold step' begin done where step' x a = if f a then step x a else x {-# INLINABLE prefilter #-} {-| @(prefilterM f folder)@ returns a new 'FoldM' where the folder's input is used only when the input satisfies a monadic predicate f. -} prefilterM :: (Monad m) => (a -> m Bool) -> FoldM m a r -> FoldM m a r prefilterM f (FoldM step begin done) = FoldM step' begin done where step' x a = do use <- f a if use then step x a else return x {-# INLINABLE prefilterM #-} {-| Transforms a 'Fold' into one which ignores elements until they stop satisfying a predicate > fold (predropWhile p folder) list = fold folder (dropWhile p list) >>> fold (predropWhile (>5) Control.Foldl.sum) [10,9,5,9] 14 -} predropWhile :: (a -> Bool) -> Fold a r -> Fold a r predropWhile f (Fold step begin done) = Fold step' begin' done' where step' (Pair dropping x) a = if dropping && f a then Pair True x else Pair False (step x a) begin' = Pair True begin done' (Pair _ state) = done state {-# INLINABLE predropWhile #-} {-| @(drop n folder)@ returns a new 'Fold' that ignores the first @n@ inputs but otherwise behaves the same as the original fold. > fold (drop n folder) list = fold folder (Data.List.genericDrop n list) >>> Foldl.fold (Foldl.drop 3 Foldl.sum) [10, 20, 30, 1, 2, 3] 6 >>> Foldl.fold (Foldl.drop 10 Foldl.sum) [10, 20, 30, 1, 2, 3] 0 -} drop :: Natural -> Fold a b -> Fold a b drop n (Fold step begin done) = Fold step' begin' done' where begin' = (n, begin) step' (0, s) x = (0, step s x) step' (n', s) _ = (n' - 1, s) done' (_, s) = done s {-# INLINABLE drop #-} {-| @(dropM n folder)@ returns a new 'FoldM' that ignores the first @n@ inputs but otherwise behaves the same as the original fold. > foldM (dropM n folder) list = foldM folder (Data.List.genericDrop n list) >>> Foldl.foldM (Foldl.dropM 3 (Foldl.generalize Foldl.sum)) [10, 20, 30, 1, 2, 3] 6 >>> Foldl.foldM (Foldl.dropM 10 (Foldl.generalize Foldl.sum)) [10, 20, 30, 1, 2, 3] 0 -} dropM :: Monad m => Natural -> FoldM m a b -> FoldM m a b dropM n (FoldM step begin done) = FoldM step' begin' done' where begin' = fmap (\s -> (n, s)) begin step' (0, s) x = fmap (\s' -> (0, s')) (step s x) step' (n', s) _ = return (n' - 1, s) done' (_, s) = done s {-# INLINABLE dropM #-} {-| 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 Foldl.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 #-} {- | @(foldOver f folder xs)@ folds all values from a Lens, Traversal, Prism or Fold with the given folder >>> foldOver (_Just . both) Foldl.sum (Just (2, 3)) 5 >>> foldOver (_Just . both) Foldl.sum Nothing 0 > Foldl.foldOver f folder xs == Foldl.fold folder (xs^..f) > Foldl.foldOver (folded.f) folder == Foldl.fold (handles f folder) > Foldl.foldOver folded == Foldl.fold -} foldOver :: Handler s a -> Fold a b -> s -> b foldOver l (Fold step begin done) = done . flip appEndo begin . getDual . getConst . l (Const . Dual . Endo . flip step) {-# INLINABLE foldOver #-} {-| > 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 => Semigroup (EndoM m a) where (EndoM f) <> (EndoM g) = EndoM (f <=< g) {-# INLINE (<>) #-} instance Monad m => Monoid (EndoM m a) where mempty = EndoM return {-# INLINE mempty #-} mappend = (<>) {-# INLINE mappend #-} {-| 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 :: 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 #-} {- | @(foldOverM f folder xs)@ folds all values from a Lens, Traversal, Prism or Fold monadically with the given folder > Foldl.foldOverM (folded.f) folder == Foldl.foldM (handlesM f folder) > Foldl.foldOverM folded == Foldl.foldM -} foldOverM :: Monad m => HandlerM m s a -> FoldM m a b -> s -> m b foldOverM l (FoldM step begin done) s = do b <- begin r <- (flip appEndoM b . getDual . getConst . l (Const . Dual . EndoM . flip step)) s done r {-# INLINABLE foldOverM #-} {-| > 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) {-# INLINABLE folded #-} {-| >>> fold (handles (filtered even) sum) [1..10] 30 >>> foldM (handlesM (filtered even) (Foldl.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 #-} {-| Perform a 'Fold' while grouping the data according to a specified group projection function. Returns the folded result grouped as a map keyed by the group. -} groupBy :: Ord g => (a -> g) -> Fold a r -> Fold a (Map g r) groupBy grouper (Fold f i e) = Fold f' mempty (fmap e) where f' !m !a = alter (\o -> Just (f (fromMaybe i o) a)) (grouper a) m {-# INLINABLE groupBy #-} {-| Combine two folds into a fold over inputs for either of them. -} either :: Fold a1 b1 -> Fold a2 b2 -> Fold (Either a1 a2) (b1, b2) either l r = (,) <$> handles _Left l <*> handles _Right r {-# INLINABLE either #-} {-| Combine two monadic folds into a fold over inputs for either of them. -} eitherM :: Monad m => FoldM m a1 b1 -> FoldM m a2 b2 -> FoldM m (Either a1 a2) (b1, b2) eitherM l r = (,) <$> handlesM _Left l <*> handlesM _Right r {-# INLINABLE eitherM #-} {-| Nest a fold in an applicative. -} nest :: Applicative f => Fold a b -> Fold (f a) (f b) nest (Fold s i e) = Fold (\xs as -> liftA2 s xs as) (pure i) (\xs -> fmap e xs) {-# INLINABLE nest #-} {- $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.4.15/src/Control/Foldl/0000755000000000000000000000000007346545000014342 5ustar0000000000000000foldl-1.4.15/src/Control/Foldl/ByteString.hs0000644000000000000000000001546007346545000016776 0ustar0000000000000000-- | Folds for byte streams module Control.Foldl.ByteString ( -- * Folding fold , foldM -- * Folds , head , last , null , length , any , all , maximum , minimum , elem , notElem , find , index , elemIndex , findIndex , count , lazy -- * Re-exports -- $reexports , module Control.Foldl , module Data.ByteString , module Data.Word ) where import Control.Foldl (Fold, FoldM) import Control.Foldl.Internal (Maybe'(..), strict, Either'(..), hush) import Data.ByteString (ByteString) import Data.Word (Word8) import Prelude hiding ( head, last, null, length, any, all, maximum, minimum, elem, notElem ) import qualified Control.Foldl import qualified Control.Foldl.Internal import qualified Data.ByteString import qualified Data.ByteString.Lazy.Internal import qualified Data.ByteString.Unsafe import qualified Data.ByteString.Lazy -- | Apply a strict left 'Fold' to a lazy bytestring fold :: Fold ByteString a -> Data.ByteString.Lazy.ByteString -> a fold (Control.Foldl.Fold step begin done) as = done (Data.ByteString.Lazy.Internal.foldlChunks step begin as) {-# INLINABLE fold #-} -- | Apply a strict monadic left 'FoldM' to a lazy bytestring foldM :: Monad m => FoldM m ByteString a -> Data.ByteString.Lazy.ByteString -> m a foldM (Control.Foldl.FoldM step begin done) as = do x <- Data.ByteString.Lazy.Internal.foldlChunks step' begin as done x where step' mx bs = do x <- mx x `seq` step x bs {-# INLINABLE foldM #-} {-| Get the first byte of a byte stream or return 'Nothing' if the stream is empty -} head :: Fold ByteString (Maybe Word8) head = Control.Foldl.Fold step Nothing' Control.Foldl.Internal.lazy where step mw8 bs = if Data.ByteString.null bs then mw8 else case mw8 of Just' _ -> mw8 Nothing' -> Just' (Data.ByteString.Unsafe.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 = Control.Foldl.Fold step Nothing' Control.Foldl.Internal.lazy where step mw8 bs = if Data.ByteString.null bs then mw8 else Just' (Data.ByteString.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 = Control.Foldl.Fold step True id where step isNull bs = isNull && Data.ByteString.null bs {-# INLINABLE null #-} -- | Return the length of the byte stream in bytes length :: Num n => Fold ByteString n length = Control.Foldl.Fold step 0 id where step n bs = n + fromIntegral (Data.ByteString.length bs) {-# INLINABLE length #-} {-| @(all predicate)@ returns 'True' if all bytes satisfy the predicate, 'False' otherwise -} all :: (Word8 -> Bool) -> Fold ByteString Bool all predicate = Control.Foldl.Fold (\b bs -> b && Data.ByteString.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 = Control.Foldl.Fold (\b bs -> b || Data.ByteString.any predicate bs) False id {-# INLINABLE any #-} -- | Computes the maximum byte maximum :: Fold ByteString (Maybe Word8) maximum = Control.Foldl.Fold step Nothing' Control.Foldl.Internal.lazy where step mw8 bs = if Data.ByteString.null bs then mw8 else Just' (case mw8 of Nothing' -> Data.ByteString.maximum bs Just' w8 -> max w8 (Data.ByteString.maximum bs) ) {-# INLINABLE maximum #-} -- | Computes the minimum byte minimum :: Fold ByteString (Maybe Word8) minimum = Control.Foldl.Fold step Nothing' Control.Foldl.Internal.lazy where step mw8 bs = if Data.ByteString.null bs then mw8 else Just' (case mw8 of Nothing' -> Data.ByteString.minimum bs Just' w8 -> min w8 (Data.ByteString.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 = Control.Foldl.Fold step Nothing' Control.Foldl.Internal.lazy where step mw8 bs = case mw8 of Nothing' -> strict (Data.ByteString.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 = Control.Foldl.Fold step (Left' (fromIntegral i)) hush where step x bs = case x of Left' remainder -> let len = Data.ByteString.length bs in if remainder < len then Right' (Data.ByteString.Unsafe.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 = Control.Foldl.Fold step (Left' 0) hush where step x bs = case x of Left' m -> case Data.ByteString.findIndex predicate bs of Nothing -> Left' (m + fromIntegral (Data.ByteString.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 = Control.Foldl.Fold step 0 id where step n bs = n + fromIntegral (Data.ByteString.count w8 bs) {-# INLINABLE count #-} -- | Combine all the strict `ByteString` chunks to build a lazy `ByteString` lazy :: Fold ByteString Data.ByteString.Lazy.ByteString lazy = fmap Data.ByteString.Lazy.fromChunks Control.Foldl.list {-# INLINABLE lazy #-} -- | {- $reexports "Control.Foldl" re-exports the 'Fold' type @Data.ByteString@ re-exports the 'ByteString' type @Data.Word@ re-exports the 'Word8' type -} foldl-1.4.15/src/Control/Foldl/Internal.hs0000644000000000000000000000151507346545000016454 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 -- * Strict Pair , Pair(..) ) 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 #-} data Pair a b = Pair !a !b foldl-1.4.15/src/Control/Foldl/NonEmpty.hs0000644000000000000000000001261607346545000016455 0ustar0000000000000000{-| This module provides a `Fold1` type that is a \"non-empty\" analog of the `Fold` type, meaning that it requires at least one input element in order to produce a result This module does not provide all of the same utilities as the "Control.Foldl" module. Instead, this module only provides the utilities which can make use of the non-empty input guarantee (e.g. `head`). For all other utilities you can convert them from the equivalent `Fold` using `fromFold`. -} module Control.Foldl.NonEmpty where import Control.Applicative (liftA2) import Control.Foldl (Fold(..)) import Control.Foldl.Internal (Either'(..)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Profunctor (Profunctor(..)) import Data.Semigroup.Foldable (Foldable1(..)) import Prelude hiding (head, last, minimum, maximum) import qualified Control.Foldl as Foldl {-| A `Fold1` is like a `Fold` except that it consumes at least one input element -} data Fold1 a b = Fold1 (a -> Fold a b) instance Functor (Fold1 a) where fmap f (Fold1 k) = Fold1 (fmap (fmap f) k) {-# INLINE fmap #-} instance Profunctor Fold1 where lmap f (Fold1 k) = Fold1 k' where k' a = lmap f (k (f a)) {-# INLINE lmap #-} rmap = fmap {-# INLINE rmap #-} instance Applicative (Fold1 a) where pure b = Fold1 (pure (pure b)) {-# INLINE pure #-} Fold1 l <*> Fold1 r = Fold1 (liftA2 (<*>) l r) {-# INLINE (<*>) #-} instance Semigroup b => Semigroup (Fold1 a b) where (<>) = liftA2 (<>) {-# INLINE (<>) #-} instance Monoid b => Monoid (Fold1 a b) where mempty = pure mempty {-# INLINE mempty #-} mappend = liftA2 mappend {-# INLINE mappend #-} instance Num b => Num (Fold1 a b) where fromInteger = pure . fromInteger {-# INLINE fromInteger #-} negate = fmap negate {-# INLINE negate #-} abs = fmap abs {-# INLINE abs #-} signum = fmap signum {-# INLINE signum #-} (+) = liftA2 (+) {-# INLINE (+) #-} (*) = liftA2 (*) {-# INLINE (*) #-} (-) = liftA2 (-) {-# INLINE (-) #-} instance Fractional b => Fractional (Fold1 a b) where fromRational = pure . fromRational {-# INLINE fromRational #-} recip = fmap recip {-# INLINE recip #-} (/) = liftA2 (/) {-# INLINE (/) #-} instance Floating b => Floating (Fold1 a b) where pi = pure pi {-# INLINE pi #-} exp = fmap exp {-# INLINE exp #-} sqrt = fmap sqrt {-# INLINE sqrt #-} log = fmap log {-# INLINE log #-} sin = fmap sin {-# INLINE sin #-} tan = fmap tan {-# INLINE tan #-} cos = fmap cos {-# INLINE cos #-} asin = fmap asin {-# INLINE asin #-} atan = fmap atan {-# INLINE atan #-} acos = fmap acos {-# INLINE acos #-} sinh = fmap sinh {-# INLINE sinh #-} tanh = fmap tanh {-# INLINE tanh #-} cosh = fmap cosh {-# INLINE cosh #-} asinh = fmap asinh {-# INLINE asinh #-} atanh = fmap atanh {-# INLINE atanh #-} acosh = fmap acosh {-# INLINE acosh #-} (**) = liftA2 (**) {-# INLINE (**) #-} logBase = liftA2 logBase {-# INLINE logBase #-} -- | Apply a strict left `Fold1` to a `NonEmpty` list fold1 :: Foldable1 f => Fold1 a b -> f a -> b fold1 (Fold1 k) as1 = Foldl.fold (k a) as where a :| as = toNonEmpty as1 {-# INLINABLE fold1 #-} -- | Promote any `Fold` to an equivalent `Fold1` fromFold :: Fold a b -> Fold1 a b fromFold (Fold step begin done) = Fold1 (\a -> Fold step (step begin a) done) {-# INLINABLE fromFold #-} -- | Promote any `Fold1` to an equivalent `Fold` toFold :: Fold1 a b -> Fold a (Maybe b) toFold (Fold1 k0) = Fold step begin done where begin = Left' k0 step (Left' k) a = Right' (k a) step (Right' (Fold step' begin' done')) a = Right' (Fold step' (step' begin' a) done') done (Right' (Fold _ begin' done')) = Just (done' begin') done (Left' _) = Nothing {-# INLINABLE toFold #-} -- | Fold all values within a non-empty container into a `NonEmpty` list nonEmpty :: Fold1 a (NonEmpty a) nonEmpty = Fold1 (\a -> fmap (a :|) Foldl.list) {-# INLINEABLE nonEmpty #-} -- | Fold all values within a non-empty container using (`<>`) sconcat :: Semigroup a => Fold1 a a sconcat = Fold1 (\begin -> Fold (<>) begin id) {-# INLINABLE sconcat #-} -- | Get the first element of a non-empty container head :: Fold1 a a head = Fold1 (\begin -> Fold step begin id) where step a _ = a {-# INLINABLE head #-} -- | Get the last element of a non-empty container last :: Fold1 a a last = Fold1 (\begin -> Fold step begin id) where step _ a = a {-# INLINABLE last #-} -- | Computes the maximum element maximum :: Ord a => Fold1 a a maximum = Fold1 (\begin -> Fold max begin id) {-# INLINABLE maximum #-} -- | Computes the maximum element with respect to the given comparison function maximumBy :: (a -> a -> Ordering) -> Fold1 a a maximumBy cmp = Fold1 (\begin -> Fold max' begin id) where max' x y = case cmp x y of GT -> x _ -> y {-# INLINABLE maximumBy #-} -- | Computes the minimum element minimum :: Ord a => Fold1 a a minimum = Fold1 (\begin -> Fold min begin id) {-# INLINABLE minimum #-} -- | Computes the minimum element with respect to the given comparison function minimumBy :: (a -> a -> Ordering) -> Fold1 a a minimumBy cmp = Fold1 (\begin -> Fold min' begin id) where min' x y = case cmp x y of GT -> y _ -> x {-# INLINABLE minimumBy #-} foldl-1.4.15/src/Control/Foldl/Optics.hs0000644000000000000000000000110207346545000016131 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module Control.Foldl.Optics where import Data.Profunctor type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) type Prism' s a = Prism s s a a prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b prism bt seta = dimap seta (either pure (fmap bt)) . right' {-# INLINE prism #-} _Left :: Prism (Either a c) (Either b c) a b _Left = prism Left $ either Right (Left . Right) {-# INLINE _Left #-} _Right :: Prism (Either c a) (Either c b) a b _Right = prism Right $ either (Left . Left) Right {-# INLINE _Right #-} foldl-1.4.15/src/Control/Foldl/Text.hs0000644000000000000000000001446107346545000015630 0ustar0000000000000000-- | Folds for text streams module Control.Foldl.Text ( -- * Folding fold , foldM -- * Folds , head , last , null , length , any , all , maximum , minimum , elem , notElem , find , index , elemIndex , findIndex , count , lazy -- * Re-exports -- $reexports , module Control.Foldl , module Data.Text ) where import Control.Foldl (Fold, FoldM) import Control.Foldl.Internal (Maybe'(..), strict, Either'(..), hush) import Data.Text (Text) import Prelude hiding ( head, last, null, length, any, all, maximum, minimum, elem, notElem ) import qualified Control.Foldl import qualified Control.Foldl.Internal import qualified Data.Text import qualified Data.Text.Lazy -- | Apply a strict left 'Fold' to lazy text fold :: Fold Text a -> Data.Text.Lazy.Text -> a fold (Control.Foldl.Fold step begin done) as = done (Data.Text.Lazy.foldlChunks step begin as) {-# INLINABLE fold #-} -- | Apply a strict monadic left 'FoldM' to lazy text foldM :: Monad m => FoldM m Text a -> Data.Text.Lazy.Text -> m a foldM (Control.Foldl.FoldM step begin done) as = do x <- Data.Text.Lazy.foldlChunks step' begin as done x where step' mx bs = do x <- mx x `seq` step x bs {-# INLINABLE foldM #-} {-| Get the first character of a text stream or return 'Nothing' if the stream is empty -} head :: Fold Text (Maybe Char) head = Control.Foldl.Fold step Nothing' Control.Foldl.Internal.lazy where step mc txt = if Data.Text.null txt then mc else case mc of Just' _ -> mc Nothing' -> Just' (Data.Text.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 = Control.Foldl.Fold step Nothing' Control.Foldl.Internal.lazy where step mc txt = if Data.Text.null txt then mc else Just' (Data.Text.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 = Control.Foldl.Fold step True id where step isNull txt = isNull && Data.Text.null txt {-# INLINABLE null #-} -- | Return the length of the text stream in characters length :: Num n => Fold Text n length = Control.Foldl.Fold (\n txt -> n + fromIntegral (Data.Text.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 = Control.Foldl.Fold (\b txt -> b && Data.Text.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 = Control.Foldl.Fold (\b txt -> b || Data.Text.any predicate txt) False id {-# INLINABLE any #-} -- | Computes the maximum character maximum :: Fold Text (Maybe Char) maximum = Control.Foldl.Fold step Nothing' Control.Foldl.Internal.lazy where step mc txt = if Data.Text.null txt then mc else Just' (case mc of Nothing' -> Data.Text.maximum txt Just' c -> max c (Data.Text.maximum txt) ) {-# INLINABLE maximum #-} -- | Computes the minimum character minimum :: Fold Text (Maybe Char) minimum = Control.Foldl.Fold step Nothing' Control.Foldl.Internal.lazy where step mc txt = if Data.Text.null txt then mc else Just' (case mc of Nothing' -> Data.Text.minimum txt Just' c -> min c (Data.Text.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 = Control.Foldl.Fold step Nothing' Control.Foldl.Internal.lazy where step mc txt = case mc of Nothing' -> strict (Data.Text.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 = Control.Foldl.Fold step (Left' (fromIntegral i)) hush where step x txt = case x of Left' remainder -> let len = Data.Text.length txt in if remainder < len then Right' (Data.Text.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 = Control.Foldl.Fold step (Left' 0) hush where step x txt = case x of Left' m -> case Data.Text.findIndex predicate txt of Nothing -> Left' (m + fromIntegral (Data.Text.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 = Control.Foldl.Fold step 0 id where step n txt = n + fromIntegral (Data.Text.count (Data.Text.singleton c) txt) {-# INLINABLE count #-} -- | Combine all the strict `Text` chunks to build a lazy `Text` lazy :: Fold Text Data.Text.Lazy.Text lazy = fmap Data.Text.Lazy.fromChunks Control.Foldl.list {-# INLINABLE lazy #-} {- $reexports "Control.Foldl" re-exports the 'Fold' type @Data.Text@ re-exports the 'Text' type -} foldl-1.4.15/src/Control/Foldl/Util/0000755000000000000000000000000007346545000015257 5ustar0000000000000000foldl-1.4.15/src/Control/Foldl/Util/MVector.hs0000644000000000000000000000067507346545000017202 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Control.Foldl.Util.MVector where import Data.Vector.Generic.Mutable import Control.Monad.ST {-# INLINE writeListInReverseOrderStartingFrom #-} writeListInReverseOrderStartingFrom :: MVector v a => v s a -> Int -> [a] -> ST s () writeListInReverseOrderStartingFrom v = let loop !index list = case list of h : t -> do unsafeWrite v index h loop (pred index) t _ -> return () in loop foldl-1.4.15/src/Control/Foldl/Util/Vector.hs0000644000000000000000000000135407346545000017060 0ustar0000000000000000{-| General utilities for immutable vectors. -} {-# LANGUAGE RankNTypes #-} module Control.Foldl.Util.Vector where import Data.Vector.Generic import Control.Monad.ST import qualified Data.Vector.Generic.Mutable as M import qualified Control.Foldl.Util.MVector as M {-| >>> fromReverseListN 3 [1,2,3] :: Data.Vector.Vector Int [3,2,1] -} {-# INLINE fromReverseListN #-} fromReverseListN :: Vector v a => Int -> [a] -> v a fromReverseListN size list = initialized size $ \ mv -> M.writeListInReverseOrderStartingFrom mv (pred size) list {-# INLINE initialized #-} initialized :: Vector v a => Int -> (forall s. Mutable v s a -> ST s ()) -> v a initialized size initialize = runST $ do mv <- M.unsafeNew size initialize mv unsafeFreeze mv foldl-1.4.15/src/Control/Scanl.hs0000644000000000000000000003475007346545000014707 0ustar0000000000000000{-| This module provides efficient and streaming left map-with-accumulator that you can combine using 'Applicative' style. Import this module qualified to avoid clashing with the Prelude: >>> import qualified Control.Scanl as SL Use 'scan' to apply a 'Scan' to a list (or other 'Traversable' structures) from left to right, and 'scanr' to do so from right to left. Note that the `Scan` type does not supersede the `Fold` type nor does the `Fold` type supersede the `Scan` type. Each type has a unique advantage. For example, `Scan`s can be chained end-to-end: > (>>>) :: Scan a b -> Scan b c -> Scan a c In other words, `Scan` is an instance of the `Category` typeclass. `Fold`s cannot be chained end-to-end Vice versa, `Fold`s can produce a result even when fed no input: > extract :: Fold a b -> b In other words, `Fold` is an instance of the `Comonad` typeclass. A `Scan` cannot produce any output until provided with at least one input. -} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} module Control.Scanl ( -- * Scan Types Scan(..) , ScanM(..) -- * Scanning , scan , scanM , scanr , prescan , postscan -- * Utilities -- $utilities , purely , purely_ , impurely , impurely_ , generalize , simplify , hoists , arrM , premap , premapM ) where import Control.Applicative import Control.Arrow import Control.Category import Control.Foldl (Fold(..)) import Control.Foldl.Internal (Pair(..)) import Control.Monad ((<=<)) import Control.Monad.Trans.Class import qualified Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict import Data.Functor.Identity import Data.Monoid hiding ((<>)) import Data.Profunctor import Data.Traversable import Data.Tuple (swap) import Prelude hiding ((.), id, scanr) #if MIN_VERSION_base(4, 7, 0) import Data.Coerce #endif asLazy :: StateT s m a -> Lazy.StateT s m a asLazy = Lazy.StateT . runStateT --import qualified Control.Foldl as L {-| Efficient representation of a left map-with-accumulator that preserves the scan's step function and initial accumulator. This allows the 'Applicative' instance to assemble derived scans that traverse the container only once A \''Scan' a b\' processes elements of type __a__ replacing each with a value of type __b__. -} data Scan a b -- | @Scan @ @ step @ @ initial @ = forall x. Scan (a -> State x b) x instance Functor (Scan a) where fmap f (Scan step begin) = Scan (fmap f . step) begin {-# INLINE fmap #-} instance Applicative (Scan a) where pure b = Scan (\_ -> pure b) () {-# INLINE pure #-} (Scan stepL beginL) <*> (Scan stepR beginR) = let step a (Pair xL xR) = (bL bR, (Pair xL' xR')) where (bL, xL') = runState (stepL a) xL (bR, xR') = runState (stepR a) xR begin = Pair beginL beginR in Scan (state . step) begin {-# INLINE (<*>) #-} instance Profunctor Scan where lmap = premap rmap = fmap instance Category Scan where id = Scan pure () {-# INLINE id #-} (Scan s2 b2) . (Scan s1 b1) = Scan (state . step) (Pair b1 b2) where step a (Pair xL xR) = (c, Pair xL' xR') where (b, xL') = runState (s1 a) xL (c, xR') = runState (s2 b) xR {-# INLINE (.) #-} instance Arrow Scan where arr f = Scan (pure . f) () {-# INLINE arr #-} first (Scan step begin) = Scan (\(a,b) -> state $ \x -> first (,b) $ runState (step a) x) begin {-# INLINE first #-} second (Scan step begin) = Scan (\(b,a) -> state $ \x -> first (b,) $ runState (step a) x) begin {-# INLINE second #-} instance Semigroup b => Semigroup (Scan a b) where (<>) = liftA2 (<>) {-# INLINE (<>) #-} instance Monoid b => Monoid (Scan a b) where mempty = pure mempty {-# INLINE mempty #-} mappend = liftA2 mappend {-# INLINE mappend #-} instance Num b => Num (Scan a b) where fromInteger = pure . fromInteger {-# INLINE fromInteger #-} negate = fmap negate {-# INLINE negate #-} abs = fmap abs {-# INLINE abs #-} signum = fmap signum {-# INLINE signum #-} (+) = liftA2 (+) {-# INLINE (+) #-} (*) = liftA2 (*) {-# INLINE (*) #-} (-) = liftA2 (-) {-# INLINE (-) #-} instance Fractional b => Fractional (Scan a b) where fromRational = pure . fromRational {-# INLINE fromRational #-} recip = fmap recip {-# INLINE recip #-} (/) = liftA2 (/) {-# INLINE (/) #-} instance Floating b => Floating (Scan a b) where pi = pure pi {-# INLINE pi #-} exp = fmap exp {-# INLINE exp #-} sqrt = fmap sqrt {-# INLINE sqrt #-} log = fmap log {-# INLINE log #-} sin = fmap sin {-# INLINE sin #-} tan = fmap tan {-# INLINE tan #-} cos = fmap cos {-# INLINE cos #-} asin = fmap asin {-# INLINE asin #-} atan = fmap atan {-# INLINE atan #-} acos = fmap acos {-# INLINE acos #-} sinh = fmap sinh {-# INLINE sinh #-} tanh = fmap tanh {-# INLINE tanh #-} cosh = fmap cosh {-# INLINE cosh #-} asinh = fmap asinh {-# INLINE asinh #-} atanh = fmap atanh {-# INLINE atanh #-} acosh = fmap acosh {-# INLINE acosh #-} (**) = liftA2 (**) {-# INLINE (**) #-} logBase = liftA2 logBase {-# INLINE logBase #-} {-| Like 'Scan', but monadic. A \''ScanM' m a b\' processes elements of type __a__ and results in a monadic value of type __m b__. -} data ScanM m a b = -- | @ScanM @ @ step @ @ initial @ @ extract@ forall x . ScanM (a -> StateT x m b) (m x) instance Functor m => Functor (ScanM m a) where fmap f (ScanM step begin) = ScanM (fmap f . step) begin {-# INLINE fmap #-} instance Applicative m => Applicative (ScanM m a) where pure b = ScanM (\_ -> StateT $ \() -> pure (b, ())) (pure ()) {-# INLINE pure #-} (ScanM stepL beginL) <*> (ScanM stepR beginR) = let step a (Pair xL xR) = (\(bL, xL') (bR, xR') -> (bL bR, (Pair xL' xR'))) <$> runStateT (stepL a) xL <*> runStateT (stepR a) xR begin = Pair <$> beginL <*> beginR in ScanM (StateT . step) begin {-# INLINE (<*>) #-} instance Functor m => Profunctor (ScanM m) where rmap = fmap lmap f (ScanM step begin) = ScanM (step . f) begin instance Monad m => Category (ScanM m) where id = ScanM pure (pure ()) {-# INLINE id #-} (ScanM s2 b2) . (ScanM s1 b1) = ScanM (StateT . step) (Pair <$> b1 <*> b2) where step a (Pair xL xR) = do (b, xL') <- runStateT (s1 a) xL (c, xR') <- runStateT (s2 b) xR pure (c, Pair xL' xR') {-# INLINE (.) #-} instance Monad m => Arrow (ScanM m) where arr f = ScanM (lift . pure . f) (pure ()) {-# INLINE arr #-} first (ScanM step begin) = ScanM (\(a,b) -> StateT $ \x -> first (,b) <$> runStateT (step a) x) begin {-# INLINE first #-} second (ScanM step begin) = ScanM (\(b,a) -> StateT $ \x -> first (b,) <$> runStateT (step a) x) begin {-# INLINE second #-} instance (Monad m, Semigroup b) => Semigroup (ScanM m a b) where (<>) = liftA2 (<>) {-# INLINE (<>) #-} instance (Monad m, Monoid b) => Monoid (ScanM m a b) where mempty = pure mempty {-# INLINE mempty #-} mappend = liftA2 mappend {-# INLINE mappend #-} instance (Monad m, Num b) => Num (ScanM m a b) where fromInteger = pure . fromInteger {-# INLINE fromInteger #-} negate = fmap negate {-# INLINE negate #-} abs = fmap abs {-# INLINE abs #-} signum = fmap signum {-# INLINE signum #-} (+) = liftA2 (+) {-# INLINE (+) #-} (*) = liftA2 (*) {-# INLINE (*) #-} (-) = liftA2 (-) {-# INLINE (-) #-} instance (Monad m, Fractional b) => Fractional (ScanM m a b) where fromRational = pure . fromRational {-# INLINE fromRational #-} recip = fmap recip {-# INLINE recip #-} (/) = liftA2 (/) {-# INLINE (/) #-} instance (Monad m, Floating b) => Floating (ScanM m a b) where pi = pure pi {-# INLINE pi #-} exp = fmap exp {-# INLINE exp #-} sqrt = fmap sqrt {-# INLINE sqrt #-} log = fmap log {-# INLINE log #-} sin = fmap sin {-# INLINE sin #-} tan = fmap tan {-# INLINE tan #-} cos = fmap cos {-# INLINE cos #-} asin = fmap asin {-# INLINE asin #-} atan = fmap atan {-# INLINE atan #-} acos = fmap acos {-# INLINE acos #-} sinh = fmap sinh {-# INLINE sinh #-} tanh = fmap tanh {-# INLINE tanh #-} cosh = fmap cosh {-# INLINE cosh #-} asinh = fmap asinh {-# INLINE asinh #-} atanh = fmap atanh {-# INLINE atanh #-} acosh = fmap acosh {-# INLINE acosh #-} (**) = liftA2 (**) {-# INLINE (**) #-} logBase = liftA2 logBase {-# INLINE logBase #-} -- | Apply a strict left 'Scan' to a 'Traversable' container scan :: Traversable t => Scan a b -> t a -> t b -- To make it possible to consume the generated structure lazily, we must -- 'traverse' with lazy 'StateT'. scan (Scan step begin) as = fst $ Lazy.runState (traverse (asLazy . step) as) begin {-# INLINE scan #-} -- | Like 'scan' but start scanning from the right scanr :: Traversable t => Scan a b -> t a -> t b scanr (Scan step begin) as = fst (runReverseState (traverse (ReverseState #. runState . step) as) begin) {-# INLINE scanr #-} -- | Like 'scan' but monadic scanM :: (Traversable t, Monad m) => ScanM m a b -> t a -> m (t b) -- To make it possible to consume the generated structure lazily, we must -- 'traverse' with lazy 'StateT'. scanM (ScanM step begin) as = fmap fst $ Lazy.runStateT (traverse (asLazy . step) as) =<< begin {-# INLINE scanM #-} {-| Convert a `Fold` into a prescan \"Prescan\" means that the last element of the scan is not included -} prescan :: Fold a b -> Scan a b prescan (Fold step begin done) = Scan (state . step') begin where step' a x = (b, x') where x' = step x a b = done x {-# INLINE prescan #-} {-| Convert a `Fold` into a postscan \"Postscan\" means that the first element of the scan is not included -} postscan :: Fold a b -> Scan a b postscan (Fold step begin done) = Scan (state . step') begin where step' a x = (b, x') where x' = step x a b = done x' {-# INLINE postscan #-} arrM :: Monad m => (b -> m c) -> ScanM m b c arrM f = ScanM (lift . f) (pure ()) {-# INLINE arrM #-} {- $utilities -} -- | Upgrade a scan to accept the 'Scan' type purely :: (forall x . (a -> State x b) -> x -> r) -> Scan a b -> r purely f (Scan step begin) = f step begin {-# INLINABLE purely #-} -- | Upgrade a more traditional scan to accept the `Scan` type purely_ :: (forall x . (x -> a -> (x, b)) -> x -> r) -> Scan a b -> r purely_ f (Scan step begin) = f (\s a -> swap $ runState (step a) s) begin {-# INLINABLE purely_ #-} -- | Upgrade a monadic scan to accept the 'ScanM' type impurely :: (forall x . (a -> StateT x m b) -> m x -> r) -> ScanM m a b -> r impurely f (ScanM step begin) = f step begin {-# INLINABLE impurely #-} -- | Upgrade a more traditional monadic scan to accept the `ScanM` type impurely_ :: Monad m => (forall x . (x -> a -> m (x, b)) -> m x -> r) -> ScanM m a b -> r impurely_ f (ScanM step begin) = f (\s a -> swap <$> runStateT (step a) s) begin {-| Generalize a `Scan` to a `ScanM` > generalize (pure r) = pure r > > generalize (f <*> x) = generalize f <*> generalize x -} generalize :: Monad m => Scan a b -> ScanM m a b generalize (Scan step begin) = hoists (\(Identity c) -> pure c) (ScanM step (Identity begin)) {-# INLINABLE generalize #-} {-| Simplify a pure `ScanM` to a `Scan` > simplify (pure r) = pure r > > simplify (f <*> x) = simplify f <*> simplify x -} simplify :: ScanM Identity a b -> Scan a b simplify (ScanM step (Identity begin)) = Scan step begin {-# INLINABLE simplify #-} {- | Shift a 'ScanM' from one monad to another with a morphism such as 'lift' or 'liftIO'; the effect is the same as 'Control.Monad.Morph.hoist'. -} hoists :: (forall x . m x -> n x) -> ScanM m a b -> ScanM n a b hoists phi (ScanM step begin ) = ScanM (\a -> StateT $ phi . runStateT (step a)) (phi begin) {-# INLINABLE hoists #-} {-| @(premap f scaner)@ returns a new 'Scan' where f is applied at each step > scan (premap f scaner) list = scan scaner (map f list) > 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) -> Scan b r -> Scan a r premap f (Scan step begin) = Scan (step . f) begin {-# INLINABLE premap #-} {-| @(premapM f scaner)@ returns a new 'ScanM' where f is applied to each input element > premapM return = 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 -> m b) -> ScanM m b r -> ScanM m a r premapM f (ScanM step begin) = ScanM (step <=< lift . f) begin {-# INLINABLE premapM #-} -- Internal helpers (not exported) newtype ReverseState s a = ReverseState { runReverseState :: s -> (a, s) } instance Functor (ReverseState s) where fmap f (ReverseState m) = ReverseState $ \s -> let (v, s') = m s in (f v, s') {-# INLINE fmap #-} instance Applicative (ReverseState s) where pure = ReverseState #. (,) {-# INLINE pure #-} mf <*> mx = ReverseState $ \s -> let (f, s2) = runReverseState mf s1 (x, s1) = runReverseState mx s in (f x, s2) {-# INLINE (<*>) #-} #if MIN_VERSION_base(4, 10, 0) -- 'liftA2' was moved to the 'Applicative' class in base 4.10.0.0 liftA2 f mx my = ReverseState $ \s -> let (x, s2) = runReverseState mx s1 (y, s1) = runReverseState my s in (f x y, s2) {-# INLINE liftA2 #-} #endif #if MIN_VERSION_base(4, 7, 0) -- | This is same as normal function composition, except slightly more efficient. The same trick is used in base and lens (#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) (#.) _ = coerce #else (#.) :: (b -> c) -> (a -> b) -> (a -> c) (#.) = (.) #endif infixr 9 #. {-# INLINE (#.) #-} foldl-1.4.15/test/0000755000000000000000000000000007346545000012052 5ustar0000000000000000foldl-1.4.15/test/doctest.hs0000644000000000000000000000015407346545000014053 0ustar0000000000000000import Test.DocTest main :: IO () main = doctest ["-isrc", "src/Control/Foldl.hs", "src/Control/Scanl.hs"]