diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,126 @@ +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 + +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` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# `foldl` v1.2.5 +# `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 -[![Build Status](https://travis-ci.org/Gabriel439/Haskell-Foldl-Library.png)](https://travis-ci.org/Gabriel439/Haskell-Foldl-Library) +[![Build Status](https://github.com/Gabriella439/foldl/actions/workflows/haskell.yml/badge.svg)](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. diff --git a/bench/Foldl.hs b/bench/Foldl.hs new file mode 100644 --- /dev/null +++ b/bench/Foldl.hs @@ -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) diff --git a/bench/Scanl.hs b/bench/Scanl.hs new file mode 100644 --- /dev/null +++ b/bench/Scanl.hs @@ -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)) + ] + ] + ] diff --git a/bench/benchmarks.hs b/bench/benchmarks.hs deleted file mode 100644 --- a/bench/benchmarks.hs +++ /dev/null @@ -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 - ] - ] - ] diff --git a/foldl.cabal b/foldl.cabal --- a/foldl.cabal +++ b/foldl.cabal @@ -1,14 +1,13 @@ Name: foldl -Version: 1.2.5 -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,38 +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.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 , - profunctors < 5.3 , + 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 diff --git a/src/Control/Foldl.hs b/src/Control/Foldl.hs --- a/src/Control/Foldl.hs +++ b/src/Control/Foldl.hs @@ -3,42 +3,47 @@ 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 executables that use this library to further improve performance. -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} module Control.Foldl ( @@ -50,11 +55,8 @@ , fold , foldM , scan -#if MIN_VERSION_base(4,8,0) , prescan , postscan -#else -#endif -- * Folds , Control.Foldl.mconcat @@ -90,11 +92,11 @@ , Control.Foldl.mapM_ , sink - -- * Generic Folds + -- ** Generic Folds , genericLength , genericIndex - -- * Container folds + -- ** Container Folds , list , revList , nub @@ -102,8 +104,11 @@ , set , hashSet , map + , foldByKeyMap , hashMap + , foldByKeyHashMap , vector + , vectorM -- * Utilities -- $utilities @@ -113,11 +118,18 @@ , impurely_ , generalize , simplify + , lifts , hoists , duplicateM , _Fold1 , premap , premapM + , postmapM + , prefilter + , prefilterM + , predropWhile + , drop + , dropM , Handler , handles , foldOver @@ -127,6 +139,10 @@ , foldOverM , folded , filtered + , groupBy + , either + , eitherM + , nest -- * Re-exports -- $reexports @@ -135,21 +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.Monoid +import Data.HashMap.Strict (HashMap) +import Data.Map.Strict (Map) +import Data.Monoid hiding ((<>)) +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 @@ -167,6 +192,8 @@ , notElem , lookup , map + , either + , drop ) import qualified Data.Foldable as F @@ -177,8 +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 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 @@ -192,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 #-} @@ -202,6 +246,25 @@ lmap = premap rmap = fmap +instance Choice Fold where + 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 #-} @@ -220,11 +283,31 @@ 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 + mappend = (<>) {-# INLINE mappend #-} instance Num b => Num (Fold a b) where @@ -281,7 +364,7 @@ cos = fmap cos {-# INLINE cos #-} - asin = fmap sin + asin = fmap asin {-# INLINE asin #-} atan = fmap atan @@ -323,43 +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 = premapM + 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 + mappend = (<>) {-# INLINE mappend #-} instance (Monad m, Num b) => Num (FoldM m a b) where @@ -416,7 +498,7 @@ cos = fmap cos {-# INLINE cos #-} - asin = fmap sin + asin = fmap asin {-# INLINE asin #-} atan = fmap atan @@ -467,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 @@ -475,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 @@ -487,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 @@ -501,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 @@ -607,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 #-} @@ -740,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 #-} @@ -758,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 @@ -774,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) @@ -885,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. -} @@ -896,12 +1007,41 @@ 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 -vector :: (PrimMonad m, Vector v a) => FoldM m a (v a) -vector = FoldM step begin done +{-| 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 @@ -916,7 +1056,7 @@ done (Pair mv idx) = do v <- V.freeze mv return (V.unsafeTake idx v) -{-# INLINABLE vector #-} +{-# INLINABLE vectorM #-} {- $utilities 'purely' and 'impurely' allow you to write folds compatible with the @foldl@ @@ -946,17 +1086,17 @@ > 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@. + Other streaming libraries supporting 'purely' and 'impurely' include @io-streams@ and @streaming@. So for example we have: -> purely System.IO.Streams.fold_ +> purely System.IO.Streams.fold_ > :: Fold a b -> Streams.InputStream a -> IO b > -> impurely System.IO.Streams.foldM_ +> 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 + 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 @@ -1023,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'. -} @@ -1031,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. @@ -1056,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 @@ -1081,22 +1228,124 @@ {-| @(premapM f folder)@ returns a new 'FoldM' where f is applied to each input element -> foldM (premapM f folder) list = foldM folder (map f list) - -> premapM id = id +> premapM return = id > -> premapM (f . g) = premap g . premap f +> premapM (f <=< g) = premap g . premap f > premapM k (pure r) = pure r > > premapM k (f <*> x) = premapM k f <*> premapM k x -} -premapM :: (a -> b) -> FoldM m b r -> FoldM m a r +premapM :: 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 = step x (f a) + 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 + + 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` @@ -1115,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 @@ -1140,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 @@ -1165,11 +1414,18 @@ -} 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 (<>) #-} + + stimes = stimesMonoid + {-# INLINE stimes #-} + instance Monad m => Monoid (EndoM m a) where mempty = EndoM return {-# INLINE mempty #-} - mappend (EndoM f) (EndoM g) = EndoM (f <=< g) + mappend = (<>) {-# INLINE mappend #-} {-| A Handler for the upstream input of `FoldM` @@ -1205,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 @@ -1232,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 @@ -1245,6 +1501,36 @@ | 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 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 diff --git a/src/Control/Foldl/Internal.hs b/src/Control/Foldl/Internal.hs --- a/src/Control/Foldl/Internal.hs +++ b/src/Control/Foldl/Internal.hs @@ -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 diff --git a/src/Control/Foldl/NonEmpty.hs b/src/Control/Foldl/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Control/Foldl/NonEmpty.hs @@ -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 #-} diff --git a/src/Control/Foldl/Optics.hs b/src/Control/Foldl/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Control/Foldl/Optics.hs @@ -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 #-} diff --git a/src/Control/Foldl/Util/MVector.hs b/src/Control/Foldl/Util/MVector.hs new file mode 100644 --- /dev/null +++ b/src/Control/Foldl/Util/MVector.hs @@ -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 diff --git a/src/Control/Foldl/Util/Vector.hs b/src/Control/Foldl/Util/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Control/Foldl/Util/Vector.hs @@ -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 diff --git a/src/Control/Scanl.hs b/src/Control/Scanl.hs new file mode 100644 --- /dev/null +++ b/src/Control/Scanl.hs @@ -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 and lens +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) +(#.) _ = coerce +#else +(#.) :: (b -> c) -> (a -> b) -> (a -> c) +(#.) = (.) +#endif + +infixr 9 #. +{-# INLINE (#.) #-} diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -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"]