module Control.Foldl (
Fold(..)
, FoldM(..)
, fold
, foldM
, scan
, mconcat
, foldMap
, head
, last
, null
, length
, and
, or
, all
, any
, sum
, product
, maximum
, minimum
, elem
, notElem
, find
, index
, elemIndex
, findIndex
, genericLength
, genericIndex
, list
, vector
, purely
, impurely
, generalize
, simplify
, premap
, premapM
, module Control.Monad.Primitive
, module Data.Foldable
, module Data.Vector.Generic
) where
import Control.Applicative (Applicative(pure, (<*>)),liftA2)
import Control.Foldl.Internal (Maybe'(..), lazy, Either'(..), hush)
import Control.Monad.Primitive (PrimMonad)
import Data.Foldable (Foldable)
import qualified Data.Foldable as F
import Data.Functor.Identity (Identity, runIdentity)
import Data.Monoid (Monoid(mempty, mappend))
import Data.Vector.Generic (Vector)
import qualified Data.Vector.Generic as V
import qualified Data.Vector.Generic.Mutable as M
import Prelude hiding
( head
, last
, null
, length
, and
, or
, all
, any
, sum
, product
, maximum
, minimum
, elem
, notElem
)
data Fold a b = forall x . Fold (x -> a -> x) x (x -> b)
data Pair a b = Pair !a !b
instance Functor (Fold a) where
fmap f (Fold step begin done) = Fold step begin (f . done)
instance Applicative (Fold a) where
pure b = Fold (\() _ -> ()) () (\() -> b)
(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
instance Monoid b => Monoid (Fold a b) where
mempty = pure mempty
mappend = liftA2 mappend
data FoldM m a b = forall x . FoldM (x -> a -> m x) (m x) (x -> m b)
instance Monad m => Functor (FoldM m a) where
fmap f (FoldM step start done) = FoldM step start done'
where
done' x = do
b <- done x
return $! f b
instance Monad m => Applicative (FoldM m a) where
pure b = FoldM (\() _ -> return ()) (return ()) (\() -> return b)
(FoldM stepL beginL doneL) <*> (FoldM stepR beginR doneR) =
let step (Pair xL xR) a = do
xL' <- stepL xL a
xR' <- stepR xR a
return $! Pair xL' xR'
begin = do
xL <- beginL
xR <- beginR
return $! Pair xL xR
done (Pair xL xR) = do
f <- doneL xL
x <- doneR xR
return $! f x
in FoldM step begin done
instance (Monoid b, Monad m) => Monoid (FoldM m a b) where
mempty = pure mempty
mappend = liftA2 mappend
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
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'
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)
mconcat :: Monoid a => Fold a a
mconcat = Fold mappend mempty id
foldMap :: Monoid w => (a -> w) -> (w -> b) -> Fold a b
foldMap to from = Fold (\x a -> mappend x (to a)) mempty from
head :: Fold a (Maybe a)
head = Fold step Nothing' lazy
where
step x a = case x of
Nothing' -> Just' a
_ -> x
last :: Fold a (Maybe a)
last = Fold (\_ -> Just') Nothing' lazy
null :: Fold a Bool
null = Fold (\_ _ -> False) True id
length :: Fold a Int
length = genericLength
and :: Fold Bool Bool
and = Fold (&&) True id
or :: Fold Bool Bool
or = Fold (||) False id
all :: (a -> Bool) -> Fold a Bool
all predicate = Fold (\x a -> x && predicate a) True id
any :: (a -> Bool) -> Fold a Bool
any predicate = Fold (\x a -> x || predicate a) False id
sum :: Num a => Fold a a
sum = Fold (+) 0 id
product :: Num a => Fold a a
product = Fold (*) 1 id
maximum :: Ord a => Fold a (Maybe a)
maximum = Fold step Nothing' lazy
where
step x a = Just' (case x of
Nothing' -> a
Just' a' -> max a a')
minimum :: Ord a => Fold a (Maybe a)
minimum = Fold step Nothing' lazy
where
step x a = Just' (case x of
Nothing' -> a
Just' a' -> min a a')
elem :: Eq a => a -> Fold a Bool
elem a = any (a ==)
notElem :: Eq a => a -> Fold a Bool
notElem a = all (a /=)
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
index :: Int -> Fold a (Maybe a)
index = genericIndex
elemIndex :: Eq a => a -> Fold a (Maybe Int)
elemIndex a = findIndex (a ==)
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
genericLength :: Num b => Fold a b
genericLength = Fold (\n _ -> n + 1) 0 id
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
list :: Fold a [a]
list = Fold (\x a -> x . (a:)) id ($ [])
maxChunkSize :: Int
maxChunkSize = 8 * 1024 * 1024
vector :: (PrimMonad m, Vector v a) => FoldM m a (v a)
vector = 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.unsafeFreeze mv
return (V.unsafeTake idx v)
purely :: (forall x . (x -> a -> x) -> x -> (x -> b) -> r) -> Fold a b -> r
purely f (Fold step begin done) = f step begin done
impurely
:: Monad m
=> (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
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)
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)
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)
premapM :: Monad m => (a -> b) -> FoldM m b r -> FoldM m a r
premapM f (FoldM step begin done) = FoldM step' begin done
where
step' x a = step x (f a)