-- |
-- Module:       Control.Monad.Freer.NonDet
-- Description:  Non deterministic effects
-- Copyright:    2017 Ixperta Solutions s.r.o.; 2017 Alexis King
-- License:      BSD3
-- Maintainer:   Alexis King <lexi.lambda@gmail.com>
-- Stability:    experimental
-- Portability:  GHC specific language extensions.
--
-- Composable handler for 'NonDet' effects.
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
  )

-- | A handler for nondeterminstic effects.
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)