foldl 1.4.0 → 1.4.18
raw patch · 15 files changed
Files
- CHANGELOG.md +86/−0
- LICENSE +2/−2
- README.md +5/−5
- bench/Foldl.hs +97/−0
- bench/Scanl.hs +86/−0
- bench/benchmarks.hs +0/−40
- foldl.cabal +57/−27
- src/Control/Foldl.hs +295/−93
- src/Control/Foldl/Internal.hs +5/−0
- src/Control/Foldl/NonEmpty.hs +497/−0
- src/Control/Foldl/Optics.hs +20/−0
- src/Control/Foldl/Util/MVector.hs +17/−0
- src/Control/Foldl/Util/Vector.hs +27/−0
- src/Control/Scanl.hs +578/−0
- test/doctest.hs +4/−0
CHANGELOG.md view
@@ -1,3 +1,89 @@+1.4.18++- Add [`lifts`](https://github.com/Gabriella439/foldl/pull/214)+- Add [`nest`](https://github.com/Gabriella439/foldl/pull/215) for `Fold1`+- Add [`Choice`, `Closed`, `Cosieve`, `Extend`, `Semigroupoid`, `Category`, `Strong`, `Arrow` and `ArrowChoice`](https://github.com/Gabriella439/foldl/pull/215) instances for `Fold1`+- Add [`Closed`](https://github.com/Gabriella439/foldl/pull/215) instance for `Fold`+- [Define `stimes` from `EndoM`'s Semigroup instance for 0](https://github.com/Gabriella439/foldl/pull/217)++1.4.17++- Add [Fold1 utilities](https://github.com/Gabriella439/foldl/pull/212): `purely`, `purely_`, `premap`, `handles`, `foldOver`, `folded1`+- Add pattern synonym [`Fold1_`](https://github.com/Gabriella439/foldl/pull/212) that makes the initial, step and extraction functions explicit.++1.4.16++- Add [`Control.Foldl.postmapM`](https://github.com/Gabriella439/foldl/pull/205)++1.4.15++- Add `Cosieve` and `Costrong` instances++1.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
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2013 Gabriel Gonzalez+Copyright (c) 2013 Gabriella Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification,@@ -8,7 +8,7 @@ * 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+ * 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.
README.md view
@@ -1,4 +1,4 @@-# `foldl` v1.4.0+# `foldl` Use this `foldl` library when you want to compute multiple folds over a collection in one pass over the data without space leaks.@@ -94,7 +94,7 @@ ```haskell (,) <$> Fold.sum <*> Fold.length = Fold step (Pair 0 0) done where- step (Pair x y) = Pair (x + n) (y + 1)+ step (Pair x y) n = Pair (x + n) (y + 1) done (Pair x y) = (x, y) ```@@ -136,7 +136,7 @@ ## Development Status -[](https://travis-ci.org/Gabriel439/Haskell-Foldl-Library)+[](https://github.com/Gabriella439/foldl/actions/workflows/haskell.yml) 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@@ -144,7 +144,7 @@ ## License (BSD 3-clause) -Copyright (c) 2016 Gabriel Gonzalez+Copyright (c) 2016 Gabriella Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification,@@ -157,7 +157,7 @@ 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+* 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.
+ bench/Foldl.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE BangPatterns #-}++module Main (main) where++import Control.Foldl hiding (map)+import qualified Control.Foldl.NonEmpty as Foldl1+import Criterion.Main+import qualified Data.List+import Prelude hiding (length, sum)+import qualified Prelude+import qualified Data.Foldable as Foldable+import Data.Functor.Contravariant (Contravariant(..))+import Data.Profunctor (Profunctor(..))+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty++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+ ]+ ]+ , env (return $ 1 :| [2..10000 :: Int]) $ \ns ->+ bgroup "1 :| [2..10000 :: Int]"+ [ bgroup "handles" $ map ($ ns)+ [ bench "fold (handles (to succ) list)" .+ nf (fold (handles (to succ) list))+ , bench "foldM (handlesM (to succ) (generalize list))" .+ nfIO . foldM (handlesM (to succ) (generalize list))+ , bench "NonEmpty.map succ" .+ nf (NonEmpty.map succ)+ , bench "Foldl1.fold1 (Foldl1.handles (to succ) (Foldl1.fromFold list))" .+ nf (Foldl1.fold1 (Foldl1.handles (to succ) (Foldl1.fromFold list)))+ ]+ ]+ ]+++-- local definition to avoid importing Control.Lens.Getter.to+to :: (Profunctor p, Contravariant f) => (s -> a) -> p a (f a) -> p s (f s)+to k = dimap k (contramap k)+{-# INLINE to #-}++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)
+ bench/Scanl.hs view
@@ -0,0 +1,86 @@+-- 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))+ ]+ ]+ ]
− bench/benchmarks.hs
@@ -1,40 +0,0 @@-module Main (main) where--import Control.Foldl hiding (map)-import Criterion.Main-import qualified Data.List-import Prelude hiding (length, sum)-import qualified Prelude--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- ]- ]- ]
foldl.cabal view
@@ -1,14 +1,13 @@ Name: foldl-Version: 1.4.0-Cabal-Version: >=1.8.0.2+Version: 1.4.18+Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 License-File: LICENSE-Copyright: 2013 Gabriel Gonzalez-Author: Gabriel Gonzalez-Maintainer: Gabriel439@gmail.com-Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1-Bug-Reports: https://github.com/Gabriel439/Haskell-Foldl-Library/issues+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@@ -20,40 +19,71 @@ README.md Source-Repository head Type: git- Location: https://github.com/Gabriel439/Haskell-Foldl-Library+ Location: https://github.com/Gabriella439/Haskell-Foldl-Library Library HS-Source-Dirs: src Build-Depends:- base >= 4.5 && < 5 ,- bytestring >= 0.9.2.1 && < 0.11,- mwc-random >= 0.13.1.0 && < 0.14,- primitive < 0.7 ,- text >= 0.11.2.0 && < 1.3 ,- transformers >= 0.2.0.0 && < 0.6 ,- vector >= 0.7 && < 0.13,- containers >= 0.5.0.0 && < 0.6 ,+ base >= 4.11.0.0 && < 5 ,+ bytestring >= 0.9.2.1 && < 0.13,+ random >= 1.2 && < 1.3 ,+ primitive < 0.10,+ text >= 0.11.2.0 && < 2.2 ,+ transformers >= 0.2.0.0 && < 0.7 ,+ vector >= 0.7 && < 0.14,+ containers >= 0.5.0.0 && < 0.8 , unordered-containers < 0.3 ,- hashable < 1.3 ,- contravariant < 1.5 ,- semigroups >= 0.17 && < 1.19,- profunctors < 5.3 ,- comonad >= 4.0 && < 6 ,- vector-builder < 0.4+ hashable < 1.6 ,+ 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.Text+ 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 benchmarks+Benchmark Foldl Type: exitcode-stdio-1.0 HS-Source-Dirs: bench- Main-Is: benchmarks.hs+ Main-Is: Foldl.hs Build-Depends:- base,+ base >= 4.11.0.0 && < 5, criterion,+ foldl,+ profunctors+ 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 >= 4.11.0.0 && < 5,+ criterion, foldl- GHC-Options: -O2 -Wall -rtsopts+ 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 >= 4.11.0.0 && < 5,+ doctest >= 0.16+ GHC-Options: -threaded+ Default-Language: Haskell2010
src/Control/Foldl.hs view
@@ -3,32 +3,35 @@ Import this module qualified to avoid clashing with the Prelude: ->>> import qualified Control.Foldl as L+>>> import qualified Control.Foldl as Foldl Use 'fold' to apply a 'Fold' to a list: ->>> L.fold L.sum [1..100]+>>> 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 = (/) <$> L.sum <*> L.genericLength+>>> let average = (/) <$> Foldl.sum <*> Foldl.genericLength - Taking the sum, the sum of squares, ..., upto the sum of x^5+ … or you can use @do@ notation if you enable the @ApplicativeDo@ language+ extension: ->>> import Data.Traversable->>> let powerSums = sequenceA [L.premap (^n) L.sum | n <- [1..5]]->>> L.fold powerSums [1..10]-[55,385,3025,25333,220825]+>>> :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: ->>> L.fold average [1..10000000]+>>> Foldl.fold average [1..10000000] 5000000.5->>> L.fold ((,) <$> L.minimum <*> L.maximum) [1..10000000]+>>> 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@@ -36,10 +39,11 @@ -} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} module Control.Foldl (@@ -51,11 +55,8 @@ , fold , foldM , scan-#if MIN_VERSION_base(4,8,0) , prescan , postscan-#else-#endif -- * Folds , Control.Foldl.mconcat@@ -91,11 +92,11 @@ , Control.Foldl.mapM_ , sink - -- * Generic Folds+ -- ** Generic Folds , genericLength , genericIndex - -- * Container folds+ -- ** Container Folds , list , revList , nub@@ -103,7 +104,9 @@ , set , hashSet , map+ , foldByKeyMap , hashMap+ , foldByKeyHashMap , vector , vectorM @@ -115,13 +118,18 @@ , impurely_ , generalize , simplify+ , lifts , hoists , duplicateM , _Fold1 , premap , premapM+ , postmapM , prefilter , prefilterM+ , predropWhile+ , drop+ , dropM , Handler , handles , foldOver@@ -132,6 +140,9 @@ , folded , filtered , groupBy+ , either+ , eitherM+ , nest -- * Re-exports -- $reexports@@ -140,24 +151,30 @@ , module Data.Vector.Generic ) where +import Control.Foldl.Optics (_Left, _Right) import Control.Applicative-import Control.Foldl.Internal (Maybe'(..), lazy, Either'(..), hush)+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.Map.Strict (Map, alter)-import Data.Maybe (fromMaybe)+import Data.HashMap.Strict (HashMap)+import Data.Map.Strict (Map) import Data.Monoid hiding ((<>))-import Data.Semigroup (Semigroup(..))+import Data.Semigroup (Semigroup(stimes), stimesMonoid)+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 System.Random.MWC (GenIO, createSystemRandom, uniformR)+import Data.Traversable+import Numeric.Natural (Natural)+import System.Random (StdGen, newStdGen, uniformR) import Prelude hiding ( head , last@@ -175,6 +192,8 @@ , notElem , lookup , map+ , either+ , drop ) import qualified Data.Foldable as F@@ -185,10 +204,27 @@ 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 VectorBuilder.Builder-import qualified VectorBuilder.Vector+import qualified Data.Semigroupoid +{- $setup++>>> import qualified Control.Foldl as Foldl+>>> import Data.Functor.Apply (Apply(..))++>>> _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 @@ -202,8 +238,6 @@ -- | @Fold @ @ step @ @ initial @ @ extract@ = forall x. Fold (x -> a -> x) x (x -> b) -data Pair a b = Pair !a !b- instance Functor (Fold a) where fmap f (Fold step begin done) = Fold step begin (f . done) {-# INLINE fmap #-}@@ -213,9 +247,24 @@ rmap = fmap instance Choice Fold where- right' (Fold step begin done) = Fold (liftA2 step) (Right begin) (fmap done)- {-# INLINE right' #-}+ right' = nest+ {-# INLINE right' #-} +instance Closed Fold where+ closed = nest+ {-# INLINE closed #-}++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 #-}@@ -234,10 +283,26 @@ in Fold step begin done {-# INLINE (<*>) #-} -instance Monoid b => Semigroup (Fold a b) where- (<>) = liftA2 mappend+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 #-}@@ -341,49 +406,42 @@ -- | @FoldM @ @ step @ @ initial @ @ extract@ forall x . FoldM (x -> a -> m x) (m x) (x -> m b) -instance Monad m => Functor (FoldM m a) where+instance Functor 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+ done' x = fmap f $! done x {-# INLINE fmap #-} -instance Monad m => Applicative (FoldM m a) where- pure b = FoldM (\() _ -> return ()) (return ()) (\() -> return b)+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 = 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+ 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 => Profunctor (FoldM m) where+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 (Monoid b, Monad m) => Semigroup (FoldM m a b) where- (<>) = liftA2 mappend+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+ mappend = (<>) {-# INLINE mappend #-} instance (Monad m, Num b) => Num (FoldM m a b) where@@ -491,7 +549,11 @@ k $! x' {-# INLINE foldM #-} --- | Convert a strict left 'Fold' into a scan+{-| 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@@ -499,10 +561,12 @@ cons a k x = done x:(k $! step x a) {-# INLINE scan #-} -#if MIN_VERSION_base(4,8,0) {-| 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@@ -511,12 +575,15 @@ where x' = step x a b = done x- (_, bs) = List.mapAccumL step' begin as+ (_, 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@@ -525,10 +592,8 @@ where x' = step x a b = done x'- (_, bs) = List.mapAccumL step' begin as+ (_, bs) = mapAccumL step' begin as {-# INLINE postscan #-}-#else-#endif -- | Fold all values within a container using 'mappend' and 'mempty' mconcat :: Monoid a => Fold a a@@ -631,7 +696,7 @@ mean = Fold step begin done where begin = Pair 0 0- step (Pair x n) y = Pair ((x * n + y) / (n + 1)) (n + 1)+ step (Pair x n) y = let n' = n+1 in Pair (x + (y - x) /n') n' done (Pair x _) = x {-# INLINABLE mean #-} @@ -764,14 +829,14 @@ random = FoldM step begin done where begin = do- g <- createSystemRandom+ 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- n <- uniformR (1, m) g+ let (n, g') = uniformR (1, m) g let c = if n == 1 then b else a- return $! Pair3 g (Just' c) (m + 1)+ return $! Pair3 g' (Just' c) (m + 1) done (Pair3 _ ma _) = return (lazy ma) {-# INLINABLE random #-}@@ -782,7 +847,7 @@ { _size :: !VectorState , _reservoir :: !(Mutable v RealWorld a) , _position :: {-# UNPACK #-} !Int- , _gen :: {-# UNPACK #-} !GenIO+ , _gen :: {-# UNPACK #-} !StdGen } -- | Pick several random elements, using reservoir sampling@@ -798,15 +863,15 @@ let s = if n <= m' then Complete else Incomplete m' return $! RandomNState s mv (i + 1) g step (RandomNState Complete mv i g) a = do- r <- uniformR (0, i - 1) g+ 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)+ return (RandomNState Complete mv (i + 1) g') begin = do mv <- M.new n- gen <- createSystemRandom+ gen <- newStdGen let s = if n <= 0 then Complete else Incomplete 0 return (RandomNState s mv 1 gen) @@ -909,6 +974,28 @@ 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. -}@@ -920,15 +1007,30 @@ done = id {-# INLINABLE hashMap #-} --- | Fold all values into a vector-vector :: Vector v a => Fold a (v a)-vector = Fold step begin done- where- begin = VectorBuilder.Builder.empty+{- | Given a 'Fold', produces a 'HashMap' which applies that fold to each @a@ separated by key @k@. - step x a = x <> VectorBuilder.Builder.singleton a+>>> 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 - done = VectorBuilder.Vector.build+ 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@@ -1061,7 +1163,6 @@ 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'. -}@@ -1069,6 +1170,14 @@ hoists phi (FoldM step begin done) = FoldM (\a b -> phi (step a b)) (phi begin) (phi . done) {-# INLINABLE hoists #-} +{- | Lift a monadic value to a 'FoldM';+ works like 'Control.Monad.Trans.Class.lift'.++> lifts . pure = pure+-}+lifts :: Monad m => m b -> FoldM m a b+lifts mb = FoldM (\() _ -> pure ()) (pure ()) (\() -> mb)+ {-| Allows to continue feeding a 'FoldM' even after passing it to a function that closes it. @@ -1094,12 +1203,12 @@ {-| @(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 f folder) list = fold folder (List.map f list) ->>> fold (premap Sum mconcat) [1..10]+>>> fold (premap Sum Foldl.mconcat) [1..10] Sum {getSum = 55} ->>> fold mconcat (map Sum [1..10])+>>> fold Foldl.mconcat (List.map Sum [1..10]) Sum {getSum = 55} > premap id = id@@ -1133,6 +1242,19 @@ step' x a = f a >>= step x {-# INLINABLE premapM #-} +{-| @(postmapM f folder)@ returns a new 'FoldM' where f is applied to the final value.++> postmapM pure = id+>+> postmapM (f >=> g) = postmapM g . postmapM f++> postmapM k (pure r) = lifts (k r)+-}+postmapM :: Monad m => (a -> m r) -> FoldM m x a -> FoldM m x r+postmapM f (FoldM step begin done) = FoldM step begin done'+ where done' x = done x >>= f+{-# INLINABLE postmapM #-}+ {-| @(prefilter f folder)@ returns a new 'Fold' where the folder's input is used only when the input satisfies a predicate f @@ -1153,10 +1275,8 @@ step' x a = if f a then step x a else x {-# INLINABLE prefilter #-} -{-| @(prefilterM f folder)@ returns a new 'Fold' where the folder's input is used+{-| @(prefilterM f folder)@ returns a new 'FoldM' where the folder's input is used only when the input satisfies a monadic predicate f.--> foldM (prefilterM p folder) list = foldM folder (filter p list) -} prefilterM :: (Monad m) => (a -> m Bool) -> FoldM m a r -> FoldM m a r prefilterM f (FoldM step begin done) = FoldM step' begin done@@ -1166,6 +1286,66 @@ 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`@@ -1184,13 +1364,13 @@ >>> fold (handles traverse sum) [[1..5],[6..10]] 55 ->>> fold (handles (traverse.traverse) sum) [[Nothing, Just 2, Just 7],[Just 13, Nothing, Just 20]]+>>> fold (handles (traverse . traverse) sum) [[Nothing, Just 2, Just 7],[Just 13, Nothing, Just 20]] 42 >>> fold (handles (filtered even) sum) [1..10] 30 ->>> fold (handles _2 mconcat) [(1,"Hello "),(2,"World"),(3,"!")]+>>> fold (handles _2 Foldl.mconcat) [(1,"Hello "),(2,"World"),(3,"!")] "Hello World!" > handles id = id@@ -1209,17 +1389,17 @@ {- | @(foldOver f folder xs)@ folds all values from a Lens, Traversal, Prism or Fold with the given folder ->>> foldOver (_Just . both) L.sum (Just (2, 3))+>>> foldOver (_Just . both) Foldl.sum (Just (2, 3)) 5 ->>> foldOver (_Just . both) L.sum Nothing+>>> foldOver (_Just . both) Foldl.sum Nothing 0 -> L.foldOver f folder xs == L.fold folder (xs^..f)+> Foldl.foldOver f folder xs == Foldl.fold folder (xs^..f) -> L.foldOver (folded.f) folder == L.fold (handles f folder)+> Foldl.foldOver (folded . f) folder == Foldl.fold (handles f folder) -> L.foldOver folded == L.fold+> Foldl.foldOver folded == Foldl.fold -} foldOver :: Handler s a -> Fold a b -> s -> b@@ -1238,6 +1418,9 @@ (EndoM f) <> (EndoM g) = EndoM (f <=< g) {-# INLINE (<>) #-} + stimes = stimesMonoid+ {-# INLINE stimes #-}+ instance Monad m => Monoid (EndoM m a) where mempty = EndoM return {-# INLINE mempty #-}@@ -1278,9 +1461,9 @@ {- | @(foldOverM f folder xs)@ folds all values from a Lens, Traversal, Prism or Fold monadically with the given folder -> L.foldOverM (folded.f) folder == L.foldM (handlesM f folder)+> Foldl.foldOverM (folded . f) folder == Foldl.foldM (handlesM f folder) -> L.foldOverM folded == L.foldM+> Foldl.foldOverM folded == Foldl.foldM -} foldOverM :: Monad m => HandlerM m s a -> FoldM m a b -> s -> m b@@ -1305,7 +1488,7 @@ >>> fold (handles (filtered even) sum) [1..10] 30 ->>> foldM (handlesM (filtered even) (mapM_ print)) [1..10]+>>> foldM (handlesM (filtered even) (Foldl.mapM_ print)) [1..10] 2 4 6@@ -1324,11 +1507,30 @@ 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+groupBy :: Ord k => (a -> k) -> Fold a b -> Fold a (Map k b)+groupBy f = premap (\(!a) -> (f a, a)) . foldByKeyMap {-# 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
src/Control/Foldl/Internal.hs view
@@ -9,6 +9,9 @@ -- * Strict Either , Either'(..) , hush++ -- * Strict Pair+ , Pair(..) ) where -- | A strict 'Maybe'@@ -34,3 +37,5 @@ hush (Left' _) = Nothing hush (Right' b) = Just b {-# INLINABLE hush #-}++data Pair a b = Pair !a !b
+ src/Control/Foldl/NonEmpty.hs view
@@ -0,0 +1,497 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-| 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`.++ Import this module qualified to avoid clashing with the Prelude:++>>> import qualified Control.Foldl.NonEmpty as Foldl1++ Use 'fold1' to apply a 'Fold1' to a non-empty list:++>>> Foldl1.fold1 Foldl1.last (1 :| [2..10])+10++-}++module Control.Foldl.NonEmpty (+ -- * Fold Types+ Fold1(.., Fold1_)++ -- * Folding+ , Control.Foldl.NonEmpty.fold1++ -- * Conversion between Fold and Fold1+ , fromFold+ , toFold++ -- * Folds+ , sconcat+ , head+ , last+ , maximum+ , maximumBy+ , minimum+ , minimumBy++ -- ** Non-empty Container Folds+ , nonEmpty++ -- * Utilities+ , purely+ , purely_+ , premap+ , FromMaybe(..)+ , Handler1+ , handles+ , foldOver+ , folded1+ , nest+ ) where++import Control.Applicative (liftA2, Const(..))+import Control.Arrow (Arrow (..), ArrowChoice (..))+import Control.Category (Category ())+import qualified Control.Category+import Control.Comonad (Comonad(..))+import Control.Foldl (Fold(..))+import Control.Foldl.Internal (Either'(..))+import Data.List.NonEmpty (NonEmpty(..))+import Data.Monoid (Dual(..))+import Data.Functor.Apply (Apply (..))+import Data.Functor.Extend (Extend (..))+import Data.Profunctor+import Data.Profunctor.Sieve (Cosieve(..))+import Data.Semigroup.Foldable (Foldable1(..), traverse1_)+import Data.Semigroupoid (Semigroupoid (..))+import Data.Functor.Contravariant (Contravariant(..))++import Prelude hiding (head, last, minimum, maximum)++import qualified Control.Foldl as Foldl++{- $setup++>>> import qualified Control.Foldl.NonEmpty as Foldl1+>>> import qualified Data.List.NonEmpty as NonEmpty+>>> import Data.Functor.Apply (Apply(..))+>>> import Data.Semigroup.Traversable (Traversable1(..))+>>> import Data.Monoid (Sum(..))++>>> _2 f (x, y) = fmap (\i -> (x, i)) (f y)++>>> both1 f (x, y) = (,) <$> f x <.> f y++-}++{-| A `Fold1` is like a `Fold` except that it consumes at least one input+ element+-}+data Fold1 a b = Fold1 (a -> Fold a b)++{-| @Fold1_@ is an alternative to the @Fold1@ constructor if you need to+ explicitly work with an initial, step and extraction function.++ @Fold1_@ is similar to the @Fold@ constructor, which also works with an+ initial, step and extraction function. However, note that @Fold@ takes the+ step function as the first argument and the initial accumulator as the+ second argument, whereas @Fold1_@ takes them in swapped order:++ @Fold1_ @ @ initial @ @ step @ @ extract@++ While @Fold@ resembles 'Prelude.foldl', @Fold1_@ resembles+ 'Data.Foldable1.foldlMap1'.+-}+pattern Fold1_ :: forall a b. forall x. (a -> x) -> (x -> a -> x) -> (x -> b) -> Fold1 a b+pattern Fold1_ begin step done <- (toFold_ -> (begin, step, done))+ where Fold1_ begin step done = Fold1 $ \a -> Fold step (begin a) done+#if __GLASGOW_HASKELL__ >= 902+{-# INLINABLE Fold1_ #-}+#endif+{-# COMPLETE Fold1_ :: Fold1 #-}++toFold_ :: Fold1 a b -> (a -> Fold a b, Fold a b -> a -> Fold a b, Fold a b -> b)+toFold_ (Fold1 (f :: a -> Fold a b)) = (begin', step', done')+ where+ done' :: Fold a b -> b+ done' (Fold _step begin done) = done begin++ step' :: Fold a b -> a -> Fold a b+ step' (Fold step begin done) a = Fold step (step begin a) done++ begin' :: a -> Fold a b+ begin' = f+{-# INLINABLE toFold_ #-}++instance Functor (Fold1 a) where+ fmap f (Fold1 k) = Fold1 (fmap (fmap f) k)+ {-# INLINE fmap #-}++instance Profunctor Fold1 where+ lmap = premap+ {-# INLINE lmap #-}++ rmap = fmap+ {-# INLINE rmap #-}++instance Choice Fold1 where+ right' = nest+ {-# INLINE right' #-}++instance Closed Fold1 where+ closed = nest+ {-# INLINE closed #-}++instance Cosieve Fold1 NonEmpty where+ cosieve = Control.Foldl.NonEmpty.fold1+ {-# INLINE cosieve #-}++instance Applicative (Fold1 a) where+ pure b = Fold1 (pure (pure b))+ {-# INLINE pure #-}++ Fold1 l <*> Fold1 r = Fold1 (liftA2 (<*>) l r)+ {-# INLINE (<*>) #-}++instance Extend (Fold1 a) where+ duplicated (Fold1 f) = Fold1 $ fmap fromFold . duplicated . f+ {-# INLINE duplicated #-}++instance Semigroup b => Semigroup (Fold1 a b) where+ (<>) = liftA2 (<>)+ {-# INLINE (<>) #-}++instance Monoid b => Monoid (Fold1 a b) where+ mempty = pure mempty+ {-# INLINE mempty #-}++ mappend = (<>)+ {-# INLINE mappend #-}++instance Semigroupoid Fold1 where+ o (Fold1 l1) (Fold1 r1) = Fold1 f1+ where+ f1 a = let r = r1 a+ l = l1 $ extract r+ in o l r+ {-# INLINE o #-}++instance Category Fold1 where+ (.) = o+ {-# INLINE (.) #-}++ id = last+ {-# INLINE id #-}++instance Strong Fold1 where+ first' f = (,) <$> lmap fst f <*> lmap snd last+ {-# INLINE first' #-}++instance Arrow Fold1 where+ arr f = f <$> last+ {-# INLINE arr #-}++ first = first'+ {-# INLINE first #-}++instance ArrowChoice Fold1 where+ left = left'+ {-# INLINE left #-}++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 #-}++-- | Upgrade a fold to accept the 'Fold1' type+purely :: (forall x . (a -> x) -> (x -> a -> x) -> (x -> b) -> r) -> Fold1 a b -> r+purely f (Fold1_ begin step done) = f begin step done+{-# INLINABLE purely #-}++-- | Upgrade a more traditional fold to accept the `Fold1` type+purely_ :: (forall x . (a -> x) -> (x -> a -> x) -> x) -> Fold1 a b -> b+purely_ f (Fold1_ begin step done) = done (f begin step)+{-# INLINABLE purely_ #-}++{-| @(premap f folder)@ returns a new 'Fold1' where f is applied at each step++> Foldl1.fold1 (premap f folder) list = Foldl1.fold1 folder (NonEmpty.map f list)++>>> Foldl1.fold1 (premap Sum Foldl1.sconcat) (1 :| [2..10])+Sum {getSum = 55}++>>> Foldl1.fold1 Foldl1.sconcat $ NonEmpty.map Sum (1 :| [2..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) -> Fold1 b r -> Fold1 a r+premap f (Fold1 k) = Fold1 k'+ where+ k' a = lmap f (k (f a))+{-# INLINABLE premap #-}++{-|+> instance Monad m => Semigroup (FromMaybe m a) where+> mappend (FromMaybe f) (FromMaybe g) = FromMaybeM (f . Just . g)+-}+newtype FromMaybe b = FromMaybe { appFromMaybe :: Maybe b -> b }++instance Semigroup (FromMaybe b) where+ FromMaybe f <> FromMaybe g = FromMaybe (f . (Just $!) . g)+ {-# INLINE (<>) #-}++{-| A handler for the upstream input of a `Fold1`++ This is compatible with van Laarhoven optics as defined in the lens package.+ Any lens, fold1 or traversal1 will type-check as a `Handler1`.+-}+type Handler1 a b =+ forall x. (b -> Const (Dual (FromMaybe x)) b) -> a -> Const (Dual (FromMaybe x)) a++{-| @(handles t folder)@ transforms the input of a `Fold1` using a Lens,+ Traversal1, or Fold1 optic:++> handles _1 :: Fold1 a r -> Fold1 (a, b) r+> handles traverse1 :: Traversable1 t => Fold1 a r -> Fold1 (t a) r+> handles folded1 :: Foldable1 t => Fold1 a r -> Fold1 (t a) r++>>> Foldl1.fold1 (handles traverse1 Foldl1.nonEmpty) $ (1 :| [2..4]) :| [ 5 :| [6,7], 8 :| [9,10] ]+1 :| [2,3,4,5,6,7,8,9,10]++>>> Foldl1.fold1 (handles _2 Foldl1.sconcat) $ (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 :: forall a b r. Handler1 a b -> Fold1 b r -> Fold1 a r+handles k (Fold1_ begin step done) = Fold1_ begin' step' done+ where+ begin' = stepAfromMaybe Nothing+ step' x = stepAfromMaybe (Just $! x)+ stepAfromMaybe = flip (appFromMaybe . getDual . getConst . k (Const . Dual . FromMaybe . flip stepBfromMaybe))+ stepBfromMaybe = maybe begin step+{-# INLINABLE handles #-}++{- | @(foldOver f folder xs)@ folds all values from a Lens, Traversal1 or Fold1 optic with the given folder++>>> foldOver (_2 . both1) Foldl1.nonEmpty (1, (2, 3))+2 :| [3]++> Foldl1.foldOver f folder xs == Foldl1.fold1 folder (xs ^.. f)++> Foldl1.foldOver (folded1 . f) folder == Foldl1.fold1 (Foldl1.handles f folder)++> Foldl1.foldOver folded1 == Foldl1.fold1++-}+foldOver :: Handler1 s a -> Fold1 a b -> s -> b+foldOver l (Fold1_ begin step done) =+ done . stepSfromMaybe Nothing+ where+ stepSfromMaybe = flip (appFromMaybe . getDual . getConst . l (Const . Dual . FromMaybe . flip stepAfromMaybe))+ stepAfromMaybe = maybe begin step+{-# INLINABLE foldOver #-}++{-|+> handles folded1 :: Foldable1 t => Fold1 a r -> Fold1 (t a) r+-}+folded1+ :: (Contravariant f, Apply f, Foldable1 t)+ => (a -> f a) -> (t a -> f (t a))+folded1 k ts = contramap (\_ -> ()) (traverse1_ k ts)+{-# INLINABLE folded1 #-}++{-| Nest a fold in an Apply.+-}+nest :: Apply f => Fold1 a b -> Fold1 (f a) (f b)+nest (Fold1_ i s e) =+ Fold1_+ (fmap i)+ (liftF2 s)+ (fmap e)+{-# INLINABLE nest #-}
+ src/Control/Foldl/Optics.hs view
@@ -0,0 +1,20 @@+{-# 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 #-}
+ src/Control/Foldl/Util/MVector.hs view
@@ -0,0 +1,17 @@+{-# 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
+ src/Control/Foldl/Util/Vector.hs view
@@ -0,0 +1,27 @@+{-|+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
+ src/Control/Scanl.hs view
@@ -0,0 +1,578 @@+{-| 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 = (<>)+ {-# 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 = (<>)+ {-# 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 <http://hackage.haskell.org/package/base-4.11.1.0/docs/src/Data.Functor.Utils.html#%23.> and lens <http://hackage.haskell.org/package/lens-4.17/docs/Control-Lens-Internal-Coerce.html#v:-35-..>+(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)+(#.) _ = coerce+#else+(#.) :: (b -> c) -> (a -> b) -> (a -> c)+(#.) = (.)+#endif++infixr 9 #.+{-# INLINE (#.) #-}
+ test/doctest.hs view
@@ -0,0 +1,4 @@+import Test.DocTest++main :: IO ()+main = doctest ["-isrc", "src/Control/Foldl/NonEmpty.hs", "src/Control/Foldl.hs", "src/Control/Scanl.hs"]