module Control.Effect.List (
EffectList, List, runList,
choose, never, select,
EffectCut, Cut,
cut, runCut
) where
import Control.Monad.Effect
import Control.Arrow (second)
import Control.Applicative (Alternative (..), (<$>))
import Control.Monad (MonadPlus (..), (<=<), join)
newtype List a = List { unList :: [a] }
deriving Functor
type EffectList = Member List
choose :: EffectList es => [a] -> Effect es a
choose = send . List
never :: EffectList es => Effect es a
never = choose []
select :: EffectList es => [Effect es a] -> Effect es a
select = join . choose
runList :: Effect (List ': es) a -> Effect es [a]
runList =
handle (\x -> return [x])
$ eliminate (fmap concat . sequence . unList)
$ defaultRelay
instance EffectList es => Alternative (Effect es) where
empty = never
x <|> y = select [x, y]
instance EffectList es => MonadPlus (Effect es) where
mzero = empty
mplus = (<|>)
data Cut a = Cut
deriving Functor
type EffectCut = Member Cut
cut :: (EffectList es, EffectCut es) => Effect es a
cut = send Cut
runCut :: EffectList es => Effect (Cut ': es) a -> Effect es a
runCut = choose . snd <=< reifyCut
where
reifyCut :: EffectList es => Effect (Cut ': es) a -> Effect es (Bool, [a])
reifyCut =
handle (\x -> return (False, [x]))
$ eliminate (\Cut -> return (True, []))
$ intercept (\(List xs) -> runAll xs)
$ defaultRelay
runAll [] = return (False, [])
runAll (x:xs) = do
(cutRequested, x') <- x
if cutRequested
then return (True, x')
else second (x' ++) <$> runAll xs