{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Gather where
import Control.Applicative
import Control.Monad(join)
data Gather g f a =
forall m. (Monoid m) =>
Gather
{ items :: f m
, postProcess :: m -> g a
}
type Gather' f = Gather f f
instance (Functor g, Functor f) => Functor (Gather g f) where
fmap f (Gather items p) = Gather items (fmap (fmap f) p)
instance (Applicative g, Alternative f) => Applicative (Gather g f) where
pure x = Gather (empty :: f ()) (pure (pure x))
Gather ia pa <*> Gather ib pb = Gather ((l <$> ia) <|> (r <$> ib)) (\(ma, mb) -> pa ma <*> pb mb)
where l x = (x, mempty)
r x = (mempty, x)
runGather :: (Alternative f) => Gather g f a -> f (g a)
runGather (Gather i p) = let x = mconcat <$> many i in fmap p x
runGather' :: (Alternative f, Monad f) => Gather' f a -> f a
runGather' = join . runGather
gather :: Monoid m => (m -> g a) -> f m -> Gather g f a
gather p i = Gather i p
zeroOrMore :: (Functor f, Applicative g)
=> f a
-> Gather g f [a]
zeroOrMore item = Gather (fmap (:[]) item) $ pure
zeroOrMore_ :: (Functor f, Applicative g)
=> f a
-> Gather g f ()
zeroOrMore_ item = Gather (fmap mempty item) $ pure
zeroOrOne :: (Functor f, Applicative g)
=> g (Maybe a)
-> f a
-> Gather g f (Maybe a)
zeroOrOne onMany item = Gather (fmap (:[]) item) $
\l -> case l of
[] -> pure Nothing
[a] -> pure (Just a)
_ -> onMany
oneOrMore :: (Functor f, Applicative g)
=> g (a, [a])
-> f a
-> Gather g f (a, [a])
oneOrMore onErr item = Gather (fmap (:[]) item) $
\l -> case l of
[] -> onErr
(a: as) -> pure (a, as)
exactlyOne :: (Functor f, Applicative g)
=> g a
-> g a
-> f a
-> Gather g f a
exactlyOne onNil onMany item = Gather (fmap (:[]) item) $
\l -> case l of
[] -> onNil
[a] -> pure a
_ -> onMany