module Control.Monad.Freer.NonDet
( NonDet(..)
, makeChoiceA
, msplit
) where
import Control.Applicative (Alternative, (<|>), empty)
import Control.Monad (msum)
import Control.Monad.Freer.Internal
( Eff(..)
, Member
, NonDet(..)
, handleRelay
, prj
, qApp
, qComp
, tsingleton
)
makeChoiceA
:: Alternative f
=> Eff (NonDet ': effs) a
-> Eff effs (f a)
makeChoiceA :: Eff (NonDet : effs) a -> Eff effs (f a)
makeChoiceA = (a -> Eff effs (f a))
-> (forall v. NonDet v -> Arr effs v (f a) -> Eff effs (f a))
-> Eff (NonDet : effs) a
-> Eff effs (f a)
forall a (effs :: [* -> *]) b (eff :: * -> *).
(a -> Eff effs b)
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-> Eff (eff : effs) a
-> Eff effs b
handleRelay (f a -> Eff effs (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> Eff effs (f a)) -> (a -> f a) -> a -> Eff effs (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) ((forall v. NonDet v -> Arr effs v (f a) -> Eff effs (f a))
-> Eff (NonDet : effs) a -> Eff effs (f a))
-> (forall v. NonDet v -> Arr effs v (f a) -> Eff effs (f a))
-> Eff (NonDet : effs) a
-> Eff effs (f a)
forall a b. (a -> b) -> a -> b
$ \NonDet v
m Arr effs v (f a)
k ->
case NonDet v
m of
NonDet v
MZero -> f a -> Eff effs (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
forall (f :: * -> *) a. Alternative f => f a
empty
NonDet v
MPlus -> f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (f a -> f a -> f a) -> Eff effs (f a) -> Eff effs (f a -> f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Arr effs v (f a)
k v
Bool
True Eff effs (f a -> f a) -> Eff effs (f a) -> Eff effs (f a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arr effs v (f a)
k v
Bool
False
msplit
:: Member NonDet effs
=> Eff effs a
-> Eff effs (Maybe (a, Eff effs a))
msplit :: Eff effs a -> Eff effs (Maybe (a, Eff effs a))
msplit = [Eff effs a] -> Eff effs a -> Eff effs (Maybe (a, Eff effs a))
forall (effs :: [* -> *]) a.
FindElem NonDet effs =>
[Eff effs a] -> Eff effs a -> Eff effs (Maybe (a, Eff effs a))
loop []
where
loop :: [Eff effs a] -> Eff effs a -> Eff effs (Maybe (a, Eff effs a))
loop [Eff effs a]
jq (Val a
x) = Maybe (a, Eff effs a) -> Eff effs (Maybe (a, Eff effs a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, Eff effs a) -> Maybe (a, Eff effs a)
forall a. a -> Maybe a
Just (a
x, [Eff effs a] -> Eff effs a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [Eff effs a]
jq))
loop [Eff effs a]
jq (E Union effs b
u Arrs effs b a
q) = case Union effs b -> Maybe (NonDet b)
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
Union effs a -> Maybe (eff a)
prj Union effs b
u of
Just NonDet b
MZero -> case [Eff effs a]
jq of
[] -> Maybe (a, Eff effs a) -> Eff effs (Maybe (a, Eff effs a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (a, Eff effs a)
forall a. Maybe a
Nothing
(j:jq') -> [Eff effs a] -> Eff effs a -> Eff effs (Maybe (a, Eff effs a))
loop [Eff effs a]
jq' Eff effs a
j
Just NonDet b
MPlus -> [Eff effs a] -> Eff effs a -> Eff effs (Maybe (a, Eff effs a))
loop (Arrs effs b a -> b -> Eff effs a
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp Arrs effs b a
q b
Bool
False Eff effs a -> [Eff effs a] -> [Eff effs a]
forall a. a -> [a] -> [a]
: [Eff effs a]
jq) (Arrs effs b a -> b -> Eff effs a
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp Arrs effs b a
q b
Bool
True)
Maybe (NonDet b)
Nothing -> Union effs b
-> Arrs effs b (Maybe (a, Eff effs a))
-> Eff effs (Maybe (a, Eff effs a))
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u ((b -> Eff effs (Maybe (a, Eff effs a)))
-> Arrs effs b (Maybe (a, Eff effs a))
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton b -> Eff effs (Maybe (a, Eff effs a))
k)
where
k :: b -> Eff effs (Maybe (a, Eff effs a))
k = Arrs effs b a
-> (Eff effs a -> Eff effs (Maybe (a, Eff effs a)))
-> b
-> Eff effs (Maybe (a, Eff effs a))
forall (effs :: [* -> *]) a b (effs' :: [* -> *]) c.
Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs effs b a
q ([Eff effs a] -> Eff effs a -> Eff effs (Maybe (a, Eff effs a))
loop [Eff effs a]
jq)