module Control.Foldl
(
Fold(..)
, fold
, FoldM(..)
, foldM
, mconcat
, foldMap
, head
, last
, null
, length
, and
, or
, all
, any
, sum
, product
, maximum
, minimum
, elem
, notElem
, find
, index
, elemIndex
, findIndex
, genericLength
, genericIndex
) where
import Control.Applicative (Applicative(pure, (<*>)))
import Data.Monoid (Monoid(mempty, mappend))
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)
fold :: Fold a b -> [a] -> b
fold (Fold step begin done) as = done (foldr step' id as begin)
where
step' x k z = k $! step z x
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
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
foldM :: (Monad m) => FoldM m a b -> [a] -> m b
foldM (FoldM step begin done) as0 = do
x <- begin
loop as0 $! x
where
loop [] x = done x
loop (a:as) x = do
x' <- step x a
loop as $! x'
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
data Maybe' a = Just' !a | Nothing'
lazy :: Maybe' a -> Maybe a
lazy Nothing' = Nothing
lazy (Just' a') = Just a'
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
data Either' a b = Left' !a | Right' !b
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 (Pair 0 False) done
where
step x@(Pair i b) a =
if b then x
else if (predicate a) then Pair i True
else Pair (i + 1) False
done (Pair i b) = if b then Just i else Nothing
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