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 [a]
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) (\(List xs) k -> fmap concat (mapM k xs))
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
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 (\(List xs) k -> runAll (map k xs)) .
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 fmap (second (x' ++)) (runAll xs)