module Control.Monad.Eff.NdetEff (
NdetEff,
makeChoiceA,
msplit,
unmsplit,
ifte,
once
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Internal
import Data.OpenUnion
import Data.FTCQueue
data NdetEff a where
MZero :: NdetEff a
MPlus :: NdetEff Bool
instance Member NdetEff r => Alternative (Eff r) where
empty = mzero
(<|>) = mplus
instance Member NdetEff r => MonadPlus (Eff r) where
mzero = send MZero
mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2
makeChoiceA :: Alternative f => Eff (NdetEff ': r) a -> Eff r (f a)
makeChoiceA = handleRelay ret handle
ret :: Alternative f => a -> Eff r (f a)
ret = return . pure
handle :: Alternative f => Handler NdetEff r (f a)
handle MZero k = return empty
handle MPlus k = liftM2 (<|>) (k True) (k False)
makeChoiceA' :: Alternative f => Eff (NdetEff ': r) a -> Eff r (f a)
makeChoiceA' m = loop [] m
where
loop [] (Pure x) = return (pure x)
loop (h:t) (Pure x) = loop t h >>= \r -> return (pure x <|> r)
loop jq (Impure u q) = case decomp u of
Right MZero -> case jq of
[] -> return empty
(h:t) -> loop t h
Right MPlus -> loop (qApp q False : jq) (qApp q True)
Left u -> Impure u (tsingleton (\x -> loop jq (qApp q x)))
msplit :: Member NdetEff r => Eff r a -> Eff r (Maybe (a, Eff r a))
msplit = loop []
where
loop [] (Pure x) = return (Just (x,mzero))
loop jq (Pure x) = return (Just (x, msum jq))
loop jq (Impure u q) = case prj u of
Just MZero -> case jq of
[] -> return Nothing
(j:jq) -> loop jq j
Just MPlus -> loop ((qApp q False):jq) (qApp q True)
_ -> Impure u (qComps q (loop jq))
ifte :: Member NdetEff r => Eff r a -> (a -> Eff r b) -> Eff r b -> Eff r b
ifte t th el = msplit t >>= check
where check Nothing = el
check (Just (sg1,sg2)) = (th sg1) `mplus` (sg2 >>= th)
once :: Member NdetEff r => Eff r a -> Eff r a
once m = msplit m >>= check
where check Nothing = mzero
check (Just (sg1,_)) = return sg1
unmsplit :: Member NdetEff r => (Maybe (a, Eff r a)) -> Eff r a
unmsplit Nothing = mzero
unmsplit (Just (a,m)) = return a `mplus` m