module Control.Effect.List (
EffectList, List, runList,
choose, never, select,
CutEffect, Cut, runCut,
cut, cutFalse
) 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 instance Is List f = IsList f
type family IsList f where
IsList List = True
IsList f = False
class Member List l => EffectList l
instance Member List l => EffectList l
choose :: EffectList l => [a] -> Effect l a
choose = send . List
never :: EffectList l => Effect l a
never = choose []
select :: EffectList l => [Effect l a] -> Effect l a
select = join . choose
runList :: Effect (List :+ l) a -> Effect l [a]
runList = eliminate (return . return) (fmap concat . sequence . unList)
instance EffectList l => Alternative (Effect l) where
empty = never
x <|> y = select [x, y]
instance EffectList l => MonadPlus (Effect l) where
mzero = empty
mplus = (<|>)
data Cut a = CutFalse
deriving Functor
class (EffectList l, Member Cut l) => CutEffect l
instance (EffectList l, Member Cut l) => CutEffect l
cut :: CutEffect l => Effect l ()
cut = return () <|> cutFalse
cutFalse :: CutEffect l => Effect l a
cutFalse = send CutFalse
runCut :: EffectList l => Effect (Cut :+ l) a -> Effect l a
runCut = choose . snd <=< reifyCut
where
reifyCut :: EffectList l => Effect (Cut :+ l) a -> Effect l (Bool, [a])
reifyCut =
intercept return (runAll . unList) .
eliminate
(\x -> return (False, [x]))
(\CutFalse -> return (True, []))
runAll [] = return (False, [])
runAll (x:xs) = do
(cutRequested, x') <- x
if cutRequested
then return (True, x')
else second (x' ++) <$> runAll xs