{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
module Control.Foldl (
Fold(..)
, FoldM(..)
, fold
, foldM
, scan
, prescan
, postscan
, Control.Foldl.mconcat
, Control.Foldl.foldMap
, head
, last
, lastDef
, lastN
, null
, length
, and
, or
, all
, any
, sum
, product
, mean
, variance
, std
, maximum
, maximumBy
, minimum
, minimumBy
, elem
, notElem
, find
, index
, lookup
, elemIndex
, findIndex
, random
, randomN
, Control.Foldl.mapM_
, sink
, genericLength
, genericIndex
, list
, revList
, nub
, eqNub
, set
, hashSet
, map
, foldByKeyMap
, hashMap
, foldByKeyHashMap
, vector
, vectorM
, purely
, purely_
, impurely
, impurely_
, generalize
, simplify
, hoists
, duplicateM
, _Fold1
, premap
, premapM
, prefilter
, prefilterM
, predropWhile
, drop
, dropM
, Handler
, handles
, foldOver
, EndoM(..)
, HandlerM
, handlesM
, foldOverM
, folded
, filtered
, groupBy
, either
, eitherM
, nest
, module Control.Monad.Primitive
, module Data.Foldable
, module Data.Vector.Generic
) where
import Control.Foldl.Optics (_Left, _Right)
import Control.Applicative
import Control.Foldl.Internal (Maybe'(..), lazy, Either'(..), Pair(..), hush)
import Control.Monad ((<=<))
import Control.Monad.Primitive (PrimMonad, RealWorld)
import Control.Comonad
import Data.Foldable (Foldable)
import Data.Functor.Identity (Identity, runIdentity)
import Data.Functor.Contravariant (Contravariant(..))
import Data.HashMap.Strict (HashMap)
import Data.Map.Strict (Map, alter)
import Data.Maybe (fromMaybe)
import Data.Monoid hiding ((<>))
import Data.Semigroup (Semigroup(..))
import Data.Semigroupoid (Semigroupoid)
import Data.Profunctor
import Data.Sequence ((|>))
import Data.Vector.Generic (Vector, Mutable)
import Data.Vector.Generic.Mutable (MVector)
import Data.Hashable (Hashable)
import Data.Traversable
import Numeric.Natural (Natural)
import System.Random.MWC (GenIO, createSystemRandom, uniformR)
import Prelude hiding
( head
, last
, null
, length
, and
, or
, all
, any
, sum
, product
, maximum
, minimum
, elem
, notElem
, lookup
, map
, either
, drop
)
import qualified Data.Foldable as F
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet
import qualified Data.Vector.Generic as V
import qualified Control.Foldl.Util.Vector as V
import qualified Data.Vector.Generic.Mutable as M
import qualified Data.Semigroupoid
data Fold a b
= forall x. Fold (x -> a -> x) x (x -> b)
instance Functor (Fold a) where
fmap f (Fold step begin done) = Fold step begin (f . done)
{-# INLINE fmap #-}
instance Profunctor Fold where
lmap = premap
rmap = fmap
instance Choice Fold where
right' (Fold step begin done) = Fold (liftA2 step) (Right begin) (fmap done)
{-# INLINE right' #-}
instance Comonad (Fold a) where
extract (Fold _ begin done) = done begin
{-# INLINE extract #-}
duplicate (Fold step begin done) = Fold step begin (\x -> Fold step x done)
{-# INLINE duplicate #-}
instance Applicative (Fold a) where
pure b = Fold (\() _ -> ()) () (\() -> b)
{-# INLINE pure #-}
(Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) =
let step (Pair xL xR) a = Pair (stepL xL a) (stepR xR a)
begin = Pair beginL beginR
done (Pair xL xR) = doneL xL (doneR xR)
in Fold step begin done
{-# INLINE (<*>) #-}
instance Semigroup b => Semigroup (Fold a b) where
(<>) = liftA2 (<>)
{-# INLINE (<>) #-}
instance Semigroupoid Fold where
o (Fold step1 begin1 done1) (Fold step2 begin2 done2) = Fold
step
(Pair begin1 begin2)
(\(Pair x _) -> done1 x)
where
step (Pair c1 c2) a =
let c2' = step2 c2 a
c1' = step1 c1 (done2 c2')
in Pair c1' c2'
{-# INLINE o #-}
instance Monoid b => Monoid (Fold a b) where
mempty = pure mempty
{-# INLINE mempty #-}
mappend = liftA2 mappend
{-# INLINE mappend #-}
instance Num b => Num (Fold a b) where
fromInteger = pure . fromInteger
{-# INLINE fromInteger #-}
negate = fmap negate
{-# INLINE negate #-}
abs = fmap abs
{-# INLINE abs #-}
signum = fmap signum
{-# INLINE signum #-}
(+) = liftA2 (+)
{-# INLINE (+) #-}
(*) = liftA2 (*)
{-# INLINE (*) #-}
(-) = liftA2 (-)
{-# INLINE (-) #-}
instance Fractional b => Fractional (Fold a b) where
fromRational = pure . fromRational
{-# INLINE fromRational #-}
recip = fmap recip
{-# INLINE recip #-}
(/) = liftA2 (/)
{-# INLINE (/) #-}
instance Floating b => Floating (Fold a b) where
pi = pure pi
{-# INLINE pi #-}
exp = fmap exp
{-# INLINE exp #-}
sqrt = fmap sqrt
{-# INLINE sqrt #-}
log = fmap log
{-# INLINE log #-}
sin = fmap sin
{-# INLINE sin #-}
tan = fmap tan
{-# INLINE tan #-}
cos = fmap cos
{-# INLINE cos #-}
asin = fmap asin
{-# INLINE asin #-}
atan = fmap atan
{-# INLINE atan #-}
acos = fmap acos
{-# INLINE acos #-}
sinh = fmap sinh
{-# INLINE sinh #-}
tanh = fmap tanh
{-# INLINE tanh #-}
cosh = fmap cosh
{-# INLINE cosh #-}
asinh = fmap asinh
{-# INLINE asinh #-}
atanh = fmap atanh
{-# INLINE atanh #-}
acosh = fmap acosh
{-# INLINE acosh #-}
(**) = liftA2 (**)
{-# INLINE (**) #-}
logBase = liftA2 logBase
{-# INLINE logBase #-}
data FoldM m a b =
forall x . FoldM (x -> a -> m x) (m x) (x -> m b)
instance Functor m => Functor (FoldM m a) where
fmap f (FoldM step start done) = FoldM step start done'
where
done' x = fmap f $! done x
{-# INLINE fmap #-}
instance Applicative m => Applicative (FoldM m a) where
pure b = FoldM (\() _ -> pure ()) (pure ()) (\() -> pure b)
{-# INLINE pure #-}
(FoldM stepL beginL doneL) <*> (FoldM stepR beginR doneR) =
let step (Pair xL xR) a = Pair <$> stepL xL a <*> stepR xR a
begin = Pair <$> beginL <*> beginR
done (Pair xL xR) = doneL xL <*> doneR xR
in FoldM step begin done
{-# INLINE (<*>) #-}
instance Functor m => Profunctor (FoldM m) where
rmap = fmap
lmap f (FoldM step begin done) = FoldM step' begin done
where
step' x a = step x (f a)
instance (Semigroup b, Monad m) => Semigroup (FoldM m a b) where
(<>) = liftA2 (<>)
{-# INLINE (<>) #-}
instance (Monoid b, Monad m) => Monoid (FoldM m a b) where
mempty = pure mempty
{-# INLINE mempty #-}
mappend = liftA2 mappend
{-# INLINE mappend #-}
instance (Monad m, Num b) => Num (FoldM m a b) where
fromInteger = pure . fromInteger
{-# INLINE fromInteger #-}
negate = fmap negate
{-# INLINE negate #-}
abs = fmap abs
{-# INLINE abs #-}
signum = fmap signum
{-# INLINE signum #-}
(+) = liftA2 (+)
{-# INLINE (+) #-}
(*) = liftA2 (*)
{-# INLINE (*) #-}
(-) = liftA2 (-)
{-# INLINE (-) #-}
instance (Monad m, Fractional b) => Fractional (FoldM m a b) where
fromRational = pure . fromRational
{-# INLINE fromRational #-}
recip = fmap recip
{-# INLINE recip #-}
(/) = liftA2 (/)
{-# INLINE (/) #-}
instance (Monad m, Floating b) => Floating (FoldM m a b) where
pi = pure pi
{-# INLINE pi #-}
exp = fmap exp
{-# INLINE exp #-}
sqrt = fmap sqrt
{-# INLINE sqrt #-}
log = fmap log
{-# INLINE log #-}
sin = fmap sin
{-# INLINE sin #-}
tan = fmap tan
{-# INLINE tan #-}
cos = fmap cos
{-# INLINE cos #-}
asin = fmap asin
{-# INLINE asin #-}
atan = fmap atan
{-# INLINE atan #-}
acos = fmap acos
{-# INLINE acos #-}
sinh = fmap sinh
{-# INLINE sinh #-}
tanh = fmap tanh
{-# INLINE tanh #-}
cosh = fmap cosh
{-# INLINE cosh #-}
asinh = fmap asinh
{-# INLINE asinh #-}
atanh = fmap atanh
{-# INLINE atanh #-}
acosh = fmap acosh
{-# INLINE acosh #-}
(**) = liftA2 (**)
{-# INLINE (**) #-}
logBase = liftA2 logBase
{-# INLINE logBase #-}
fold :: Foldable f => Fold a b -> f a -> b
fold (Fold step begin done) as = F.foldr cons done as begin
where
cons a k x = k $! step x a
{-# INLINE fold #-}
foldM :: (Foldable f, Monad m) => FoldM m a b -> f a -> m b
foldM (FoldM step begin done) as0 = do
x0 <- begin
F.foldr step' done as0 $! x0
where
step' a k x = do
x' <- step x a
k $! x'
{-# INLINE foldM #-}
scan :: Fold a b -> [a] -> [b]
scan (Fold step begin done) as = foldr cons nil as begin
where
nil x = done x:[]
cons a k x = done x:(k $! step x a)
{-# INLINE scan #-}
prescan :: Traversable t => Fold a b -> t a -> t b
prescan (Fold step begin done) as = bs
where
step' x a = (x', b)
where
x' = step x a
b = done x
(_, bs) = mapAccumL step' begin as
{-# INLINE prescan #-}
postscan :: Traversable t => Fold a b -> t a -> t b
postscan (Fold step begin done) as = bs
where
step' x a = (x', b)
where
x' = step x a
b = done x'
(_, bs) = mapAccumL step' begin as
{-# INLINE postscan #-}
mconcat :: Monoid a => Fold a a
mconcat = Fold mappend mempty id
{-# INLINABLE mconcat #-}
foldMap :: Monoid w => (a -> w) -> (w -> b) -> Fold a b
foldMap to = Fold (\x a -> mappend x (to a)) mempty
{-# INLINABLE foldMap #-}
head :: Fold a (Maybe a)
head = _Fold1 const
{-# INLINABLE head #-}
last :: Fold a (Maybe a)
last = _Fold1 (flip const)
{-# INLINABLE last #-}
lastDef :: a -> Fold a a
lastDef a = Fold (\_ a' -> a') a id
{-# INLINABLE lastDef #-}
lastN :: Int -> Fold a [a]
lastN n = Fold step begin done
where
step s a = s' |> a
where
s' =
if Seq.length s < n
then s
else Seq.drop 1 s
begin = Seq.empty
done = F.toList
{-# INLINABLE lastN #-}
null :: Fold a Bool
null = Fold (\_ _ -> False) True id
{-# INLINABLE null #-}
length :: Fold a Int
length = genericLength
{-# INLINABLE length #-}
and :: Fold Bool Bool
and = Fold (&&) True id
{-# INLINABLE and #-}
or :: Fold Bool Bool
or = Fold (||) False id
{-# INLINABLE or #-}
all :: (a -> Bool) -> Fold a Bool
all predicate = Fold (\x a -> x && predicate a) True id
{-# INLINABLE all #-}
any :: (a -> Bool) -> Fold a Bool
any predicate = Fold (\x a -> x || predicate a) False id
{-# INLINABLE any #-}
sum :: Num a => Fold a a
sum = Fold (+) 0 id
{-# INLINABLE sum #-}
product :: Num a => Fold a a
product = Fold (*) 1 id
{-# INLINABLE product #-}
mean :: Fractional a => Fold a a
mean = Fold step begin done
where
begin = Pair 0 0
step (Pair x n) y = let n' = n+1 in Pair (x + (y - x) /n') n'
done (Pair x _) = x
{-# INLINABLE mean #-}
variance :: Fractional a => Fold a a
variance = Fold step begin done
where
begin = Pair3 0 0 0
step (Pair3 n mean_ m2) x = Pair3 n' mean' m2'
where
n' = n + 1
mean' = (n * mean_ + x) / (n + 1)
delta = x - mean_
m2' = m2 + delta * delta * n / (n + 1)
done (Pair3 n _ m2) = m2 / n
{-# INLINABLE variance #-}
std :: Floating a => Fold a a
std = sqrt variance
{-# INLINABLE std #-}
maximum :: Ord a => Fold a (Maybe a)
maximum = _Fold1 max
{-# INLINABLE maximum #-}
maximumBy :: (a -> a -> Ordering) -> Fold a (Maybe a)
maximumBy cmp = _Fold1 max'
where
max' x y = case cmp x y of
GT -> x
_ -> y
{-# INLINABLE maximumBy #-}
minimum :: Ord a => Fold a (Maybe a)
minimum = _Fold1 min
{-# INLINABLE minimum #-}
minimumBy :: (a -> a -> Ordering) -> Fold a (Maybe a)
minimumBy cmp = _Fold1 min'
where
min' x y = case cmp x y of
GT -> y
_ -> x
{-# INLINABLE minimumBy #-}
elem :: Eq a => a -> Fold a Bool
elem a = any (a ==)
{-# INLINABLE elem #-}
notElem :: Eq a => a -> Fold a Bool
notElem a = all (a /=)
{-# INLINABLE notElem #-}
find :: (a -> Bool) -> Fold a (Maybe a)
find predicate = Fold step Nothing' lazy
where
step x a = case x of
Nothing' -> if predicate a then Just' a else Nothing'
_ -> x
{-# INLINABLE find #-}
index :: Int -> Fold a (Maybe a)
index = genericIndex
{-# INLINABLE index #-}
elemIndex :: Eq a => a -> Fold a (Maybe Int)
elemIndex a = findIndex (a ==)
{-# INLINABLE elemIndex #-}
findIndex :: (a -> Bool) -> Fold a (Maybe Int)
findIndex predicate = Fold step (Left' 0) hush
where
step x a = case x of
Left' i ->
if predicate a
then Right' i
else Left' (i + 1)
_ -> x
{-# INLINABLE findIndex #-}
lookup :: Eq a => a -> Fold (a,b) (Maybe b)
lookup a0 = Fold step Nothing' lazy
where
step x (a,b) = case x of
Nothing' -> if a == a0
then Just' b
else Nothing'
_ -> x
{-# INLINABLE lookup #-}
data Pair3 a b c = Pair3 !a !b !c
random :: FoldM IO a (Maybe a)
random = FoldM step begin done
where
begin = do
g <- createSystemRandom
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 c = if n == 1 then b else a
return $! Pair3 g (Just' c) (m + 1)
done (Pair3 _ ma _) = return (lazy ma)
{-# INLINABLE random #-}
data VectorState = Incomplete {-# UNPACK #-} !Int | Complete
data RandomNState v a = RandomNState
{ _size :: !VectorState
, _reservoir :: !(Mutable v RealWorld a)
, _position :: {-# UNPACK #-} !Int
, _gen :: {-# UNPACK #-} !GenIO
}
randomN :: Vector v a => Int -> FoldM IO a (Maybe (v a))
randomN n = FoldM step begin done
where
step
:: MVector (Mutable v) a
=> RandomNState v a -> a -> IO (RandomNState v a)
step (RandomNState (Incomplete m) mv i g) a = do
M.write mv m a
let m' = m + 1
let s = if n <= m' then Complete else Incomplete m'
return $! RandomNState s mv (i + 1) g
step (RandomNState Complete mv i g) a = do
r <- uniformR (0, i - 1) g
if r < n
then M.unsafeWrite mv r a
else return ()
return (RandomNState Complete mv (i + 1) g)
begin = do
mv <- M.new n
gen <- createSystemRandom
let s = if n <= 0 then Complete else Incomplete 0
return (RandomNState s mv 1 gen)
done :: Vector v a => RandomNState v a -> IO (Maybe (v a))
done (RandomNState (Incomplete _) _ _ _) = return Nothing
done (RandomNState Complete mv _ _) = do
v <- V.freeze mv
return (Just v)
mapM_ :: Monad m => (a -> m ()) -> FoldM m a ()
mapM_ = sink
{-# INLINABLE mapM_ #-}
sink :: (Monoid w, Monad m) => (a -> m w) -> FoldM m a w
sink act = FoldM step begin done where
done = return
begin = return mempty
step m a = do
m' <- act a
return $! mappend m m'
{-# INLINABLE sink #-}
genericLength :: Num b => Fold a b
genericLength = Fold (\n _ -> n + 1) 0 id
{-# INLINABLE genericLength #-}
genericIndex :: Integral i => i -> Fold a (Maybe a)
genericIndex i = Fold step (Left' 0) done
where
step x a = case x of
Left' j -> if i == j then Right' a else Left' (j + 1)
_ -> x
done x = case x of
Left' _ -> Nothing
Right' a -> Just a
{-# INLINABLE genericIndex #-}
list :: Fold a [a]
list = Fold (\x a -> x . (a:)) id ($ [])
{-# INLINABLE list #-}
revList :: Fold a [a]
revList = Fold (\x a -> a:x) [] id
{-# INLINABLE revList #-}
nub :: Ord a => Fold a [a]
nub = Fold step (Pair Set.empty id) fin
where
step (Pair s r) a = if Set.member a s
then Pair s r
else Pair (Set.insert a s) (r . (a :))
fin (Pair _ r) = r []
{-# INLINABLE nub #-}
eqNub :: Eq a => Fold a [a]
eqNub = Fold step (Pair [] id) fin
where
step (Pair known r) a = if List.elem a known
then Pair known r
else Pair (a : known) (r . (a :))
fin (Pair _ r) = r []
{-# INLINABLE eqNub #-}
set :: Ord a => Fold a (Set.Set a)
set = Fold (flip Set.insert) Set.empty id
{-# INLINABLE set #-}
hashSet :: (Eq a, Hashable a) => Fold a (HashSet.HashSet a)
hashSet = Fold (flip HashSet.insert) HashSet.empty id
{-# INLINABLE hashSet #-}
map :: Ord a => Fold (a, b) (Map.Map a b)
map = Fold step begin done
where
begin = mempty
step m (k, v) = Map.insert k v m
done = id
{-# INLINABLE map #-}
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
hashMap :: (Eq a, Hashable a) => Fold (a, b) (HashMap.HashMap a b)
hashMap = Fold step begin done
where
begin = mempty
step m (k, v) = HashMap.insert k v m
done = id
{-# INLINABLE hashMap #-}
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
vector :: Vector v a => Fold a (v a)
vector = V.fromReverseListN <$> length <*> revList
{-# INLINABLE vector #-}
maxChunkSize :: Int
maxChunkSize = 8 * 1024 * 1024
vectorM :: (PrimMonad m, Vector v a) => FoldM m a (v a)
vectorM = FoldM step begin done
where
begin = do
mv <- M.unsafeNew 10
return (Pair mv 0)
step (Pair mv idx) a = do
let len = M.length mv
mv' <- if idx >= len
then M.unsafeGrow mv (min len maxChunkSize)
else return mv
M.unsafeWrite mv' idx a
return (Pair mv' (idx + 1))
done (Pair mv idx) = do
v <- V.freeze mv
return (V.unsafeTake idx v)
{-# INLINABLE vectorM #-}
purely :: (forall x . (x -> a -> x) -> x -> (x -> b) -> r) -> Fold a b -> r
purely f (Fold step begin done) = f step begin done
{-# INLINABLE purely #-}
purely_ :: (forall x . (x -> a -> x) -> x -> x) -> Fold a b -> b
purely_ f (Fold step begin done) = done (f step begin)
{-# INLINABLE purely_ #-}
impurely
:: (forall x . (x -> a -> m x) -> m x -> (x -> m b) -> r)
-> FoldM m a b
-> r
impurely f (FoldM step begin done) = f step begin done
{-# INLINABLE impurely #-}
impurely_
:: Monad m
=> (forall x . (x -> a -> m x) -> m x -> m x) -> FoldM m a b -> m b
impurely_ f (FoldM step begin done) = do
x <- f step begin
done x
{-# INLINABLE impurely_ #-}
generalize :: Monad m => Fold a b -> FoldM m a b
generalize (Fold step begin done) = FoldM step' begin' done'
where
step' x a = return (step x a)
begin' = return begin
done' x = return (done x)
{-# INLINABLE generalize #-}
simplify :: FoldM Identity a b -> Fold a b
simplify (FoldM step begin done) = Fold step' begin' done'
where
step' x a = runIdentity (step x a)
begin' = runIdentity begin
done' x = runIdentity (done x)
{-# INLINABLE simplify #-}
hoists :: (forall x . m x -> n x) -> FoldM m a b -> FoldM n a b
hoists phi (FoldM step begin done) = FoldM (\a b -> phi (step a b)) (phi begin) (phi . done)
{-# INLINABLE hoists #-}
duplicateM :: Applicative m => FoldM m a b -> FoldM m a (FoldM m a b)
duplicateM (FoldM step begin done) =
FoldM step begin (\x -> pure (FoldM step (pure x) done))
{-# INLINABLE duplicateM #-}
_Fold1 :: (a -> a -> a) -> Fold a (Maybe a)
_Fold1 step = Fold step_ Nothing' lazy
where
step_ mx a = Just' (case mx of
Nothing' -> a
Just' x -> step x a)
{-# INLINABLE _Fold1 #-}
premap :: (a -> b) -> Fold b r -> Fold a r
premap f (Fold step begin done) = Fold step' begin done
where
step' x a = step x (f a)
{-# INLINABLE premap #-}
premapM :: Monad m => (a -> m b) -> FoldM m b r -> FoldM m a r
premapM f (FoldM step begin done) = FoldM step' begin done
where
step' x a = f a >>= step x
{-# INLINABLE premapM #-}
prefilter :: (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 :: (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 #-}
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 :: 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 :: 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 #-}
type Handler a b =
forall x . (b -> Const (Dual (Endo x)) b) -> a -> Const (Dual (Endo x)) a
handles :: Handler a b -> Fold b r -> Fold a r
handles k (Fold step begin done) = Fold step' begin done
where
step' = flip (appEndo . getDual . getConst . k (Const . Dual . Endo . flip step))
{-# INLINABLE handles #-}
foldOver :: Handler s a -> Fold a b -> s -> b
foldOver l (Fold step begin done) =
done . flip appEndo begin . getDual . getConst . l (Const . Dual . Endo . flip step)
{-# INLINABLE foldOver #-}
newtype EndoM m a = EndoM { appEndoM :: a -> m a }
instance Monad m => Semigroup (EndoM m a) where
(EndoM f) <> (EndoM g) = EndoM (f <=< g)
{-# INLINE (<>) #-}
instance Monad m => Monoid (EndoM m a) where
mempty = EndoM return
{-# INLINE mempty #-}
mappend = (<>)
{-# INLINE mappend #-}
type HandlerM m a b =
forall x . (b -> Const (Dual (EndoM m x)) b) -> a -> Const (Dual (EndoM m x)) a
handlesM :: HandlerM m a b -> FoldM m b r -> FoldM m a r
handlesM k (FoldM step begin done) = FoldM step' begin done
where
step' = flip (appEndoM . getDual . getConst . k (Const . Dual . EndoM . flip step))
{-# INLINABLE handlesM #-}
foldOverM :: Monad m => HandlerM m s a -> FoldM m a b -> s -> m b
foldOverM l (FoldM step begin done) s = do
b <- begin
r <- (flip appEndoM b . getDual . getConst . l (Const . Dual . EndoM . flip step)) s
done r
{-# INLINABLE foldOverM #-}
folded
:: (Contravariant f, Applicative f, Foldable t)
=> (a -> f a) -> (t a -> f (t a))
folded k ts = contramap (\_ -> ()) (F.traverse_ k ts)
{-# INLINABLE folded #-}
filtered :: Monoid m => (a -> Bool) -> (a -> m) -> a -> m
filtered p k x
| p x = k x
| otherwise = mempty
{-# INLINABLE filtered #-}
groupBy :: Ord g => (a -> g) -> Fold a r -> Fold a (Map g r)
groupBy grouper (Fold f i e) = Fold f' mempty (fmap e)
where
f' !m !a = alter (\o -> Just (f (fromMaybe i o) a)) (grouper a) m
{-# INLINABLE groupBy #-}
either :: Fold a1 b1 -> Fold a2 b2 -> Fold (Either a1 a2) (b1, b2)
either l r = (,) <$> handles _Left l <*> handles _Right r
{-# INLINABLE either #-}
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 :: 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 #-}