├── .gitignore ├── LICENSE ├── Setup.hs ├── bench └── Main.hs ├── prefolds.cabal ├── readme.md ├── src ├── Data │ └── Strict │ │ ├── Drive.hs │ │ ├── Maybe.hs │ │ └── Tuple.hs ├── Experiment │ ├── SimpleStepper.hs │ └── Stepper.hs ├── Fold │ ├── Core.hs │ └── Pure.hs ├── Lib.hs ├── Prefolds.hs └── Unfold │ ├── Core.hs │ └── Pure.hs ├── stack.yaml └── test └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | *.*~ 3 | run.txt -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Main where 3 | 4 | import Prefolds 5 | import Data.Monoid 6 | import qualified Prelude as P 7 | import qualified Data.List as P 8 | import Criterion.Main 9 | import Control.Monad.Trans.State.Strict (modify) 10 | 11 | -- 140 MB total memory in use. 12 | fail1 :: IO () 13 | fail1 = print . uncurry (\xs ys -> P.sum xs + P.sum ys) . P.span (1 ==) $ 14 | replicate (10^7) (1 :: Integer) 15 | 16 | -- 2 MB total memory in use. 17 | nofail1 :: IO () 18 | nofail1 = print . exec (span (+) (1 ==) sum sum) $ replicate (10^7) (1 :: Integer) 19 | 20 | whnfFrom1To :: ([Integer] -> b) -> Integer -> Benchmarkable 21 | whnfFrom1To f = whnf $ f . P.enumFromTo 1 22 | {-# INLINE whnfFrom1To #-} 23 | 24 | whnfFrom1 :: (Int -> [Integer] -> b) -> Int -> Benchmarkable 25 | whnfFrom1 f = whnf $ \n -> f n [n `seq` 1..] 26 | {-# INLINE whnfFrom1 #-} 27 | 28 | test2 :: Integer 29 | test2 = snd $ exec f [1..10^6] where 30 | f = runFoldStateT' 0 $ traverse_ (modify . (+)) 31 | 32 | test3 :: (Integer, Integer) 33 | test3 = first getSum $ exec f [1..10^6] where 34 | f = runFoldStateT' 0 $ foldMapM (\n -> modify (n +) >> return (Sum n)) 35 | 36 | main = print test3 37 | 38 | -- Prelude version is 30% faster. It was only 20% faster, what did happen? 39 | -- Is it because the definition of `exec` was "optimized"? 40 | benchSum :: Benchmark 41 | benchSum = bgroup "sum" 42 | [ bench "Prefolds/List" $ whnfFrom1To (exec sum) (10^7) 43 | -- , bench "Prefolds/Unfold" $ whnf (\n -> pairing_ (take n sum) $ enumFrom 1) (10^7) 44 | {-, bench "Prefolds/State" $ 45 | whnfFrom1To (evalStateT . exec . runFoldStateT 0 $ traverse_ (\_ -> modify') (10^5)-} 46 | , bench "Prelude" $ whnfFrom1To P.sum (10^7) 47 | ] -- where plus = 48 | 49 | -- Prelude version is 20% slower. 50 | benchAverage :: Benchmark 51 | benchAverage = bgroup "average" 52 | [ bench "Prefolds" $ whnf average (10^7) 53 | , bench "Prelude" $ whnf paverage (10^7) 54 | ] where 55 | average n = exec ((/) <$> sum <&> genericLength) [1..n] 56 | paverage n = P.sum [1..n] / fromIntegral (P.length [1..n]) 57 | 58 | -- Prelude version is more than two times faster than `Prefolds/Mul` 59 | -- and three times faster than `Prefolds/Sum`. 60 | benchAverageTake :: Benchmark 61 | benchAverageTake = bgroup "averageTake" 62 | [ bench "Prefolds/Mul" $ whnf average (10^7) 63 | , bench "Prefolds/Sum" $ whnf average' (10^7) -- Note that this doesn't do the same job as others. 64 | , bench "Prelude" $ whnf paverage (10^7) 65 | ] where 66 | average n = exec ((/) <$> take n sum <&> take n genericLength) [n `seq` 1..] 67 | average' n = exec ((/) <$> take n sum <+> take n genericLength) [n `seq` 1..] 68 | paverage n = P.sum (P.take n [n `seq` 1..]) 69 | / fromIntegral (P.length $ P.take n [n `seq` 1..]) 70 | 71 | -- All are equal. 72 | benchSlowAverageTake :: Benchmark 73 | benchSlowAverageTake = bgroup "slowAverageTake" 74 | [ bench "Prefolds/Mul" $ whnf average (10^4) 75 | , bench "Prefolds/Sum" $ whnf average' (10^4) -- Note that this doesn't do the same job as others. 76 | , bench "Prelude" $ whnf paverage (10^4) 77 | ] where 78 | average n = exec ((/) <$> map slowId (take n sum) <&> take n genericLength) [n `seq` 1..] 79 | average' n = exec ((/) <$> map slowId (take n sum) <+> take n genericLength) [n `seq` 1..] 80 | paverage n = (P.sum . P.take n $ P.map slowId [n `seq` 1..]) 81 | / fromIntegral (P.length $ P.take n [n `seq` 1..]) 82 | 83 | slowId :: (Eq a, Num a) => a -> a 84 | slowId n = go 1000 n where 85 | go 0 n = n 86 | go m n = go (m - 1) n 87 | 88 | -- Prelude version is almost two times faster. 89 | benchScan :: Benchmark 90 | benchScan = bgroup "scan" 91 | [ bench "Prefolds.scan" $ whnfFrom1To (exec $ scan sum sum) (10^7) 92 | , bench "Prelude.scan" $ whnfFrom1To (P.sum . P.scanl' (+) 0) (10^7) 93 | ] 94 | 95 | -- Prefolds versions are nearly equal, Prelude versions are two times faster. 96 | benchScanTake :: Benchmark 97 | benchScanTake = bgroup "scanTake" 98 | [ bench "Prefolds.scan/1" $ whnfFrom1 (\n -> exec $ scan (take n sum) sum) (10^6-1) 99 | , bench "Prefolds.scan/2" $ whnfFrom1 (\n -> exec $ scan sum (take n sum)) (10^6) 100 | , bench "Prefolds.scan/3" $ whnfFrom1 (\n -> exec $ take n (scan sum sum)) (10^6-1) 101 | , bench "Prelude.scan/1" $ whnfFrom1 (\n -> P.sum . P.scanl' (+) 0 . P.take n) (10^6-1) 102 | , bench "Prelude.scan/2" $ whnfFrom1 (\n -> P.sum . P.take n . P.scanl' (+) 0) (10^6) 103 | ] 104 | 105 | -- Prelude version is 10% slower. 106 | benchGroup :: Benchmark 107 | benchGroup = bgroup "group" 108 | [ bench "Prefolds.group" . flip whnf (gen 10) $ 109 | getSum . exec (take (10^7) . group (foldMap Sum) $ sum) 110 | , bench "Prelude.group" . flip whnf (gen 10) $ 111 | P.sum . P.map (getSum . P.foldMap Sum) . P.group . P.take (10^7) 112 | ] where 113 | gen n = cycle $ replicate n 1 ++ replicate n 2 114 | 115 | -- Prelude versions are two orders of magnitude slower, but they leak and I don't see why. 116 | benchInits :: Benchmark 117 | benchInits = bgroup "inits" 118 | [ bench "Prefolds.inits" $ whnfFrom1 (\n -> exec $ inits sum (take n sum)) (10^3) 119 | , bench "Prelude.inits" $ whnfFrom1 (\n -> P.sum . P.take n . P.map P.sum . P.inits) (10^3) 120 | , bench "Prelude.lazyInits" $ whnfFrom1 (\n -> P.sum . P.take n . P.map P.sum . lazyInits) (10^3) 121 | ] where 122 | lazyInits :: [a] -> [[a]] 123 | lazyInits = foldr (\x -> ([] :) . P.map (x:)) [[]] 124 | 125 | -- `Prefolds.bind` and `Prefolds.apply` are 15% slower. 126 | benchBind :: Benchmark 127 | benchBind = bgroup "bind" 128 | [ bench "Prefolds.bind" $ whnfFrom1 (\n -> exec $ take 0 sum >> take n sum) (10^6) 129 | , bench "Prefolds.apply" $ whnfFrom1 (\n -> exec $ take 0 sum *> take n sum) (10^6) 130 | , bench "Prefolds.nobind" $ whnfFrom1 (\n -> exec $ take n sum) (10^6) 131 | ] 132 | 133 | suite :: [Benchmark] 134 | suite = 135 | [ benchSum 136 | {-, benchAverage 137 | , benchAverageTake 138 | , benchSlowAverageTake 139 | , benchScan 140 | , benchScanTake 141 | , benchGroup 142 | , benchInits 143 | , benchBind-} 144 | ] 145 | 146 | benchSuite :: IO () 147 | benchSuite = defaultMain suite 148 | 149 | -- main = benchSuite 150 | -------------------------------------------------------------------------------- /prefolds.cabal: -------------------------------------------------------------------------------- 1 | name: prefolds 2 | version: 0.1.0.0 3 | synopsis: Composable short-circuiting streaming folds. 4 | description: Please see readme.md 5 | homepage: https://github.com/effectfully/prefolds 6 | license: BSD3 7 | license-file: LICENSE 8 | author: effectfully 9 | maintainer: effectfully@gmail.com 10 | copyright: 2016 11 | category: Control 12 | build-type: Simple 13 | extra-source-files: readme.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: 18 | src 19 | exposed-modules: 20 | Data.Strict.Tuple 21 | , Data.Strict.Maybe 22 | , Data.Strict.Drive 23 | , Lib 24 | , Prefolds 25 | other-modules: 26 | Fold.Pure 27 | , Fold.Core 28 | , Unfold.Pure 29 | , Unfold.Core 30 | build-depends: 31 | base 32 | , comonad 33 | -- I have no idea why haskell-mode requires this. 34 | , criterion 35 | , mmorph 36 | , transformers 37 | default-language: 38 | Haskell2010 39 | GHC-Options: 40 | -O2 -Wall -fno-warn-unused-matches 41 | 42 | test-suite prefolds-test 43 | type: 44 | exitcode-stdio-1.0 45 | hs-source-dirs: 46 | test 47 | main-is: 48 | Main.hs 49 | build-depends: 50 | base 51 | , mmorph 52 | , prefolds 53 | , transformers 54 | ghc-options: 55 | -O2 56 | default-language: 57 | Haskell2010 58 | 59 | Benchmark prefolds-bench 60 | type: 61 | exitcode-stdio-1.0 62 | hs-source-dirs: 63 | bench 64 | main-is: 65 | Main.hs 66 | build-depends: 67 | base 68 | , criterion 69 | , mmorph 70 | , prefolds 71 | , transformers 72 | ghc-options: 73 | -O2 -rtsopts -with-rtsopts=-sstderr 74 | default-language: 75 | Haskell2010 76 | 77 | source-repository head 78 | type: git 79 | location: https://github.com/effectfully/prefolds 80 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # prefolds 2 | 3 | ## A quick taste 4 | 5 | With [`Control.Foldl`](https://hackage.haskell.org/package/foldl-1.2.1/docs/Control-Foldl.html) you can write 6 | 7 | ```haskell 8 | fold ((/) <$> sum <*> genericLength) [1..10^6] 9 | ``` 10 | 11 | and it'll stream. 12 | 13 | With `prefolds` you can write 14 | 15 | ```haskell 16 | exec ((/) <$> take (10^6) sum <&> take (10^6) genericLength) [1..] 17 | ``` 18 | 19 | and it'll stream too. 20 | 21 | With `Control.Foldl` `fold null [1..10^6]` will traverse the entire list. With `prefolds` the following holds: `exec null (1:undefined) ≡ False`. As well as `exec (take 0 undefined) ≡ []`. And folds are monadic, e.g. `exec (take 2 sum >>= \n -> take n list) [1..6] ≡ [3..5]`. 22 | 23 | ## Overview 24 | 25 | There are multiple ways to compose folds: 26 | 27 | 1. `f <+> g` reads as "consume a stream by `f` and `g` in parallel, stop when both folds are saturated and apply the result of `f` to the result of `g`". 28 | 2. `f <&> g` reads as "consume a stream by `f` and `g` in parallel, stop when either fold is saturated and apply the result of `f` to the result of `g`". That's what `Control.Foldl` has. 29 | 3. `f <*> g` reads as "consume a stream by `f`, then, when `f` is saturated, consume the rest of the stream by `g` and apply the result of `f` to the result of `g`". 30 | 4. `f >>= h` reads as "consume a stream by `f`, then, when `f` is saturated, pass the result to `h` 31 | and consume the rest of the stream by the resulting fold. 32 | 4. `scan f g` reads as "scan a stream with `f`, then consume the resulting stream by `g`". 33 | 5. `groupBy p f g` reads as "groupBy elements of a stream by `p`, fold substreams by `f`, then fold the resulting stream by `g`". 34 | 6. `inits f g` reads as "fold "inits" of a stream by `f`, then fold the resulting stream by `g`". 35 | 7. `chunks f g` reads as "fold a stream with `f`, then, when `f` is saturated, fold the rest of the stream with `f`, then, when `f` is saturated... and then fold the resulting stream with `g`". 36 | 37 | Here is an extended example: 38 | 39 | ```haskell 40 | -- Prints 41 | -- 2 42 | -- 4 43 | -- 6 44 | -- [120,12] 45 | -- [7,8,9,10] 46 | -- 11 47 | example :: IO () 48 | example = execM (final <$> sink1 <+> sink2 <*> sink3 <&>> total) [1..] where 49 | final x y zs n = print [x,y] >> print zs >> print n 50 | sink1 = take 4 $ map succ product -- 2 * 3 * 4 * 5 = 120 51 | sink2 = take 6 . filter even $ traverse_ print &> sum -- 2 + 4 + 6 = 12 52 | sink3 = takeWhile (<= 10) list -- [7,8,9,10] 53 | total = length -- total number of processed elements is 11, since 54 | -- `takeWhile (<= 10)` forced `11` before it stopped. 55 | ``` 56 | 57 | Here we compose four streaming folds. `(<+>)` and others have the same associativity and fixity as `(<$>)`, so the fold is parsed as 58 | 59 | ```haskell 60 | ((((final <$> sink1) <+> sink2) <*> sink3) <&>> total) 61 | ``` 62 | 63 | This reads as follows: 64 | 65 | 1. Consume a stream in parallel by `sink1` and `sink2` and stop when both are saturated. 66 | 2. Consume the rest of the stream by `sink3` 67 | 3. While performing 1. and 2. also consume the stream by `total` and stop when either 1. and 2. is stopped or `total` is saturated (which can't happen, since an attempt to find the length of an infinite list diverges). 68 | 4. Collect results and pass them to `final`. 69 | 70 | ## Internals 71 | 72 | `Fold` is defined almost as the one in `Control.Foldl`: 73 | 74 | ```haskell 75 | data Fold a m b = forall acc. Fold (acc -> m b) (acc -> a -> DriveT m acc) (DriveT m acc) 76 | ``` 77 | 78 | except that we have this `DriveT` transformer which turns a `Monad` into a "`MonoMonad`". 79 | 80 | ```haskell 81 | data Drive a = Stop !a | More !a 82 | newtype DriveT m a = DriveT { getDriveT :: m (Drive a) } 83 | ``` 84 | 85 | If an accumulator is in the `Stop` state, then the fold is saturated. If an accumulator is in the `More` state, then the fold can consume more input. `Drive` (and `DriveT m` for `Monad m`) is an `Applicative` in two ways: 86 | 87 | ```haskell 88 | instance SumApplicative Drive where 89 | spure = Stop 90 | 91 | Stop f <+> Stop x = Stop $ f x 92 | f <+> x = More $ runDrive f (runDrive x) 93 | 94 | instance AndApplicative Drive where 95 | apure = More 96 | 97 | More f <&> More x = More $ f x 98 | f <&> x = Stop $ runDrive f (runDrive x) 99 | ``` 100 | 101 | `SumApplicative` and `AndApplicative` have the same methods and laws as `Applicative` except methods are named differently. There are corresponding `SumMonad` and `AndMonad` instances, but they don't allow to terminate execution early (like with `Either`), because, well, how would you define `Stop x >>= f = Stop x` if `f :: a -> m b` and you're supposed to return a `m b`, but `Stop x :: m a`? So there is another type class: 102 | 103 | ```haskell 104 | -- The usual monad laws. 105 | class Functor m => MonoMonad m where 106 | mpure :: a -> m a 107 | (>>#) :: m a -> (a -> m a) -> m a 108 | 109 | (>#>) :: (a -> m a) -> (a -> m a) -> a -> m a 110 | f >#> g = \x -> f x >># g 111 | ``` 112 | 113 | With this we can define 114 | 115 | ```haskell 116 | instance MonoMonad Drive where 117 | Stop x >># f = Stop x 118 | More x >># f = f x 119 | ``` 120 | 121 | `Drive` and `DriveT m` are also `Comonad`s: 122 | 123 | ```haskell 124 | instance Comonad Drive where 125 | extract = runDrive 126 | 127 | extend f = drive (Stop . f . Stop) (More . f . More) 128 | 129 | instance Monad m => Comonad (DriveT m) where 130 | extract = error "there is no `extract` for `DriveT m` unless `m` is a comonad, \ 131 | \ but this is not needed for `extend`, which is more important than `extract`" 132 | 133 | extend f = ... 134 | ``` 135 | 136 | The last instance is used a lot across the code. 137 | 138 | There are also some `MonadTrans`-like type classes: 139 | 140 | ```haskell 141 | -- Transforms a Monad into a SumApplicative. 142 | class SumApplicativeTrans t where 143 | slift :: Monad m => m a -> t m a 144 | 145 | -- Transforms a Monad into an AndApplicative. 146 | class AndApplicativeTrans t where 147 | mlift :: Monad m => m a -> t m a 148 | ``` 149 | 150 | Instances of these type classes: 151 | 152 | ```haskell 153 | instance SumApplicativeTrans DriveT where 154 | slift a = DriveT $ Stop <$> a 155 | 156 | instance AndApplicativeTrans DriveT where 157 | mlift a = DriveT $ More <$> a 158 | ``` 159 | 160 | Here are some suggestive synonyms: 161 | 162 | ```haskell 163 | halt :: SumApplicative f => a -> f a 164 | halt = spure 165 | 166 | more :: MonoMonad m => a -> m a 167 | more = mpure 168 | 169 | haltWhen :: (SumApplicative m, MonoMonad m) => (a -> Bool) -> a -> m a 170 | haltWhen p x = if p x then halt x else more x 171 | 172 | moreWhen :: (SumApplicative m, MonoMonad m) => (a -> Bool) -> a -> m a 173 | moreWhen p x = if p x then more x else halt x 174 | 175 | stop :: (SumApplicativeTrans t, Monad m) => m a -> t m a 176 | stop = slift 177 | 178 | keep :: (AndApplicativeTrans t, Monad m) => m a -> t m a 179 | keep = alift 180 | 181 | terminate :: (SumApplicative m, MonoMonad m) => m a -> m a 182 | terminate a = a >># halt 183 | 184 | terminateWhen :: (SumApplicative m, MonoMonad m) => (a -> Bool) -> m a -> m a 185 | terminateWhen p a = a >># \x -> if p x then halt x else more x 186 | ``` 187 | 188 | `Fold a m` is a `Monad`, a `SumApplicative` and an `AndApplicative` (as you've seen in the example above) and `Fold a` is a `SumApplicativeTrans` and an `AndApplicativeTrans`. 189 | 190 | ## Kleisli functors 191 | 192 | As to that `(<&>>)`... have you ever wanted to apply `f :: a -> b -> m c` to `a :: m a` and `b :: m b` in applicative style and get `m c`? You can do `join $ f <$> a <*> b`, but this is kinda verbose. So we can define a special purpose combinator 193 | 194 | ```haskell 195 | (<*>>) :: Monad m => m (a -> m b) -> m a -> m c 196 | f <*>> a = f >>= (a >>=) 197 | ``` 198 | 199 | But there is a nice abstract structure behind this combinator that gives us such combinators for all our Applicative-like classes, namely the one of [Kleisli Functors](https://elvishjerricco.github.io/2016/10/12/kleisli-functors.html): 200 | 201 | ```haskell 202 | class (Monad m, Functor f) => KleisliFunctor m f where 203 | kmap :: (a -> m b) -> f a -> f b 204 | kmap = kjoin .* fmap 205 | 206 | kjoin :: f (m a) -> f a 207 | kjoin = kmap id 208 | 209 | (<$>>) :: KleisliFunctor m f => (a -> m b) -> f a -> f b 210 | (<$>>) = kmap 211 | 212 | (<*>>) :: (KleisliFunctor m f, Applicative f) => f (a -> m b) -> f a -> f b 213 | h <*>> a = kjoin $ h <*> a 214 | 215 | (<+>>) :: (KleisliFunctor m f, SumApplicative f) => f (a -> m b) -> f a -> f b 216 | h <+>> a = kjoin $ h <+> a 217 | 218 | (<&>>) :: (KleisliFunctor m f, AndApplicative f) => f (a -> m b) -> f a -> f b 219 | h <&>> a = kjoin $ h <&> a 220 | 221 | instance Monad m => KleisliFunctor m m where 222 | kmap = (=<<) 223 | ``` 224 | 225 | And this instance 226 | 227 | ```haskell 228 | instance Monad m => KleisliFunctor m (Fold a m) where 229 | kmap h (Fold g f a) = Fold (g >=> h) f a 230 | ``` 231 | 232 | allows to use `(<&>>)` the way it's used above. 233 | -------------------------------------------------------------------------------- /src/Data/Strict/Drive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 2 | module Data.Strict.Drive where 3 | 4 | import Lib 5 | 6 | infixl 1 >>~, >~> 7 | 8 | class (Functor f, Functor g) => Absorb f g where 9 | (>>~) :: f a -> (a -> g b) -> g b 10 | a >>~ f = abjoin $ fmap f a 11 | {-# INLINE (>>~) #-} 12 | 13 | abjoin :: f (g a) -> g a 14 | abjoin a = a >>~ id 15 | {-# INLINE abjoin #-} 16 | 17 | (>~>) :: Absorb f m => (a -> f b) -> (b -> m c) -> a -> m c 18 | f >~> g = \x -> f x >>~ g 19 | {-# INLINE (>~>) #-} 20 | 21 | data Drive a = Stop !a | More !a 22 | 23 | drive :: (a -> b) -> (a -> b) -> Drive a -> b 24 | drive f g (Stop x) = f x 25 | drive f g (More x) = g x 26 | {-# INLINABLE drive #-} 27 | 28 | runDrive :: Drive a -> a 29 | runDrive = drive id id 30 | {-# INLINEABLE runDrive #-} 31 | 32 | isStop :: Drive a -> Bool 33 | isStop = drive (const True) (const False) 34 | {-# INLINABLE isStop #-} 35 | 36 | isMore :: Drive a -> Bool 37 | isMore = drive (const False) (const True) 38 | {-# INLINABLE isMore #-} 39 | 40 | driveToEither :: Drive a -> Either a a 41 | driveToEither = drive Left Right 42 | {-# INLINABLE driveToEither #-} 43 | 44 | instance Functor Drive where 45 | fmap f = drive (Stop . f) (More . f) 46 | {-# INLINEABLE fmap #-} 47 | 48 | instance SumApplicative Drive where 49 | spure = Stop 50 | {-# INLINEABLE spure #-} 51 | 52 | Stop f <+> Stop x = Stop $ f x 53 | f <+> x = More $ runDrive f (runDrive x) 54 | {-# INLINEABLE (<+>) #-} 55 | 56 | instance AndApplicative Drive where 57 | apure = More 58 | {-# INLINEABLE apure #-} 59 | 60 | More f <&> More x = More $ f x 61 | f <&> x = Stop $ runDrive f (runDrive x) 62 | {-# INLINEABLE (<&>) #-} 63 | 64 | instance Foldable Drive where 65 | foldMap = foldMapDefault 66 | {-# INLINEABLE foldMap #-} 67 | 68 | instance Traversable Drive where 69 | traverse f = drive (Stop <.> f) (More <.> f) 70 | {-# INLINEABLE traverse #-} 71 | 72 | instance MonoMonad Drive where 73 | mpure = apure 74 | {-# INLINABLE mpure #-} 75 | 76 | a >># f = drive Stop f a 77 | {-# INLINABLE (>>#) #-} 78 | 79 | instance Comonad Drive where 80 | extract = runDrive 81 | {-# INLINEABLE extract #-} 82 | 83 | extend f = drive (Stop . f . Stop) (More . f . More) 84 | {-# INLINEABLE extend #-} 85 | 86 | -- Is there a type class for this? 87 | sequenceBi :: Bifunctor f => Drive (f a b) -> f (Drive a) (Drive b) 88 | sequenceBi = drive (bimap Stop Stop) (bimap More More) 89 | {-# INLINABLE sequenceBi #-} 90 | 91 | newtype DriveT m a = DriveT { getDriveT :: m (Drive a) } 92 | 93 | driveToDriveT :: Applicative f => Drive a -> DriveT f a 94 | driveToDriveT = DriveT . pure 95 | {-# INLINEABLE driveToDriveT #-} 96 | 97 | driveT :: Functor f => (a -> b) -> (a -> b) -> DriveT f a -> f b 98 | driveT g f (DriveT a) = drive g f <$> a 99 | {-# INLINEABLE driveT #-} 100 | 101 | driveTM :: Monad m => (a -> m b) -> (a -> m b) -> DriveT m a -> m b 102 | driveTM g f (DriveT a) = a >>= drive g f 103 | {-# INLINEABLE driveTM #-} 104 | 105 | runDriveT :: Functor f => DriveT f a -> f a 106 | runDriveT (DriveT a) = runDrive <$> a 107 | {-# INLINEABLE runDriveT #-} 108 | 109 | driveDriveT :: Monad m => (a -> DriveT m b) -> (a -> DriveT m b) -> DriveT m a -> DriveT m b 110 | driveDriveT f g (DriveT a) = a >>~ drive f g 111 | {-# INLINABLE driveDriveT #-} 112 | 113 | isStopT :: Functor f => DriveT f a -> f Bool 114 | isStopT (DriveT a) = isStop <$> a 115 | {-# INLINABLE isStopT #-} 116 | 117 | isMoreT :: Functor f => DriveT f a -> f Bool 118 | isMoreT (DriveT a) = isMore <$> a 119 | {-# INLINABLE isMoreT #-} 120 | 121 | driveToExceptT :: Monad m => DriveT m a -> ExceptT a m a 122 | driveToExceptT (DriveT a) = ExceptT $ driveToEither <$> a 123 | {-# INLINABLE driveToExceptT #-} 124 | 125 | -- A few slightly asymmetric synonyms to make things readable. 126 | halt :: SumApplicative f => a -> f a 127 | halt = spure 128 | {-# INLINEABLE halt #-} 129 | 130 | more :: MonoMonad m => a -> m a 131 | more = mpure 132 | {-# INLINEABLE more #-} 133 | 134 | haltWhen :: (SumApplicative m, MonoMonad m) => (a -> Bool) -> a -> m a 135 | haltWhen p x = if p x then halt x else more x 136 | {-# INLINEABLE haltWhen #-} 137 | 138 | moreWhen :: (SumApplicative m, MonoMonad m) => (a -> Bool) -> a -> m a 139 | moreWhen p x = if p x then more x else halt x 140 | {-# INLINEABLE moreWhen #-} 141 | 142 | stop :: (SumApplicativeTrans t, Monad m) => m a -> t m a 143 | stop = slift 144 | {-# INLINEABLE stop #-} 145 | 146 | keep :: (AndApplicativeTrans t, Monad m) => m a -> t m a 147 | keep = alift 148 | {-# INLINEABLE keep #-} 149 | 150 | terminate :: (SumApplicative m, MonoMonad m) => m a -> m a 151 | terminate a = a >># halt 152 | {-# INLINEABLE terminate #-} 153 | 154 | terminateWhen :: (SumApplicative m, MonoMonad m) => (a -> Bool) -> m a -> m a 155 | terminateWhen p a = a >># \x -> if p x then halt x else more x 156 | {-# INLINEABLE terminateWhen #-} 157 | 158 | instance Functor f => Functor (DriveT f) where 159 | fmap f (DriveT a) = DriveT $ fmap (fmap f) a 160 | {-# INLINEABLE fmap #-} 161 | 162 | instance Applicative f => SumApplicative (DriveT f) where 163 | spure = DriveT . pure . Stop 164 | {-# INLINEABLE spure #-} 165 | 166 | DriveT h <+> DriveT a = DriveT $ (<+>) <$> h <*> a 167 | {-# INLINEABLE (<+>) #-} 168 | 169 | instance Applicative f => AndApplicative (DriveT f) where 170 | apure = DriveT . pure . More 171 | {-# INLINEABLE apure #-} 172 | 173 | DriveT h <&> DriveT a = DriveT $ (<&>) <$> h <*> a 174 | {-# INLINEABLE (<&>) #-} 175 | 176 | instance Foldable m => Foldable (DriveT m) where 177 | foldMap f (DriveT a) = foldMap (f . runDrive) a 178 | {-# INLINEABLE foldMap #-} 179 | 180 | instance Traversable m => Traversable (DriveT m) where 181 | traverse f (DriveT a) = fmap DriveT $ traverse (traverse f) a 182 | {-# INLINEABLE traverse #-} 183 | 184 | instance Monad m => MonoMonad (DriveT m) where 185 | mpure = apure 186 | {-# INLINABLE mpure #-} 187 | 188 | a >># f = driveDriveT halt f a 189 | {-# INLINABLE (>>#) #-} 190 | 191 | instance Monad m => Comonad (DriveT m) where 192 | extract = error "there is no `extract` for `DriveT m` unless `m` is a comonad, \ 193 | \ but this is not needed for `extend`, which is more important than `extract`" 194 | 195 | extend f = driveDriveT (halt . f . halt) (more . f . more) 196 | {-# INLINABLE extend #-} 197 | 198 | instance SumApplicativeTrans DriveT where 199 | slift a = DriveT $ Stop <$> a 200 | {-# INLINEABLE slift #-} 201 | 202 | instance AndApplicativeTrans DriveT where 203 | alift a = DriveT $ More <$> a 204 | {-# INLINEABLE alift #-} 205 | 206 | instance MFunctor DriveT where 207 | hoist h (DriveT a) = DriveT $ h a 208 | {-# INLINEABLE hoist #-} 209 | 210 | instance TransTraversable DriveT (ReaderT r) where 211 | sequenceT (DriveT (ReaderT f)) = ReaderT $ DriveT . f 212 | {-# INLINEABLE sequenceT #-} 213 | 214 | runDriveReaderT :: Monad m => r -> DriveT (ReaderT r m) a -> DriveT m a 215 | runDriveReaderT r = flip runReaderT r . sequenceT 216 | {-# INLINEABLE runDriveReaderT #-} 217 | 218 | instance TransTraversable DriveT (StateT s) where 219 | sequenceT (DriveT (StateT f)) = StateT $ DriveT . uncurry tupr <.> f 220 | {-# INLINEABLE sequenceT #-} 221 | 222 | runDriveStateT :: Monad m => s -> DriveT (StateT s m) a -> DriveT m (a, s) 223 | runDriveStateT s = flip runStateT s . sequenceT 224 | {-# INLINEABLE runDriveStateT #-} 225 | 226 | instance TransTraversable DriveT (ExceptT e) where 227 | sequenceT (DriveT (ExceptT s)) = ExceptT . DriveT $ either (Stop . Left) (fmap Right) <$> s 228 | {-# INLINEABLE sequenceT #-} 229 | 230 | runDriveExceptT :: Monad m => DriveT (ExceptT e m) a -> DriveT m (Either e a) 231 | runDriveExceptT = runExceptT . sequenceT 232 | {-# INLINEABLE runDriveExceptT #-} 233 | 234 | instance Monad m => Absorb (DriveT m) m where 235 | a >>~ f = runDriveT a >>= f 236 | {-# INLINEABLE (>>~) #-} 237 | 238 | instance Monad m => Absorb m (DriveT m) where 239 | a >>~ f = DriveT $ a >>= getDriveT . f 240 | {-# INLINEABLE (>>~) #-} 241 | -------------------------------------------------------------------------------- /src/Data/Strict/Maybe.hs: -------------------------------------------------------------------------------- 1 | module Data.Strict.Maybe where 2 | 3 | data Maybe' a = Just' !a | Nothing' 4 | 5 | lazy :: Maybe' a -> Maybe a 6 | lazy Nothing' = Nothing 7 | lazy (Just' a) = Just a 8 | {-# INLINABLE lazy #-} 9 | 10 | strict :: Maybe a -> Maybe' a 11 | strict Nothing = Nothing' 12 | strict (Just a) = Just' a 13 | {-# INLINABLE strict #-} 14 | 15 | maybe' :: b -> (a -> b) -> Maybe' a -> b 16 | maybe' y f Nothing' = y 17 | maybe' y f (Just' x) = f x 18 | {-# INLINABLE maybe' #-} 19 | -------------------------------------------------------------------------------- /src/Data/Strict/Tuple.hs: -------------------------------------------------------------------------------- 1 | module Data.Strict.Tuple where 2 | 3 | import Data.Bifunctor 4 | 5 | data Pair a b = Pair !a !b 6 | data Triple a b c = Triple !a !b !c 7 | data Quadruple a b c d = Quadruple !a !b !c !d 8 | 9 | instance Functor (Pair a) where 10 | fmap f (Pair a b) = Pair a (f b) 11 | {-# INLINE fmap #-} 12 | 13 | instance Bifunctor Pair where 14 | bimap f g (Pair a b) = Pair (f a) (g b) 15 | {-# INLINE bimap #-} 16 | 17 | instance Monoid a => Applicative (Pair a) where 18 | pure = Pair mempty 19 | {-# INLINE pure #-} 20 | 21 | Pair x1 g <*> Pair x2 y = Pair (x1 `mappend` x2) (g y) 22 | {-# INLINE (<*>) #-} 23 | 24 | instance Functor (Triple a b) where 25 | fmap f (Triple a b c) = Triple a b (f c) 26 | {-# INLINE fmap #-} 27 | 28 | instance Bifunctor (Triple a) where 29 | bimap f g (Triple a b c) = Triple a (f b) (g c) 30 | {-# INLINE bimap #-} 31 | 32 | instance Functor (Quadruple a b c) where 33 | fmap f (Quadruple a b c d) = Quadruple a b c (f d) 34 | {-# INLINE fmap #-} 35 | 36 | instance Bifunctor (Quadruple a b) where 37 | bimap f g (Quadruple a b c d) = Quadruple a b (f c) (g d) 38 | {-# INLINE bimap #-} 39 | 40 | fstp :: Pair a b -> a 41 | fstp (Pair a b) = a 42 | {-# INLINE fstp #-} 43 | 44 | sndp :: Pair a b -> b 45 | sndp (Pair a b) = b 46 | {-# INLINE sndp #-} 47 | 48 | fromPair :: Pair a b -> (a, b) 49 | fromPair (Pair a b) = (a, b) 50 | {-# INLINE fromPair #-} 51 | 52 | toPair :: (a, b) -> Pair a b 53 | toPair (a, b) = Pair a b 54 | {-# INLINE toPair #-} 55 | 56 | fstt :: Triple a b c -> a 57 | fstt (Triple a b c) = a 58 | {-# INLINE fstt #-} 59 | 60 | sndt :: Triple a b c -> b 61 | sndt (Triple a b c) = b 62 | {-# INLINE sndt #-} 63 | 64 | thdt :: Triple a b c -> c 65 | thdt (Triple a b c) = c 66 | {-# INLINE thdt #-} 67 | 68 | fstq :: Quadruple a b c d -> a 69 | fstq (Quadruple a b c d) = a 70 | {-# INLINE fstq #-} 71 | 72 | sndq :: Quadruple a b c d -> b 73 | sndq (Quadruple a b c d) = b 74 | {-# INLINE sndq #-} 75 | 76 | thdq :: Quadruple a b c d -> c 77 | thdq (Quadruple a b c d) = c 78 | {-# INLINE thdq #-} 79 | 80 | fthq :: Quadruple a b c d -> d 81 | fthq (Quadruple a b c d) = d 82 | {-# INLINE fthq #-} 83 | -------------------------------------------------------------------------------- /src/Experiment/SimpleStepper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 2 | {-# LANGUAGE RankNTypes, ExistentialQuantification, NoImplicitPrelude #-} 3 | module SimpleStepper where 4 | 5 | import Lib 6 | import Data.Strict.Tuple 7 | import Data.Strict.Drive 8 | 9 | class (Functor f, Functor g, Monad m) => Pairing f g m where 10 | interpret :: (a -> b -> m c) -> f b -> g a -> m c 11 | 12 | data Stepper f m b = forall acc. Stepper (acc -> m b) (acc -> f (DriveT m acc)) (DriveT m acc) 13 | 14 | instance Monad m => Functor (Stepper f m) where 15 | fmap h (Stepper g f a) = Stepper (h <.> g) f a 16 | {-# INLINEABLE fmap #-} 17 | 18 | instance Pairing f g m => Pairing (Stepper f m) (Stepper g m) m where 19 | interpret h (Stepper g2 f2 a2) (Stepper g1 f1 a1) = go a1 a2 where 20 | go a1 a2 = driveTM (\(Pair a1' a2') -> h <$> g1 a1' <*>> g2 a2') 21 | (\(Pair a1' a2') -> interpret go (f2 a2') (f1 a1')) 22 | (Pair <$> a1 <&> a2) 23 | {-# INLINEABLE interpret #-} 24 | 25 | take :: (Functor f, Monad m) => Int -> Stepper f m b -> Stepper f m b 26 | take n (Stepper g f a) = Stepper (g . sndp) step (finish n a) where 27 | finish n a = terminateWhen ((<= 0) . fstp) $ Pair n <$> a 28 | 29 | step (Pair n a) | n <= 0 = error "Stepper.take: panic" 30 | | otherwise = finish (n - 1) <$> f a 31 | {-# INLINABLE take #-} 32 | 33 | instance Monad m => Pairing ((->) a) ((,) (m a)) m where 34 | interpret g f (a, b) = a >>= g b . f 35 | {-# INLINEABLE interpret #-} 36 | 37 | type Fold a = Stepper ((->) a) 38 | type Unfold a m = Stepper ((,) (m a)) m 39 | 40 | test :: Monad m => Fold a m (b -> m c) -> Unfold a m b -> m c 41 | test = interpret (flip id) 42 | -------------------------------------------------------------------------------- /src/Experiment/Stepper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 2 | {-# LANGUAGE RankNTypes, ExistentialQuantification, NoImplicitPrelude #-} 3 | module Stepper where 4 | 5 | import Lib 6 | import Data.Strict.Tuple 7 | import Data.Strict.Drive 8 | 9 | class (Functor (t m), Functor (s m), Monad m) => TransPairing t s m where 10 | interpretT :: (m a -> m b -> m c) -> t m b -> s m a -> m c 11 | 12 | data Stepper t m b = forall acc. Stepper (acc -> m b) (acc -> DriveT (t m) acc) (DriveT m acc) 13 | 14 | instance Monad m => Functor (Stepper t m) where 15 | fmap h (Stepper g f a) = Stepper (h <.> g) f a 16 | {-# INLINEABLE fmap #-} 17 | 18 | interpretDriveT :: TransPairing t s m 19 | => (DriveT m a -> DriveT m b -> m c) -> DriveT (t m) b -> DriveT (s m) a -> m c 20 | interpretDriveT f (DriveT b) (DriveT a) = interpretT (\a' b' -> f (DriveT a') (DriveT b')) b a 21 | {-# INLINEABLE interpretDriveT #-} 22 | 23 | instance TransPairing t s m => TransPairing (Stepper t) (Stepper s) m where 24 | interpretT h (Stepper g2 f2 a2) (Stepper g1 f1 a1) = go a1 a2 where 25 | go a1 a2 = driveTM (\(Pair a1' a2') -> h (g1 a1') (g2 a2')) 26 | (\(Pair a1' a2') -> interpretDriveT go (f2 a2') (f1 a1')) 27 | (Pair <$> a1 <&> a2) 28 | {-# INLINEABLE interpretT #-} 29 | 30 | newtype Fun a m b = Fun { getFun :: a -> m b } 31 | newtype Tup a m b = Tup { getTup :: m (Pair a b) } 32 | 33 | instance Functor f => Functor (Fun a f) where 34 | fmap g (Fun f) = Fun $ g <.> f 35 | {-# INLINEABLE fmap #-} 36 | 37 | instance Functor m => Functor (Tup a m) where 38 | fmap g (Tup p) = Tup $ (\(Pair x y) -> Pair x $ g y) <$> p 39 | {-# INLINEABLE fmap #-} 40 | 41 | instance Monad m => TransPairing (Fun a) (Tup a) m where 42 | interpretT g (Fun f) (Tup p) = p >>= \(Pair x y) -> g (return y) (f x) 43 | {-# INLINEABLE interpretT #-} 44 | 45 | -- DriveT (Fun a m) acc 46 | -- ~ Fun a m (Drive acc) 47 | -- ~ a -> m (Drive acc) 48 | type Fold a = Stepper (Fun a) 49 | -- DriveT (Tup a m) acc 50 | -- ~ Tup a m (Drive acc) 51 | -- ~ m (Pair a (Drive acc)) 52 | type Unfold a = Stepper (Tup a) 53 | 54 | test :: Monad m => Fold a m b -> Unfold a m c -> m b 55 | test = interpretT (*>) 56 | -------------------------------------------------------------------------------- /src/Fold/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} 2 | {-# LANGUAGE RankNTypes, ExistentialQuantification, NoImplicitPrelude #-} 3 | module Fold.Core where 4 | 5 | import Lib hiding (foldM) 6 | import Data.Strict.Tuple 7 | import Data.Strict.Drive 8 | import qualified Fold.Pure as Pure 9 | 10 | infixl 4 , />, > 11 | 12 | data Fold a m b = forall acc. Fold (acc -> m b) (acc -> a -> DriveT m acc) (DriveT m acc) 13 | 14 | saturated_consumed :: String -> a 15 | saturated_consumed name = error $ concat 16 | [ "prefolds." 17 | , name 18 | , ": a saturated fold consumed an element. " 19 | , "If you didn't define any functions that explicitly deal with `DriveT`, " 20 | , "then please report this as a bug. " 21 | , "If you did define such functions, " 22 | , "then it's likely that one of them doesn't stop on `Stop`." 23 | ] 24 | {-# NOINLINE saturated_consumed #-} 25 | -- I guess no reason to bloat code by inlining a function that throws an error? 26 | 27 | driveFold :: Monad m => (b -> a -> DriveT m b) -> DriveT m b -> Fold a m b 28 | driveFold = Fold pure 29 | {-# INLINEABLE driveFold #-} 30 | 31 | driveHalt :: Monad m => DriveT m b -> Fold a m b 32 | driveHalt = driveFold $ saturated_consumed "driveHalt" 33 | {-# INLINABLE driveHalt #-} 34 | 35 | driveMore :: Monad m => DriveT m b -> Fold a m b 36 | driveMore = driveFold $ more .* const 37 | {-# INLINABLE driveMore #-} 38 | 39 | instance Monad m => Functor (Fold a m) where 40 | -- `h <.> g` is not strictified, because I'm not sure it's needed. 41 | -- The same applies to other instances. 42 | fmap h (Fold g f a) = Fold (h <.> g) f a 43 | {-# INLINEABLE fmap #-} 44 | 45 | instance Monad m => KleisliFunctor m (Fold a m) where 46 | kmap h (Fold g f a) = Fold (g >=> h) f a 47 | {-# INLINEABLE kmap #-} 48 | 49 | combine :: Monad m 50 | => (forall t. (t -> t) -> t -> t) 51 | -> Fold a m (b -> c) -> Fold a m b -> Fold a m c 52 | combine c (Fold g1 f1 a1) (Fold g2 f2 a2) = Fold final step acc where 53 | acc = isStopT a1 >>~ \b -> Triple b <$> a1 <+> a2 54 | 55 | step (Triple b a1' a2') x 56 | | b = Triple True a1' <$> f2 a2' x 57 | | otherwise = driveDriveT (\a1'' -> Triple True a1'' <$> c (>># flip f2 x) a2) 58 | (\a1'' -> more $ Triple False a1'' a2') 59 | (f1 a1' x) 60 | 61 | final (Triple b a1' a2') = g1 a1' <*> g2 a2' 62 | {-# INLINABLE combine #-} 63 | 64 | () :: Monad m => Fold a m (b -> c) -> Fold a m b -> Fold a m c 65 | () = combine id 66 | {-# INLINEABLE () #-} 67 | 68 | (/>) :: Monad m => Fold a m b -> Fold a m c -> Fold a m c 69 | b /> c = const id <$> b c 70 | {-# INLINEABLE (/>) #-} 71 | 72 | (>) :: Monad m => Fold a m (b -> m c) -> Fold a m b -> Fold a m c 73 | (>) = kjoin .* () 74 | {-# INLINEABLE (>) #-} 75 | 76 | instance Monad m => Applicative (Fold a m) where 77 | pure = driveHalt . spure 78 | {-# INLINABLE pure #-} 79 | 80 | (<*>) = combine (const id) 81 | {-# INLINABLE (<*>) #-} 82 | 83 | instance Monad m => SumApplicative (Fold a m) where 84 | spure = driveHalt . spure 85 | {-# INLINABLE spure #-} 86 | 87 | Fold g1 f1 a1 <+> Fold g2 f2 a2 = Fold final step (pairW a1 a2) where 88 | pairW a1' a2' = Pair <$> duplicate a1' <+> duplicate a2' 89 | 90 | step (Pair a1' a2') x = pairW (a1' >># flip f1 x) (a2' >># flip f2 x) 91 | 92 | final (Pair a1' a2') = (a1' >>~ g1) <*> (a2' >>~ g2) 93 | {-# INLINABLE (<+>) #-} 94 | 95 | instance Monad m => AndApplicative (Fold a m) where 96 | apure = driveMore . apure 97 | {-# INLINABLE apure #-} 98 | 99 | Fold g1 f1 a1 <&> Fold g2 f2 a2 = Fold final step (Pair <$> a1 <&> a2) where 100 | step (Pair a1' a2') x = Pair <$> f1 a1' x <&> f2 a2' x 101 | 102 | final (Pair a1' a2') = g1 a1' <*> g2 a2' 103 | {-# INLINABLE (<&>) #-} 104 | 105 | -- There isn't much point in making `acc` strict I guess, but it costs nothing, so why not. 106 | data FoldMore a m b = forall acc. FoldMore (acc -> m b) (acc -> a -> DriveT m acc) !acc 107 | 108 | runFoldMore :: FoldMore a m b -> m b 109 | runFoldMore (FoldMore g f a) = g a 110 | {-# INLINEABLE runFoldMore #-} 111 | 112 | toFoldMore :: Functor m => Fold a m b -> DriveT m (FoldMore a m b) 113 | toFoldMore (Fold g f (DriveT a)) = DriveT $ fmap (FoldMore g f) <$> a 114 | {-# INLINEABLE toFoldMore #-} 115 | 116 | feedFoldMore :: Functor m => a -> FoldMore a m b -> DriveT m (FoldMore a m b) 117 | feedFoldMore x (FoldMore g f a) = FoldMore g f <$> f a x 118 | {-# INLINEABLE feedFoldMore #-} 119 | 120 | instance Monad m => Monad (Fold a m) where 121 | Fold g1 f1 a1 >>= h = Fold final step (left a1) where 122 | left = driveDriveT (g1 >~> Right <.> toFoldMore . h) (more . Left) 123 | 124 | step (Left a1') x = left $ f1 a1' x 125 | step (Right f2) x = Right <$> feedFoldMore x f2 126 | 127 | final (Left a1') = g1 a1' >>= runFold . h 128 | final (Right f2) = runFoldMore f2 129 | {-# INLINABLE (>>=) #-} 130 | 131 | instance SumApplicativeTrans (Fold a) where 132 | slift = driveMore . slift 133 | {-# INLINABLE slift #-} 134 | 135 | instance AndApplicativeTrans (Fold a) where 136 | alift = driveHalt . alift 137 | {-# INLINABLE alift #-} 138 | 139 | instance MFunctor (Fold a) where 140 | hoist h (Fold g f a) = Fold (h . g) (hoist h .* f) (hoist h a) 141 | {-# INLINEABLE hoist #-} 142 | 143 | -- TODO: is this strict? 144 | runFoldReaderT :: Monad m => r -> Fold a (ReaderT r m) b -> Fold a m b 145 | runFoldReaderT r (Fold g f a) = Fold final step (runDriveReaderT r a) where 146 | step a' x = runDriveReaderT r (f a' x) 147 | 148 | final a' = runReaderT (g a') r 149 | {-# INLINEABLE runFoldReaderT #-} 150 | 151 | instance TransTraversable (Fold a) (ReaderT r) where 152 | sequenceT = ReaderT . flip runFoldReaderT 153 | {-# INLINEABLE sequenceT #-} 154 | 155 | runFoldStateT' :: Monad m => s -> Fold a (StateT s m) b -> Fold a m (b, s) 156 | runFoldStateT' s (Fold g f a) = Fold final step (run s a) where 157 | run = toPair <.*> runDriveStateT 158 | 159 | step (Pair a' s') x = run s' (f a' x) 160 | 161 | final (Pair a' s') = runStateT (g a') s' 162 | {-# INLINEABLE runFoldStateT' #-} 163 | 164 | instance TransTraversable (Fold a) (StateT s) where 165 | sequenceT = StateT . flip runFoldStateT' 166 | {-# INLINEABLE sequenceT #-} 167 | 168 | -- TODO: this is not strict, perhaps. 169 | runFoldExceptT :: Monad m => Fold a (ExceptT e m) b -> Fold a m (Either e b) 170 | runFoldExceptT (Fold g f a) = Fold final step (runDriveExceptT a) where 171 | step (Left e) x = saturated_consumed "addExceptT" 172 | step (Right a') x = runDriveExceptT (f a' x) 173 | 174 | final = join <.> runExceptT . traverse g 175 | {-# INLINEABLE runFoldExceptT #-} 176 | 177 | instance TransTraversable (Fold a) (ExceptT e) where 178 | sequenceT = ExceptT . runFoldExceptT 179 | {-# INLINEABLE sequenceT #-} 180 | 181 | runFold :: Monad m => Fold a m b -> m b 182 | runFold (Fold g f a) = a >>~ g 183 | {-# INLINEABLE runFold #-} 184 | 185 | feedFold :: Monad m => a -> Fold a m b -> DriveT m (Fold a m b) 186 | feedFold x (Fold g f a) = a >># flip f x =>> Fold g f 187 | {-# INLINEABLE feedFold #-} 188 | 189 | map :: (b -> a) -> Fold a m c -> Fold b m c 190 | map h (Fold g f a) = Fold g (\a' -> f a' . h) a 191 | {-# INLINEABLE map #-} 192 | 193 | filter :: Monad m => (a -> Bool) -> Fold a m b -> Fold a m b 194 | filter p (Fold g f a) = Fold g (\a' x -> if p x then f a' x else more a') a 195 | {-# INLINABLE filter #-} 196 | 197 | -- The usual flaw: loses the first element for which the predicate doesn't hold. 198 | takeWhile :: Monad m => (a -> Bool) -> Fold a m b -> Fold a m b 199 | takeWhile p (Fold g f a) = Fold g (\a' x -> if p x then f a' x else halt a') a 200 | {-# INLINABLE takeWhile #-} 201 | 202 | dropWhile :: Monad m => (a -> Bool) -> Fold a m b -> Fold a m b 203 | dropWhile p (Fold g f a) = Fold (g . sndp) step (Pair False <$> a) where 204 | step (Pair b a') x | b || not (p x) = Pair True <$> f a' x 205 | | otherwise = more $ Pair False a' 206 | {-# INLINABLE dropWhile #-} 207 | 208 | spanM :: Monad m => (b -> c -> m d) -> (a -> Bool) -> Fold a m b -> Fold a m c -> Fold a m d 209 | spanM h p b c = h <$> takeWhile p b > c 210 | {-# INLINEABLE spanM #-} 211 | 212 | span :: Monad m => (b -> c -> d) -> (a -> Bool) -> Fold a m b -> Fold a m c -> Fold a m d 213 | span f = spanM (pure .* f) 214 | {-# INLINEABLE span #-} 215 | 216 | span_ :: Monad m => (a -> Bool) -> Fold a m b -> Fold a m c -> Fold a m c 217 | span_ = span (const id) 218 | {-# INLINEABLE span_ #-} 219 | 220 | take :: Monad m => Int -> Fold a m b -> Fold a m b 221 | take n (Fold g f a) = Fold (g . sndp) step (finish n a) where 222 | finish n' a' = terminateWhen ((<= 0) . fstp) $ Pair n' <$> a' 223 | 224 | step (Pair n' a') x | n <= 0 = saturated_consumed "take" 225 | | otherwise = finish (n' - 1) $ f a' x 226 | {-# INLINABLE take #-} 227 | 228 | drop :: Monad m => Int -> Fold a m b -> Fold a m b 229 | drop n (Fold g f a) = Fold (g . sndp) step (Pair n <$> a) where 230 | step (Pair n' a') x | n' <= 0 = Pair n' <$> f a' x 231 | | otherwise = more $ Pair (n' - 1) a' 232 | {-# INLINABLE drop #-} 233 | 234 | cross :: Monad m => m a -> DriveT m b -> (b -> a -> DriveT m b) -> DriveT m b 235 | cross a b f = a >>~ \x -> b >># flip f x 236 | {-# INLINABLE cross #-} 237 | 238 | scan :: Monad m => Fold a m b -> Fold b m c -> Fold a m c 239 | scan (Fold g1 f1 a1) (Fold g2 f2 a2) = Fold final step (pair a1 a2) where 240 | pair a1' a2' = Pair <$> a1' <&> duplicate a2' 241 | 242 | step (Pair a1' a2') x = pair (f1 a1' x) $ cross (g1 a1') a2' f2 243 | 244 | final (Pair a1' a2') = cross (g1 a1') a2' f2 >>~ g2 245 | {-# INLINEABLE scan #-} 246 | 247 | -- Unlike the prelude version, `p` must be only transitive and is not required to be symmetric. 248 | groupBy :: Monad m => (a -> a -> Bool) -> Fold a m b -> Fold b m c -> Fold a m c 249 | groupBy p (Fold g1 f1 a1) (Fold g2 f2 a2) = Fold final step acc where 250 | acc = a2 =>> Quadruple False (const True) a1 251 | 252 | step (Quadruple _ p' a1' a2') x 253 | | p' x = more $ pair a1' a2' 254 | | otherwise = cross (a1' >>~ g1) a2' f2 =>> pair a1 255 | where pair a = Quadruple True (p x) (a >># flip f1 x) 256 | 257 | final (Quadruple b _ a1' a2') = (if b then cross (a1' >>~ g1) a2' f2 else a2') >>~ g2 258 | {-# INLINABLE groupBy #-} 259 | 260 | -- Same as `groupBy`, but is slightly more efficient. 261 | -- The only difference is that this version emulates `Prelude.groupBy p [] = [[]]`. 262 | groupBy1 :: Monad m => (a -> a -> Bool) -> Fold a m b -> Fold b m c -> Fold a m c 263 | groupBy1 p (Fold g1 f1 a1) (Fold g2 f2 a2) = Fold final step acc where 264 | acc = a2 =>> Triple (const True) a1 265 | 266 | step (Triple p' a1' a2') x 267 | | p' x = more $ pair a1' a2' 268 | | otherwise = cross (a1' >>~ g1) a2' f2 =>> pair a1 269 | where pair a = Triple (p x) (a >># flip f1 x) 270 | 271 | final (Triple _ a1' a2') = cross (a1' >>~ g1) a2' f2 >>~ g2 272 | {-# INLINABLE groupBy1 #-} 273 | 274 | group :: (Monad m, Eq a) => Fold a m b -> Fold b m c -> Fold a m c 275 | group = groupBy (==) 276 | {-# INLINEABLE group #-} 277 | 278 | inits :: Monad m => Fold a m b -> Fold b m c -> Fold a m c 279 | inits (Fold g1 f1 a1) (Fold g2 f2 a2) = Fold final step (a2 =>> Pair a1) where 280 | step (Pair a1' a2') x = cross (a1' >>~ g1) a2' f2 =>> Pair (a1' >># flip f1 x) 281 | 282 | final (Pair a1' a2') = cross (a1' >>~ g1) a2' f2 >>~ g2 283 | {-# INLINABLE inits #-} 284 | 285 | chunks :: Monad m => Fold a m b -> Fold b m c -> Fold a m c 286 | chunks (Fold g1 f1 a1) (Fold g2 f2 a2) = Fold final step (pack a2) where 287 | pack a2' = Triple False <$> a1 <&> duplicate a2' 288 | 289 | step (Triple _ a1' a2') x = driveDriveT (\a1'' -> pack $ cross (g1 a1'') a2' f2) 290 | (\a1'' -> more $ Triple True a1'' a2') 291 | (f1 a1' x) 292 | 293 | final (Triple b a1' a2') = (if b then cross (g1 a1') a2' f2 else a2') >>~ g2 294 | {-# INLINABLE chunks #-} 295 | 296 | chunksOf :: Monad m => Int -> Fold a m b -> Fold b m c -> Fold a m c 297 | chunksOf = chunks .* take 298 | {-# INLINABLE chunksOf #-} 299 | 300 | splitWhen :: Monad m => (a -> Bool) -> Fold a m b -> Fold b m c -> Fold a m c 301 | splitWhen = chunks .* takeWhile 302 | {-# INLINABLE splitWhen #-} 303 | 304 | -- exec (splitOne ',' list list) "abc,def," === ["abc", "def"] 305 | splitOne :: (Monad m, Eq a) => a -> Fold a m b -> Fold b m c -> Fold a m c 306 | splitOne = splitWhen . (/=) 307 | {-# INLINABLE splitOne #-} 308 | 309 | execM :: (Monad m, Foldable t) => Fold a m b -> t a -> m b 310 | execM (Fold g f a) xs = a >># flip (mfoldM f) xs >>~ g 311 | {-# INLINABLE execM #-} 312 | 313 | exec :: Foldable t => Fold a Identity b -> t a -> b 314 | exec = runIdentity .* execM 315 | {-# INLINABLE exec #-} 316 | 317 | impurely :: Monad m 318 | => (forall acc. (DriveT m acc -> (acc -> m b) -> m b) -> 319 | (acc -> m b) -> (acc -> a -> DriveT m acc) -> DriveT m acc -> c) 320 | -> Fold a m b -> c 321 | impurely h (Fold g f a) = h (flip $ driveTM g) g f a 322 | {-# INLINABLE impurely #-} 323 | 324 | impurelyRest :: Monad m 325 | => (forall acc. (forall t. (acc -> m t) -> (acc -> m t) -> DriveT m acc -> m t) -> 326 | (acc -> m b) -> (acc -> a -> DriveT m acc) -> DriveT m acc -> c) 327 | -> Fold a m b -> c 328 | impurelyRest h (Fold g f a) = h driveTM g f a 329 | {-# INLINABLE impurelyRest #-} 330 | 331 | newtype Pattern m a z = Pattern { getPattern :: a -> DriveT m a } 332 | 333 | instance Functor (Pattern m acc) where 334 | fmap _ (Pattern f) = Pattern f 335 | {-# INLINE fmap #-} 336 | 337 | instance Monad m => Applicative (Pattern m acc) where 338 | pure _ = Pattern more 339 | {-# INLINE pure #-} 340 | 341 | Pattern f <*> Pattern g = Pattern (f >#> g) 342 | {-# INLINE (<*>) #-} 343 | 344 | type Handler b m a = forall acc. (a -> Pattern m acc a) -> b -> Pattern m acc b 345 | 346 | handle :: Handler b m a -> Fold a m c -> Fold b m c 347 | handle k (Fold g f a) = Fold g (flip $ getPattern . k (Pattern . flip f)) a 348 | {-# INLINEABLE handle #-} 349 | 350 | foldM :: Monad m => (b -> a -> m b) -> b -> Fold a m b 351 | foldM f = driveFold (keep .* f) . more 352 | {-# INLINABLE foldM #-} 353 | 354 | foldMapM :: (Monad m, Monoid b) => (a -> m b) -> Fold a m b 355 | foldMapM f = foldM (\a x -> mappend a <$> f x) mempty 356 | {-# INLINABLE foldMapM #-} 357 | 358 | traverse_ :: Monad m => (a -> m ()) -> Fold a m () 359 | traverse_ f = foldM (const f) () 360 | {-# INLINABLE traverse_ #-} 361 | 362 | fromPureFold :: Monad m => Pure.Fold a b -> Fold a m b 363 | fromPureFold (Pure.Fold g f a) = Fold (pure . g) (driveToDriveT .* f) (more a) 364 | {-# INLINABLE fromPureFold #-} 365 | 366 | fold :: Monad m => (b -> a -> b) -> b -> Fold a m b 367 | fold = fromPureFold .* Pure.fold 368 | {-# INLINABLE fold #-} 369 | 370 | list :: Monad m => Fold a m [a] 371 | list = fromPureFold Pure.list 372 | {-# INLINABLE list #-} 373 | 374 | revList :: Monad m => Fold a m [a] 375 | revList = fromPureFold Pure.revList 376 | {-# INLINABLE revList #-} 377 | 378 | foldMap :: (Monad m, Monoid b) => (a -> b) -> Fold a m b 379 | foldMap = fromPureFold . Pure.foldMap 380 | {-# INLINABLE foldMap #-} 381 | 382 | mconcat :: (Monad m, Monoid a) => Fold a m a 383 | mconcat = fromPureFold Pure.mconcat 384 | {-# INLINABLE mconcat #-} 385 | 386 | null :: Monad m => Fold a m Bool 387 | null = fromPureFold Pure.null 388 | {-# INLINABLE null #-} 389 | 390 | length :: Monad m => Fold a m Int 391 | length = fromPureFold Pure.length 392 | {-# INLINABLE length #-} 393 | 394 | all :: Monad m => (a -> Bool) -> Fold a m Bool 395 | all = fromPureFold . Pure.all 396 | {-# INLINEABLE all #-} 397 | 398 | any :: Monad m => (a -> Bool) -> Fold a m Bool 399 | any = fromPureFold . Pure.any 400 | {-# INLINEABLE any #-} 401 | 402 | and :: Monad m => Fold Bool m Bool 403 | and = fromPureFold Pure.and 404 | {-# INLINEABLE and #-} 405 | 406 | or :: Monad m => Fold Bool m Bool 407 | or = fromPureFold Pure.or 408 | {-# INLINEABLE or #-} 409 | 410 | sum :: (Monad m, Num a) => Fold a m a 411 | sum = fromPureFold Pure.sum 412 | {-# INLINABLE sum #-} 413 | 414 | product :: (Monad m, Num a) => Fold a m a 415 | product = fromPureFold Pure.product 416 | {-# INLINABLE product #-} 417 | 418 | elem :: (Monad m, Eq a) => a -> Fold a m Bool 419 | elem = fromPureFold . Pure.elem 420 | {-# INLINABLE elem #-} 421 | 422 | notElem :: (Monad m, Eq a) => a -> Fold a m Bool 423 | notElem = fromPureFold . Pure.notElem 424 | {-# INLINABLE notElem #-} 425 | 426 | genericLength :: (Monad m, Num b) => Fold a m b 427 | genericLength = fromPureFold Pure.genericLength 428 | {-# INLINABLE genericLength #-} 429 | 430 | head :: Monad m => Fold a m (Maybe a) 431 | head = fromPureFold Pure.head 432 | {-# INLINABLE head #-} 433 | 434 | last :: Monad m => Fold a m (Maybe a) 435 | last = fromPureFold Pure.last 436 | {-# INLINABLE last #-} 437 | 438 | find :: Monad m => (a -> Bool) -> Fold a m (Maybe a) 439 | find = fromPureFold . Pure.find 440 | {-# INLINABLE find #-} 441 | 442 | minimum :: (Monad m, Ord a) => Fold a m (Maybe a) 443 | minimum = fromPureFold Pure.minimum 444 | {-# INLINABLE minimum #-} 445 | 446 | maximum :: (Monad m, Ord a) => Fold a m (Maybe a) 447 | maximum = fromPureFold Pure.maximum 448 | {-# INLINABLE maximum #-} 449 | 450 | minimumBy :: Monad m => (a -> a -> Ordering) -> Fold a m (Maybe a) 451 | minimumBy = fromPureFold . Pure.minimumBy 452 | {-# INLINABLE minimumBy #-} 453 | 454 | maximumBy :: Monad m => (a -> a -> Ordering) -> Fold a m (Maybe a) 455 | maximumBy = fromPureFold . Pure.maximumBy 456 | {-# INLINABLE maximumBy #-} 457 | -------------------------------------------------------------------------------- /src/Fold/Pure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-} 2 | module Fold.Pure where 3 | 4 | import Lib 5 | import Data.Strict.Maybe 6 | import Data.Strict.Drive 7 | 8 | data Fold a b = forall acc. Fold (acc -> b) (acc -> a -> Drive acc) acc 9 | 10 | foldDrive :: (b -> a -> Drive b) -> b -> Fold a b 11 | foldDrive = Fold id 12 | {-# INLINEABLE foldDrive #-} 13 | 14 | fold1Drive :: (a -> a -> Drive a) -> Fold a (Maybe a) 15 | fold1Drive f = Fold lazy (\ma x -> Just' <$> maybe' (more x) (flip f x) ma) Nothing' 16 | {-# INLINEABLE fold1Drive #-} 17 | 18 | fold :: (b -> a -> b) -> b -> Fold a b 19 | fold f = foldDrive (more .* f) 20 | {-# INLINABLE fold #-} 21 | 22 | fold1 :: (a -> a -> a) -> Fold a (Maybe a) 23 | fold1 f = fold1Drive (more .* f) 24 | {-# INLINABLE fold1 #-} 25 | 26 | list :: Fold a [a] 27 | list = Fold ($ []) (\r x -> more $ r . (x:)) id 28 | {-# INLINABLE list #-} 29 | 30 | revList :: Fold a [a] 31 | revList = fold (flip (:)) [] 32 | {-# INLINABLE revList #-} 33 | 34 | foldMap :: Monoid b => (a -> b) -> Fold a b 35 | foldMap f = fold (\a x -> a `mappend` f x) mempty 36 | {-# INLINABLE foldMap #-} 37 | 38 | mconcat :: Monoid a => Fold a a 39 | mconcat = foldMap id 40 | {-# INLINABLE mconcat #-} 41 | 42 | null :: Fold a Bool 43 | null = foldDrive (\_ _ -> halt False) True 44 | {-# INLINABLE null #-} 45 | 46 | length :: Fold a Int 47 | length = genericLength 48 | {-# INLINABLE length #-} 49 | 50 | all :: (a -> Bool) -> Fold a Bool 51 | all p = foldDrive (\a x -> moreWhen id $ a && p x) True 52 | {-# INLINEABLE all #-} 53 | 54 | any :: (a -> Bool) -> Fold a Bool 55 | any p = foldDrive (\a x -> haltWhen id $ a || p x) False 56 | {-# INLINEABLE any #-} 57 | 58 | and :: Fold Bool Bool 59 | and = all id 60 | {-# INLINEABLE and #-} 61 | 62 | or :: Fold Bool Bool 63 | or = any id 64 | {-# INLINEABLE or #-} 65 | 66 | sum :: Num a => Fold a a 67 | sum = fold (+) 0 68 | {-# INLINABLE sum #-} 69 | 70 | product :: Num a => Fold a a 71 | product = fold (*) 1 72 | {-# INLINABLE product #-} 73 | 74 | elem :: Eq a => a -> Fold a Bool 75 | elem a = any (a ==) 76 | {-# INLINABLE elem #-} 77 | 78 | notElem :: Eq a => a -> Fold a Bool 79 | notElem a = all (a /=) 80 | {-# INLINABLE notElem #-} 81 | 82 | genericLength :: Num b => Fold a b 83 | genericLength = fold (\a _ -> 1 + a) 0 84 | {-# INLINABLE genericLength #-} 85 | 86 | find :: (a -> Bool) -> Fold a (Maybe a) 87 | find p = foldDrive f Nothing where 88 | f _ x = if p x then halt (Just x) else more Nothing 89 | {-# INLINABLE find #-} 90 | 91 | head :: Fold a (Maybe a) 92 | head = foldDrive (\_ -> halt . Just) Nothing 93 | {-# INLINABLE head #-} 94 | 95 | last :: Fold a (Maybe a) 96 | last = fold1 (const id) 97 | {-# INLINABLE last #-} 98 | 99 | minimum :: Ord a => Fold a (Maybe a) 100 | minimum = fold1 min 101 | {-# INLINABLE minimum #-} 102 | 103 | maximum :: Ord a => Fold a (Maybe a) 104 | maximum = fold1 max 105 | {-# INLINABLE maximum #-} 106 | 107 | minimumBy :: (a -> a -> Ordering) -> Fold a (Maybe a) 108 | minimumBy c = fold1 f where 109 | f x y = case c x y of 110 | GT -> y 111 | _ -> x 112 | {-# INLINABLE minimumBy #-} 113 | 114 | maximumBy :: (a -> a -> Ordering) -> Fold a (Maybe a) 115 | maximumBy c = fold1 f where 116 | f x y = case c x y of 117 | GT -> x 118 | _ -> y 119 | {-# INLINABLE maximumBy #-} 120 | -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DefaultSignatures, BangPatterns #-} 2 | module Lib 3 | ( module Lib 4 | , module Prelude 5 | , module Data.Functor.Identity 6 | , module Data.Bifunctor 7 | , module Data.Traversable 8 | , module Control.Applicative 9 | , module Control.Monad 10 | , module Control.Comonad 11 | , module Control.Monad.Morph 12 | , module Control.Monad.Trans.Reader 13 | , module Control.Monad.Trans.State.Strict 14 | , module Control.Monad.Trans.Except 15 | ) where 16 | 17 | import Prelude hiding (map, filter, takeWhile, dropWhile, span, take, drop, 18 | foldMap, mconcat, null, length, all, any, and, or, sum, product, 19 | elem, notElem, head, last, minimum, maximum, 20 | iterate, repeat, enumFrom, enumFromTo, enumFromThenTo) 21 | import Data.Functor.Identity 22 | import Data.Bifunctor 23 | import Data.Traversable (foldMapDefault) 24 | import Control.Applicative ((<**>)) 25 | import Control.Monad (join, (>=>), ap) 26 | import Control.Comonad 27 | import Control.Monad.Morph (MFunctor, hoist) 28 | import Control.Monad.Trans.Reader (ReaderT(..), ask, local) 29 | import Control.Monad.Trans.State.Strict (StateT(..), get, put, modify') 30 | import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE, catchE) 31 | 32 | infixr 9 .*, <.>, <.*> 33 | infixl 4 <+>, +>, <+, <&>, &>, <&, <$>>, <*>>, <+>>, <&>> 34 | infixl 1 >>#, >#> 35 | 36 | (.*) :: (c -> d) -> (a -> b -> c) -> a -> b -> d 37 | g .* f = \x y -> g (f x y) 38 | {-# INLINE (.*) #-} 39 | 40 | (<.>) :: Functor f => (b -> c) -> (a -> f b) -> a -> f c 41 | g <.> f = \x -> g <$> f x 42 | {-# INLINE (<.>) #-} 43 | 44 | (<.) :: Functor f => c -> (a -> f b) -> a -> f c 45 | y <. f = \x -> y <$ f x 46 | {-# INLINE (<.) #-} 47 | 48 | (<.*>) :: Functor f => (c -> d) -> (a -> b -> f c) -> a -> b -> f d 49 | g <.*> f = fmap g .* f 50 | {-# INLINE (<.*>) #-} 51 | 52 | tupl :: Functor f => a -> f b -> f (a, b) 53 | tupl = fmap . (,) 54 | {-# INLINE tupl #-} 55 | 56 | tupr :: Functor f => f a -> b -> f (a, b) 57 | tupr = flip $ fmap . flip (,) 58 | {-# INLINE tupr #-} 59 | 60 | runEither :: Either a a -> a 61 | runEither = either id id 62 | {-# INLINE runEither #-} 63 | 64 | foldM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b 65 | foldM f a xs = foldr (\x r (!a') -> f a' x >>= r) return xs a 66 | {-# INLINE foldM #-} 67 | 68 | mfoldM :: (Foldable t, MonoMonad m) => (b -> a -> m b) -> b -> t a -> m b 69 | mfoldM f a xs = foldr (\x r (!a') -> f a' x >># r) mpure xs a 70 | {-# INLINE mfoldM #-} 71 | 72 | -- The usual Applicative laws. 73 | class Functor f => SumApplicative f where 74 | spure :: a -> f a 75 | (<+>) :: f (a -> b) -> f a -> f b 76 | 77 | (+>) :: f a -> f b -> f b 78 | a +> b = id <$ a <+> b 79 | {-# INLINE (+>) #-} 80 | 81 | (<+) :: f a -> f b -> f a 82 | a <+ b = const <$> a <+> b 83 | {-# INLINE (<+) #-} 84 | 85 | -- The usual Applicative laws. 86 | class Functor f => AndApplicative f where 87 | apure :: a -> f a 88 | (<&>) :: f (a -> b) -> f a -> f b 89 | 90 | (&>) :: f a -> f b -> f b 91 | a &> b = id <$ a <&> b 92 | {-# INLINE (&>) #-} 93 | 94 | (<&) :: f a -> f b -> f a 95 | a <& b = const <$> a <&> b 96 | {-# INLINE (<&) #-} 97 | 98 | -- The usual Monad laws. 99 | class Functor m => MonoMonad m where 100 | mpure :: a -> m a 101 | (>>#) :: m a -> (a -> m a) -> m a 102 | 103 | (>#>) :: (a -> m a) -> (a -> m a) -> a -> m a 104 | f >#> g = \x -> f x >># g 105 | {-# INLINE (>#>) #-} 106 | 107 | -- Transforms a Monad into a SumApplicative. 108 | class SumApplicativeTrans t where 109 | slift :: Monad m => m a -> t m a 110 | 111 | -- Transforms a Monad into an AndApplicative. 112 | class AndApplicativeTrans t where 113 | alift :: Monad m => m a -> t m a 114 | 115 | -- A variant of http://elvishjerricco.github.io/2016/10/12/kleisli-functors.html 116 | -- kmap return === id 117 | -- kmap g . kmap f === kmap (f >=> g) 118 | class (Monad m, Functor f) => KleisliFunctor m f where 119 | kmap :: (a -> m b) -> f a -> f b 120 | kmap = kjoin .* fmap 121 | {-# INLINE kmap #-} 122 | 123 | kjoin :: f (m a) -> f a 124 | kjoin = kmap id 125 | {-# INLINE kjoin #-} 126 | 127 | (<$>>) :: KleisliFunctor m f => (a -> m b) -> f a -> f b 128 | (<$>>) = kmap 129 | {-# INLINE (<$>>) #-} 130 | 131 | (<*>>) :: (KleisliFunctor m f, Applicative f) => f (a -> m b) -> f a -> f b 132 | h <*>> a = kjoin $ h <*> a 133 | {-# INLINE (<*>>) #-} 134 | 135 | (<+>>) :: (KleisliFunctor m f, SumApplicative f) => f (a -> m b) -> f a -> f b 136 | h <+>> a = kjoin $ h <+> a 137 | {-# INLINE (<+>>) #-} 138 | 139 | (<&>>) :: (KleisliFunctor m f, AndApplicative f) => f (a -> m b) -> f a -> f b 140 | h <&>> a = kjoin $ h <&> a 141 | {-# INLINE (<&>>) #-} 142 | 143 | instance Monad m => KleisliFunctor m m where 144 | kmap = (=<<) 145 | {-# INLINE kmap #-} 146 | 147 | class TransTraversable t s where 148 | sequenceT :: Monad m => t (s m) a -> s (t m) a 149 | -------------------------------------------------------------------------------- /src/Prefolds.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Prefolds 3 | ( module Lib 4 | , module Data.Strict.Drive 5 | , module Fold.Core 6 | , module Unfold.Core 7 | , module Prefolds 8 | ) where 9 | 10 | import Lib hiding (foldM) 11 | import Data.Strict.Tuple 12 | import Data.Strict.Maybe 13 | import Data.Strict.Drive 14 | import Fold.Core 15 | import Unfold.Core 16 | 17 | pairingM :: Monad m => Fold a m (b -> c) -> Unfold a m b -> m c 18 | pairingM (Fold g2 f2 a2) (Unfold g1 f1 a1) = go a1 a2 where 19 | go a1 a2 = driveTM (\(a1', a2') -> g1 a1' <**> g2 a2') 20 | (\(a1', a2') -> do 21 | Pair mx a1'' <- f1 a1' 22 | go (return a1'') $ maybe' a2 (f2 a2') mx) 23 | ((,) <$> DriveT a1 <&> a2) 24 | {-# INLINEABLE pairingM #-} 25 | 26 | pairingM_ :: Monad m => Fold a m c -> Unfold a m b -> m c 27 | pairingM_ = pairingM . fmap const 28 | {-# INLINEABLE pairingM_ #-} 29 | 30 | pairing :: Fold a Identity (b -> c) -> Unfold a Identity b -> c 31 | pairing = runIdentity .* pairingM 32 | {-# INLINEABLE pairing #-} 33 | 34 | pairing_ :: Fold a Identity c -> Unfold a Identity b -> c 35 | pairing_ = runIdentity .* pairingM_ 36 | {-# INLINEABLE pairing_ #-} 37 | -------------------------------------------------------------------------------- /src/Unfold/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} 2 | {-# LANGUAGE RankNTypes, ExistentialQuantification, NoImplicitPrelude #-} 3 | module Unfold.Core where 4 | 5 | import Lib hiding (foldM) 6 | import Data.Strict.Tuple 7 | import Data.Strict.Maybe 8 | import Data.Strict.Drive 9 | import qualified Unfold.Pure as Pure 10 | 11 | data Unfold a m b = forall acc. 12 | Unfold (acc -> m b) (acc -> m (Pair (Maybe' a) (Drive acc))) (m (Drive acc)) 13 | 14 | fromPureUnfold :: Monad m => Pure.Unfold a -> Unfold a m () 15 | fromPureUnfold (Pure.Unfold f a) = Unfold (\_ -> return ()) (return . first Just' . f) (return a) 16 | {-# INLINEABLE fromPureUnfold #-} 17 | 18 | toUnfold :: Monad m => [a] -> Unfold a m () 19 | toUnfold = fromPureUnfold . Pure.toUnfold 20 | {-# INLINEABLE toUnfold #-} 21 | 22 | iterate :: Monad m => (a -> a) -> a -> Unfold a m () 23 | iterate = fromPureUnfold .* Pure.iterate 24 | {-# INLINEABLE iterate #-} 25 | 26 | repeat :: Monad m => a -> Unfold a m () 27 | repeat = fromPureUnfold . Pure.repeat 28 | {-# INLINEABLE repeat #-} 29 | 30 | enumFrom :: (Monad m, Enum a) => a -> Unfold a m () 31 | enumFrom = fromPureUnfold . Pure.enumFrom 32 | {-# INLINEABLE enumFrom #-} 33 | -------------------------------------------------------------------------------- /src/Unfold/Pure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} 2 | {-# LANGUAGE RankNTypes, ExistentialQuantification, NoImplicitPrelude #-} 3 | module Unfold.Pure where 4 | 5 | import Lib hiding (foldM) 6 | import Data.Strict.Tuple 7 | import Data.Strict.Maybe 8 | import Data.Strict.Drive 9 | import qualified Prelude as P 10 | 11 | data Unfold a = forall acc. Unfold (acc -> Pair a (Drive acc)) (Drive acc) 12 | 13 | toUnfold :: [a] -> Unfold a 14 | toUnfold xs = Unfold (\(x:xs) -> Pair x (finish xs)) (finish xs) where 15 | finish = haltWhen P.null 16 | {-# INLINEABLE toUnfold #-} 17 | 18 | iterate :: (a -> a) -> a -> Unfold a 19 | iterate f x = Unfold (ap Pair More . f) (More x) 20 | {-# INLINEABLE iterate #-} 21 | 22 | repeat :: a -> Unfold a 23 | repeat = iterate id 24 | {-# INLINEABLE repeat #-} 25 | 26 | enumFrom :: Enum a => a -> Unfold a 27 | enumFrom = iterate succ 28 | {-# INLINEABLE enumFrom #-} 29 | 30 | {-enumFromTo :: Enum a => a -> a -> Unfold a 31 | enumFromTo n m = Unfold (ap Pair More . f) (More n) where 32 | finish = haltWhen 33 | {-# INLINEABLE enumFrom #-}-} 34 | 35 | {-enumFrom :: Enum a => a -> Unfold a 36 | enumFrom = iterate succ 37 | {-# INLINEABLE enumFrom #-}-} 38 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-7.7 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: 43 | - criterion-1.1.4.0 44 | - code-page-0.1.1 45 | - optparse-applicative-0.13.0.0 46 | 47 | # Override default flag values for local packages and extra-deps 48 | flags: {} 49 | 50 | # Extra package databases containing global packages 51 | extra-package-dbs: [] 52 | 53 | # Control whether we use the GHC we find on the path 54 | # system-ghc: true 55 | # 56 | # Require a specific version of stack, using version ranges 57 | # require-stack-version: -any # Default 58 | # require-stack-version: ">=1.2" 59 | # 60 | # Override the architecture used by stack, especially useful on Windows 61 | # arch: i386 62 | # arch: x86_64 63 | # 64 | # Extra directories used by stack for building 65 | # extra-include-dirs: [/path/to/dir] 66 | # extra-lib-dirs: [/path/to/dir] 67 | # 68 | # Allow a newer minor version of GHC than the snapshot specifies 69 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification, RankNTypes #-} 2 | {-# LANGUAGE BangPatterns, TypeOperators, NoImplicitPrelude #-} 3 | module Main where 4 | 5 | import Prefolds 6 | import qualified Prelude as P 7 | import qualified Data.List as P 8 | import Control.Monad.Trans.Writer 9 | 10 | -- I didn't find a lib that allows to not name every single test, 11 | -- so here is a tiny implementation. 12 | data Test = forall a. (Show a, Eq a) => a :== a 13 | | Label String [Test] 14 | 15 | type Suite = Writer [Test] () 16 | 17 | runSuite :: Suite -> String 18 | runSuite = fin . gos . execWriter where 19 | fin [] = "OK" 20 | fin ss = P.intercalate "\n" ss 21 | 22 | gos = concatMap go . zip [1 :: Int ..] 23 | 24 | go (i, x :== y) = [concat [show i, ": ", show x, " is not ", show y] | x /= y] 25 | go (i, Label s ts) = P.map (\t -> s ++ "/" ++ t) $ gos ts 26 | 27 | label :: String -> Suite -> Suite 28 | label s t = tell [Label s $ execWriter t] 29 | 30 | (===) :: (Show a, Eq a) => a -> a -> Suite 31 | x === y = tell [x :== y] 32 | 33 | 34 | 35 | perf :: (Fold a Identity [a] -> Fold a Identity b) -> [a] -> b 36 | perf f = exec (f list) 37 | 38 | -- It's really easy to make an off-by-one error with functions like `scan` and `groupBy`, 39 | -- hence the tests mostly cover such cases. 40 | suite :: Suite 41 | suite = do 42 | label "map" $ do 43 | perf (map (^2)) [] === ([] :: [Int]) 44 | perf (map (^2)) [1..3] === [1,4,9] 45 | label "take" $ do 46 | perf (take 0) [] === ([] :: [Int]) 47 | perf (take 1) [] === ([] :: [Int]) 48 | perf (take 0) [1..] === [] 49 | perf (take 3) [1,2] === [1,2] 50 | perf (take 2) [1..3] === [1,2] 51 | perf (take 3) [1..3] === [1..3] 52 | perf (take 3) [1..] === [1..3] 53 | perf (take 0) undefined === ([] :: [Int]) 54 | perf (take 3) (1:2:3:undefined) === [1..3] 55 | label "filter" $ do 56 | perf (filter even) [] === [] 57 | perf (filter even) [1] === [] 58 | perf (filter even) [1,3,5] === [] 59 | perf (filter even) [1..5] === [2,4] 60 | label "map-take-filter" $ do 61 | perf (map (* 3) . take 5 . filter even) [1..] === [6,12] 62 | perf (map (* 3) . filter even . take 5) [1..] === [6,12,18,24,30] 63 | perf (take 5 . map (* 3) . filter even) [1..] === [6,12] 64 | perf (take 5 . filter even . map (* 3)) [1..] === [6,12] 65 | perf (filter even . map (* 3) . take 5) [1..] === [6,12,18,24,30] 66 | perf (filter even . take 5 . map (* 3)) [1..] === [6,12,18,24,30] 67 | label "drop" $ do 68 | perf (drop 0) [] === ([] :: [Int]) 69 | perf (drop 1) [] === ([] :: [Int]) 70 | perf (drop 0) [1] === [1] 71 | perf (drop 1) [1] === [] 72 | perf (drop 2) [1] === [] 73 | perf (drop 0) [1..4] === [1..4] 74 | perf (drop 1) [1..4] === [2..4] 75 | perf (drop 3) [1..4] === [4] 76 | perf (drop 4) [1..4] === [] 77 | perf (drop 5) [1..4] === [] 78 | perf (drop 9) [1..4] === [] 79 | label "takeWhile" $ do 80 | perf (takeWhile (<= 5)) [] === [] 81 | perf (takeWhile (<= 5)) [1..4] === [1..4] 82 | perf (takeWhile (<= 5)) [1..6] === [1..5] 83 | perf (takeWhile (<= 5)) [5..] === [5] 84 | perf (takeWhile (<= 5)) [6..] === [] 85 | perf (takeWhile (<= 5)) (4:5:6:undefined) === [4,5] 86 | label "dropWhile" $ do 87 | perf (dropWhile (<= 5)) [] === [] 88 | perf (dropWhile (<= 5)) [1..4] === [] 89 | perf (dropWhile (<= 5)) [1..6] === [6] 90 | perf (dropWhile (<= 5)) [3..9] === [6..9] 91 | perf (dropWhile (<= 5)) [5..9] === [6..9] 92 | label "scan" $ do 93 | label "basic" $ do 94 | perf (scan sum) [] === [0] 95 | perf (scan sum) [1] === [0,1] 96 | perf (scan sum) [1..5] === [0,1,3,6,10,15] 97 | label "stop" $ do 98 | label "single" $ do 99 | perf (take 0 . scan sum) [1..] === [0] 100 | perf (scan sum . take 0) [1..] === [] 101 | perf (take 5 . scan sum) [1..] === [0,1,3,6,10,15] 102 | perf (scan sum . take 5) [1..] === [0,1,3,6,10] 103 | perf (scan (take 5 sum)) [1..] === [0,1,3,6,10,15] 104 | label "multi" $ do 105 | perf (take 5 . scan sum . take 3) [1..] === [0,1,3] 106 | perf (take 3 . scan sum . take 5) [1..] === [0,1,3,6] 107 | perf (scan (take 5 sum) . take 3) [1..] === [0,1,3] 108 | perf (scan (take 3 sum) . take 5) [1..] === [0,1,3,6] 109 | perf (scan (take 5 sum) . take 4) [1..] === [0,1,3,6] 110 | perf (scan (take 4 sum) . take 5) [1..] === [0,1,3,6,10] 111 | perf (scan (take 5 sum) . take 5) [1..] === [0,1,3,6,10] 112 | let testGroupBy gby = do 113 | label "basic" $ do 114 | exec (gby (<) list list) [1] === [[1]] 115 | exec (gby (<) list list) [1,2] === [[1,2]] 116 | exec (gby (<) list list) [1,3,2] === [[1,3],[2]] 117 | exec (gby (<) list list) [2,1,3] === [[2],[1,3]] 118 | exec (gby (<) list list) [2,1,3,4,5] === [[2],[1,3,4,5]] 119 | exec (gby (<) list list) [2,1,3,4,5,4,2,1,4,6,8] === [[2],[1,3,4,5],[4],[2],[1,4,6,8]] 120 | exec (gby (<) list list) [1..5] === [[1..5]] 121 | label "stop" $ do 122 | let xs = [7,1,2,3,4,3,5,9,2] ++ [1..] 123 | exec (gby (<) (take 0 list) $ take 0 list) xs === [] 124 | exec (gby (<) (take 0 list) $ take 1 list) xs === [[]] 125 | exec (gby (<) (take 0 list) $ take 3 list) xs === [[],[],[]] 126 | exec (gby (<) (take 1 list) $ take 0 list) xs === [] 127 | exec (gby (<) (take 3 list) $ take 0 list) xs === [] 128 | exec (gby (<) (take 1 list) $ take 1 list) xs === [[7]] 129 | exec (gby (<) (take 2 list) $ take 3 list) xs === [[7],[1,2],[3,5]] 130 | exec (gby (<) (take 3 list) $ take 2 list) xs === [[7],[1,2,3]] 131 | exec (gby (<) (take 3 list) $ take 3 list) xs === [[7],[1,2,3],[3,5,9]] 132 | exec (take 12 $ gby (<) list list) xs === [[7],[1,2,3,4],[3,5,9],[2],[1,2,3]] 133 | exec (take 12 $ gby (<) (take 2 list) list) xs === [[7],[1,2],[3,5],[2],[1,2]] 134 | label "groupBy" $ do 135 | label "empty" $ do 136 | exec (groupBy (<) sum list) [] === [] 137 | exec (groupBy (<) list list) [] === ([] :: [[Int]]) 138 | testGroupBy groupBy 139 | label "groupBy1" $ do 140 | label "empty" $ do 141 | exec (groupBy1 (<) sum list) [] === [0] 142 | exec (groupBy1 (<) list list) [] === ([[]] :: [[Int]]) 143 | testGroupBy groupBy1 144 | label "inits" $ do 145 | label "basic" $ do 146 | exec (inits list list) [] === [[] :: [Int]] 147 | exec (inits list list) [1] === [[],[1]] 148 | exec (inits list list) [1..4] === [[],[1],[1,2],[1,2,3],[1,2,3,4]] 149 | label "stop" $ do 150 | label "finite" $ do 151 | exec (inits (take 0 list) (take 0 list)) [1,2] === [] 152 | exec (inits (take 3 list) (take 0 list)) [1,2] === [] 153 | exec (inits (take 0 list) (take 1 list)) [1,2] === [[]] 154 | exec (inits (take 0 list) (take 4 list)) [1,2] === [[],[],[]] 155 | exec (inits (take 2 list) (take 4 list)) [1,2] === [[],[1],[1,2]] 156 | exec (inits (take 4 list) (take 4 list)) [1,2] === [[],[1],[1,2]] 157 | exec (inits (take 3 list) (take 5 list)) [1,2] === [[],[1],[1,2]] 158 | label "infinite" $ do 159 | exec (inits (take 0 list) (take 0 list)) [1..] === [] 160 | exec (inits (take 3 list) (take 0 list)) [1..] === [] 161 | exec (inits (take 0 list) (take 1 list)) [1..] === [[]] 162 | exec (inits (take 0 list) (take 4 list)) [1..] === [[],[],[],[]] 163 | exec (inits (take 2 list) (take 4 list)) [1..] === [[],[1],[1,2],[1,2]] 164 | exec (inits (take 4 list) (take 4 list)) [1..] === [[],[1],[1,2],[1,2,3]] 165 | exec (inits (take 3 list) (take 5 list)) [1..] === [[],[1],[1,2],[1,2,3],[1,2,3]] 166 | label "chunks" $ do 167 | label "degenerate" $ do 168 | exec (chunks list list) [] === ([] :: [[Int]]) 169 | exec (chunks list list) [1] === [[1]] 170 | exec (chunks list list) [1..4] === [[1..4]] 171 | label "chunksOf" $ do 172 | label "degenerate" $ do 173 | exec (chunksOf 0 list list) [] === ([] :: [[Int]]) 174 | exec (chunksOf 0 list list) [1] === ([] :: [[Int]]) 175 | exec (chunksOf 0 list list) [1..4] === ([] :: [[Int]]) 176 | label "basic" $ do 177 | exec (chunksOf 1 list list) [] === ([] :: [[Int]]) 178 | exec (chunksOf 1 list list) [1] === [[1]] 179 | exec (chunksOf 1 list list) [1..4] === [[1],[2],[3],[4]] 180 | exec (chunksOf 3 list list) [1] === [[1]] 181 | exec (chunksOf 3 list list) [1..4] === [[1,2,3],[4]] 182 | exec (chunksOf 3 list list) [1..5] === [[1,2,3],[4,5]] 183 | exec (chunksOf 3 list list) [1..6] === [[1,2,3],[4,5,6]] 184 | label "splitOne" $ do 185 | exec (splitOne ',' list list) "" === [] 186 | exec (splitOne ',' list list) "," === [""] 187 | exec (splitOne ',' list list) ",," === ["",""] 188 | exec (splitOne ',' list list) "a" === ["a"] 189 | exec (splitOne ',' list list) "abc" === ["abc"] 190 | exec (splitOne ',' list list) "a,bcd" === ["a", "bcd"] 191 | exec (splitOne ',' list list) "ab,c,def" === ["ab", "c", "def"] 192 | exec (splitOne ',' list list) "abc,def," === ["abc", "def"] 193 | exec (splitOne ',' list list) "abc,def,," === ["abc", "def", ""] 194 | label "compose" $ do 195 | label "parallel" $ do 196 | label "product" $ do 197 | exec ((,) <$> list <&> list) [] === ([],[] :: [Int]) 198 | exec ((,) <$> list <&> list) [1..4] === ([1..4],[1..4]) 199 | exec ((,) <$> take 3 list <&> list) [1..4] === ([1..3],[1..3]) 200 | exec ((,) <$> list <&> take 3 list) [1..4] === ([1..3],[1..3]) 201 | exec ((,) <$> take 0 list <&> take 1 list) [1..] === ([],[]) 202 | exec ((,) <$> take 1 list <&> take 0 list) [1..] === ([],[]) 203 | exec ((,) <$> take 1 list <&> take 1 list) [1..] === ([1],[1]) 204 | exec ((,) <$> take 3 list <&> take 4 list) [1..] === ([1..3],[1..3]) 205 | exec ((,) <$> take 4 list <&> take 3 list) [1..] === ([1..3],[1..3]) 206 | exec ((,) <$> take 4 list <&> take 4 list) [1..] === ([1..4],[1..4]) 207 | label "sum" $ do 208 | exec ((,) <$> list <+> list) [] === ([],[] :: [Int]) 209 | exec ((,) <$> list <+> list) [1..4] === ([1..4],[1..4]) 210 | exec ((,) <$> take 3 list <+> list) [1..4] === ([1..3],[1..4]) 211 | exec ((,) <$> list <+> take 3 list) [1..4] === ([1..4],[1..3]) 212 | exec ((,) <$> take 0 list <+> take 1 list) [1..] === ([],[1]) 213 | exec ((,) <$> take 1 list <+> take 0 list) [1..] === ([1],[]) 214 | exec ((,) <$> take 1 list <+> take 1 list) [1..] === ([1],[1]) 215 | exec ((,) <$> take 3 list <+> take 4 list) [1..] === ([1..3],[1..4]) 216 | exec ((,) <$> take 4 list <+> take 3 list) [1..] === ([1..4],[1..3]) 217 | exec ((,) <$> take 4 list <+> take 4 list) [1..] === ([1..4],[1..4]) 218 | label "sequential" $ do 219 | label "apply" $ do 220 | exec ((,) <$> list <*> list) [] === ([],[] :: [Int]) 221 | exec ((,) <$> list <*> list) [1..4] === ([1..4],[]) 222 | exec ((,) <$> take 3 list <*> list) [1..4] === ([1..3],[4]) 223 | exec ((,) <$> list <*> take 3 list) [1..4] === ([1..4],[]) 224 | exec ((,) <$> take 0 list <*> take 1 list) [1..] === ([],[1]) 225 | exec ((,) <$> take 1 list <*> take 0 list) [1..] === ([1],[]) 226 | exec ((,) <$> take 1 list <*> take 1 list) [1..] === ([1],[2]) 227 | exec ((,) <$> take 3 list <*> take 4 list) [1..] === ([1..3],[4..7]) 228 | exec ((,) <$> take 4 list <*> take 3 list) [1..] === ([1..4],[5..7]) 229 | exec ((,) <$> take 4 list <*> take 4 list) [1..] === ([1..4],[5..8]) 230 | label "weld" $ do 231 | exec ((,) <$> list list) [] === ([],[] :: [Int]) 232 | exec ((,) <$> list list) [1..4] === ([1..4],[]) -- Sic. 233 | exec ((,) <$> take 3 list list) [1..4] === ([1..3],[3,4]) 234 | exec ((,) <$> list take 3 list) [1..4] === ([1..4],[]) -- Sic. 235 | exec ((,) <$> take 0 list take 1 list) [1..] === ([],[1]) 236 | exec ((,) <$> take 1 list take 0 list) [1..] === ([1],[]) 237 | exec ((,) <$> take 1 list take 1 list) [1..] === ([1],[1]) 238 | exec ((,) <$> take 3 list take 4 list) [1..] === ([1..3],[3..6]) 239 | exec ((,) <$> take 4 list take 3 list) [1..] === ([1..4],[4..6]) 240 | exec ((,) <$> take 4 list take 4 list) [1..] === ([1..4],[4..7]) 241 | label "bind" $ do 242 | label "degenerate" $ do 243 | exec (take 0 sum >>= \n -> (,) n <$> take n list) [] === (0, []) 244 | exec (take 0 sum >>= \n -> (,) n <$> take n list) [1..3] === (0, []) 245 | exec (take 3 sum >>= \n -> (,) n <$> take n list) [] === (0, []) 246 | exec (take 3 sum >>= \n -> (,) n <$> take n list) [1..3] === (6, []) 247 | label "basic" $ do 248 | exec (take 0 sum >>= \n -> (,) n <$> take 2 list) [1..3] === (0, [1,2]) 249 | exec (take 0 sum >>= \n -> (,) n <$> take 4 list) [1..3] === (0, [1..3]) 250 | exec (take 2 sum >>= \n -> (,) n <$> take n list) [1..3] === (3, [3]) 251 | exec (take 2 sum >>= \n -> (,) n <$> take n list) [1..5] === (3, [3..5]) 252 | exec (take 2 sum >>= \n -> (,) n <$> take n list) [1..6] === (3, [3..5]) 253 | label "null" $ do 254 | exec null [] === True 255 | exec null [1] === False 256 | exec null (1 : P.repeat 2) === False 257 | exec null (1:undefined) === False 258 | label "length" $ do 259 | exec length [] === 0 260 | exec length [1] === 1 261 | exec length [1..5] === 5 262 | label "all" $ do 263 | exec (all even) [] === True 264 | exec (all even) [1] === False 265 | exec (all even) [2] === True 266 | exec (all even) [2,3] === False 267 | exec (all even) [2,4,6] === True 268 | exec (all even) ([2,4,6] ++ P.repeat 1) === False 269 | exec (all even) (2:4:6:1:undefined) === False 270 | label "any" $ do 271 | exec (any even) [] === False 272 | exec (any even) [1] === False 273 | exec (any even) [2] === True 274 | exec (any even) [2,3] === True 275 | exec (any even) [1,3,4] === True 276 | exec (any even) ([1,3,5] ++ P.repeat 2) === True 277 | exec (any even) (1:3:5:2:undefined) === True 278 | label "find" $ do 279 | exec (find even) [] === Nothing 280 | exec (find even) [1] === Nothing 281 | exec (find even) [2] === Just 2 282 | exec (find even) [2,3] === Just 2 283 | exec (find even) [1,3,4] === Just 4 284 | exec (find even) ([1,3,5] ++ P.repeat 2) === Just 2 285 | exec (find even) (1:3:5:2:undefined) === Just 2 286 | label "head" $ do 287 | exec head [] === (Nothing :: Maybe Int) 288 | exec head [1] === Just 1 289 | exec head [1..5] === Just 1 290 | exec head (1 : P.repeat 2) === Just 1 291 | exec head (1:undefined) === Just 1 292 | label "last" $ do 293 | exec last [] === (Nothing :: Maybe Int) 294 | exec last [1] === Just 1 295 | exec last [1..5] === Just 5 296 | label "random" $ do 297 | perf (takeWhile (< 10) . dropWhile (<= 3) . filter even) [1..] === [4,6,8] 298 | exec ((,) <$> take 4 list <+> (drop 2 . take 4) list) [1..] === ([1..4],[3..6]) 299 | perf (filter even . scan sum . take 6 . dropWhile (<= 10)) [1..] === [12,20,30] 300 | exec ((,,) <$> take 4 list <+> take 3 list <&> take 2 list) [1..] === ([1..2],[1..2],[1..2]) 301 | exec ((,,) <$> take 4 list <+> take 3 list <&> take 5 list) [1..] === ([1..4],[1..3],[1..4]) 302 | exec ((,,) <$> take 4 list <+> take 3 list <*> take 2 list) [1..] === ([1..4],[1..3],[5..6]) 303 | exec ((,) <$> sum <&> any even) [1..3] === (3,True) 304 | exec ((,) <$> sum <+> any even) [1..3] === (6,True) 305 | exec (handle P.traverse $ take 5 sum) ([1..3] : P.repeat [4..]) === 15 306 | 307 | checkSuite :: IO () 308 | checkSuite = putStrLn $ runSuite suite 309 | 310 | foldMN :: Monad m => (f acc -> (acc -> m b) -> m b) -> 311 | (acc -> m b) -> (acc -> a -> f acc) -> f acc -> [m a] -> m b 312 | foldMN (>>~) g f a xs = a >>~ foldr (\mx r !a -> mx >>= \x -> f a x >>~ r) g xs 313 | 314 | -- 2 315 | -- 4 316 | -- 6 317 | -- [120,12] 318 | -- [7,8,9,10] 319 | -- 11 320 | example :: IO () 321 | example = execM (final <$> sink1 <+> sink2 <*> sink3 <&>> total) [1..] where 322 | final x y zs n = print [x,y] >> print zs >> print n 323 | sink1 = take 4 $ map succ product -- 2 * 3 * 4 * 5 = 120 324 | sink2 = take 6 . filter even $ traverse_ print &> sum -- 2 + 4 + 6 = 12 325 | sink3 = takeWhile (<= 10) list -- [7,8,9,10] 326 | total = length -- total number of processed elements is 11, since 327 | -- `takeWhile (<= 10)` forced `11` before it stopped. 328 | 329 | -- 1 1 330 | -- 2 4 331 | -- 3 9 332 | test1 :: IO () 333 | test1 = impurely foldMN (take 3 . traverse_ $ print . (^2)) $ 334 | P.map (\n -> n <$ putStr (show n ++ " ")) [1..] where 335 | 336 | main = checkSuite 337 | --------------------------------------------------------------------------------