{-# LANGUAGE DeriveTraversable, FlexibleInstances, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-}
module Control.Carrier.NonDet.Church
(
runNonDet
, runNonDetA
, runNonDetM
, NonDetC(..)
, module Control.Effect.NonDet
) where
import Control.Algebra
import Control.Applicative (liftA2)
import Control.Effect.NonDet
import qualified Control.Monad.Fail as Fail
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.Coerce (coerce)
import Data.Functor.Identity
runNonDet
:: (m b -> m b -> m b)
-> (a -> m b)
-> m b
-> NonDetC m a
-> m b
runNonDet :: (m b -> m b -> m b) -> (a -> m b) -> m b -> NonDetC m a -> m b
runNonDet fork :: m b -> m b -> m b
fork leaf :: a -> m b
leaf nil :: m b
nil (NonDetC m :: forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
m) = (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
m m b -> m b -> m b
fork a -> m b
leaf m b
nil
runNonDetA :: (Alternative f, Applicative m) => NonDetC m a -> m (f a)
runNonDetA :: NonDetC m a -> m (f a)
runNonDetA = (m (f a) -> m (f a) -> m (f a))
-> (a -> m (f a)) -> m (f a) -> NonDetC m a -> m (f a)
forall (m :: * -> *) b a.
(m b -> m b -> m b) -> (a -> m b) -> m b -> NonDetC m a -> m b
runNonDet ((f a -> f a -> f a) -> m (f a) -> m (f a) -> m (f a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)) (f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> m (f a)) -> (a -> f a) -> a -> m (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
forall (f :: * -> *) a. Alternative f => f a
empty)
runNonDetM :: (Applicative m, Monoid b) => (a -> b) -> NonDetC m a -> m b
runNonDetM :: (a -> b) -> NonDetC m a -> m b
runNonDetM leaf :: a -> b
leaf = (m b -> m b -> m b) -> (a -> m b) -> m b -> NonDetC m a -> m b
forall (m :: * -> *) b a.
(m b -> m b -> m b) -> (a -> m b) -> m b -> NonDetC m a -> m b
runNonDet ((b -> b -> b) -> m b -> m b -> m b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> b -> b
forall a. Monoid a => a -> a -> a
mappend) (b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> m b) -> (a -> b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
leaf) (b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
forall a. Monoid a => a
mempty)
newtype NonDetC m a = NonDetC (forall b . (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
deriving (a -> NonDetC m b -> NonDetC m a
(a -> b) -> NonDetC m a -> NonDetC m b
(forall a b. (a -> b) -> NonDetC m a -> NonDetC m b)
-> (forall a b. a -> NonDetC m b -> NonDetC m a)
-> Functor (NonDetC m)
forall a b. a -> NonDetC m b -> NonDetC m a
forall a b. (a -> b) -> NonDetC m a -> NonDetC m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) a b. a -> NonDetC m b -> NonDetC m a
forall (m :: * -> *) a b. (a -> b) -> NonDetC m a -> NonDetC m b
<$ :: a -> NonDetC m b -> NonDetC m a
$c<$ :: forall (m :: * -> *) a b. a -> NonDetC m b -> NonDetC m a
fmap :: (a -> b) -> NonDetC m a -> NonDetC m b
$cfmap :: forall (m :: * -> *) a b. (a -> b) -> NonDetC m a -> NonDetC m b
Functor)
instance Applicative (NonDetC m) where
pure :: a -> NonDetC m a
pure a :: a
a = (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
NonDetC (\ _ leaf :: a -> m b
leaf _ -> a -> m b
leaf a
a)
{-# INLINE pure #-}
NonDetC f :: forall b. (m b -> m b -> m b) -> ((a -> b) -> m b) -> m b -> m b
f <*> :: NonDetC m (a -> b) -> NonDetC m a -> NonDetC m b
<*> NonDetC a :: forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
a = (forall b. (m b -> m b -> m b) -> (b -> m b) -> m b -> m b)
-> NonDetC m b
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
NonDetC ((forall b. (m b -> m b -> m b) -> (b -> m b) -> m b -> m b)
-> NonDetC m b)
-> (forall b. (m b -> m b -> m b) -> (b -> m b) -> m b -> m b)
-> NonDetC m b
forall a b. (a -> b) -> a -> b
$ \ fork :: m b -> m b -> m b
fork leaf :: b -> m b
leaf nil :: m b
nil ->
(m b -> m b -> m b) -> ((a -> b) -> m b) -> m b -> m b
forall b. (m b -> m b -> m b) -> ((a -> b) -> m b) -> m b -> m b
f m b -> m b -> m b
fork (\ f' :: a -> b
f' -> (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
a m b -> m b -> m b
fork (b -> m b
leaf (b -> m b) -> (a -> b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f') m b
nil) m b
nil
{-# INLINE (<*>) #-}
instance Alternative (NonDetC m) where
empty :: NonDetC m a
empty = (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
NonDetC (\ _ _ nil :: m b
nil -> m b
nil)
{-# INLINE empty #-}
NonDetC l :: forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
l <|> :: NonDetC m a -> NonDetC m a -> NonDetC m a
<|> NonDetC r :: forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
r = (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
NonDetC ((forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a)
-> (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
forall a b. (a -> b) -> a -> b
$ \ fork :: m b -> m b -> m b
fork leaf :: a -> m b
leaf nil :: m b
nil -> m b -> m b -> m b
fork ((m b -> m b -> m b) -> (a -> m b) -> m b -> m b
forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
l m b -> m b -> m b
fork a -> m b
leaf m b
nil) ((m b -> m b -> m b) -> (a -> m b) -> m b -> m b
forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
r m b -> m b -> m b
fork a -> m b
leaf m b
nil)
{-# INLINE (<|>) #-}
instance Monad (NonDetC m) where
NonDetC a :: forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
a >>= :: NonDetC m a -> (a -> NonDetC m b) -> NonDetC m b
>>= f :: a -> NonDetC m b
f = (forall b. (m b -> m b -> m b) -> (b -> m b) -> m b -> m b)
-> NonDetC m b
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
NonDetC ((forall b. (m b -> m b -> m b) -> (b -> m b) -> m b -> m b)
-> NonDetC m b)
-> (forall b. (m b -> m b -> m b) -> (b -> m b) -> m b -> m b)
-> NonDetC m b
forall a b. (a -> b) -> a -> b
$ \ fork :: m b -> m b -> m b
fork leaf :: b -> m b
leaf nil :: m b
nil ->
(m b -> m b -> m b) -> (a -> m b) -> m b -> m b
forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
a m b -> m b -> m b
fork ((m b -> m b -> m b) -> (b -> m b) -> m b -> NonDetC m b -> m b
forall (m :: * -> *) b a.
(m b -> m b -> m b) -> (a -> m b) -> m b -> NonDetC m a -> m b
runNonDet m b -> m b -> m b
fork b -> m b
leaf m b
nil (NonDetC m b -> m b) -> (a -> NonDetC m b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NonDetC m b
f) m b
nil
{-# INLINE (>>=) #-}
instance Fail.MonadFail m => Fail.MonadFail (NonDetC m) where
fail :: String -> NonDetC m a
fail s :: String
s = m a -> NonDetC m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
s)
{-# INLINE fail #-}
instance MonadFix m => MonadFix (NonDetC m) where
mfix :: (a -> NonDetC m a) -> NonDetC m a
mfix f :: a -> NonDetC m a
f = (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
NonDetC ((forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a)
-> (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
forall a b. (a -> b) -> a -> b
$ \ fork :: m b -> m b -> m b
fork leaf :: a -> m b
leaf nil :: m b
nil ->
([a] -> m [a]) -> m [a]
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (NonDetC m a -> m [a]
forall (f :: * -> *) (m :: * -> *) a.
(Alternative f, Applicative m) =>
NonDetC m a -> m (f a)
runNonDetA (NonDetC m a -> m [a]) -> ([a] -> NonDetC m a) -> [a] -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NonDetC m a
f (a -> NonDetC m a) -> ([a] -> a) -> [a] -> NonDetC m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> a
forall a. [a] -> a
head)
m [a] -> ([a] -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (m b -> m b -> m b) -> (a -> m b) -> m b -> NonDetC m a -> m b
forall (m :: * -> *) b a.
(m b -> m b -> m b) -> (a -> m b) -> m b -> NonDetC m a -> m b
runNonDet m b -> m b -> m b
fork a -> m b
leaf m b
nil (NonDetC m a -> m b) -> ([a] -> NonDetC m a) -> [a] -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> NonDetC m a -> NonDetC m a)
-> NonDetC m a -> [a] -> NonDetC m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\ a :: a
a _ -> a -> NonDetC m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a NonDetC m a -> NonDetC m a -> NonDetC m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> NonDetC m a) -> NonDetC m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (m [a] -> NonDetC m a
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
m (t a) -> NonDetC m a
liftAll (m [a] -> NonDetC m a) -> (a -> m [a]) -> a -> NonDetC m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> [a]
forall a. [a] -> [a]
tail (m [a] -> m [a]) -> (a -> m [a]) -> a -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonDetC m a -> m [a]
forall (f :: * -> *) (m :: * -> *) a.
(Alternative f, Applicative m) =>
NonDetC m a -> m (f a)
runNonDetA (NonDetC m a -> m [a]) -> (a -> NonDetC m a) -> a -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NonDetC m a
f))
NonDetC m a
forall (f :: * -> *) a. Alternative f => f a
empty where
liftAll :: m (t a) -> NonDetC m a
liftAll m :: m (t a)
m = (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
NonDetC ((forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a)
-> (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
forall a b. (a -> b) -> a -> b
$ \ fork :: m b -> m b -> m b
fork leaf :: a -> m b
leaf nil :: m b
nil -> m (t a)
m m (t a) -> (t a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> m b -> m b) -> m b -> t a -> m b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (m b -> m b -> m b
fork (m b -> m b -> m b) -> (a -> m b) -> a -> m b -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
leaf) m b
nil
{-# INLINE mfix #-}
instance MonadIO m => MonadIO (NonDetC m) where
liftIO :: IO a -> NonDetC m a
liftIO io :: IO a
io = m a -> NonDetC m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io)
{-# INLINE liftIO #-}
instance MonadPlus (NonDetC m)
instance MonadTrans NonDetC where
lift :: m a -> NonDetC m a
lift m :: m a
m = (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
NonDetC (\ _ leaf :: a -> m b
leaf _ -> m a
m m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
leaf)
{-# INLINE lift #-}
instance (Algebra sig m, Effect sig) => Algebra (NonDet :+: sig) (NonDetC m) where
alg :: (:+:) NonDet sig (NonDetC m) a -> NonDetC m a
alg (L (L Empty)) = NonDetC m a
forall (f :: * -> *) a. Alternative f => f a
empty
alg (L (R (Choose k :: Bool -> NonDetC m a
k))) = Bool -> NonDetC m a
k Bool
True NonDetC m a -> NonDetC m a -> NonDetC m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> NonDetC m a
k Bool
False
alg (R other :: sig (NonDetC m) a
other) = (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
NonDetC ((forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a)
-> (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b -> m b)
-> NonDetC m a
forall a b. (a -> b) -> a -> b
$ \ fork :: m b -> m b -> m b
fork leaf :: a -> m b
leaf nil :: m b
nil -> sig m (NonDetC Identity a) -> m (NonDetC Identity a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg (NonDetC Identity ()
-> (forall x.
NonDetC Identity (NonDetC m x) -> m (NonDetC Identity x))
-> sig (NonDetC m) a
-> sig m (NonDetC Identity a)
forall (sig :: (* -> *) -> * -> *) (ctx :: * -> *) (m :: * -> *)
(n :: * -> *) a.
(Effect sig, Functor ctx, Monad m) =>
ctx ()
-> (forall x. ctx (m x) -> n (ctx x)) -> sig m a -> sig n (ctx a)
thread (() -> NonDetC Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall x. NonDetC Identity (NonDetC m x) -> m (NonDetC Identity x)
forall (m :: * -> *) a.
Applicative m =>
NonDetC Identity (NonDetC m a) -> m (NonDetC Identity a)
dst sig (NonDetC m) a
other) m (NonDetC Identity a) -> (NonDetC Identity a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Identity (m b) -> m b
forall a. Identity a -> a
runIdentity (Identity (m b) -> m b)
-> (NonDetC Identity a -> Identity (m b))
-> NonDetC Identity a
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity (m b) -> Identity (m b) -> Identity (m b))
-> (a -> Identity (m b))
-> Identity (m b)
-> NonDetC Identity a
-> Identity (m b)
forall (m :: * -> *) b a.
(m b -> m b -> m b) -> (a -> m b) -> m b -> NonDetC m a -> m b
runNonDet ((m b -> m b -> m b)
-> Identity (m b) -> Identity (m b) -> Identity (m b)
forall a b. Coercible a b => a -> b
coerce m b -> m b -> m b
fork) ((a -> m b) -> a -> Identity (m b)
forall a b. Coercible a b => a -> b
coerce a -> m b
leaf) (m b -> Identity (m b)
forall a b. Coercible a b => a -> b
coerce m b
nil) where
dst :: Applicative m => NonDetC Identity (NonDetC m a) -> m (NonDetC Identity a)
dst :: NonDetC Identity (NonDetC m a) -> m (NonDetC Identity a)
dst = Identity (m (NonDetC Identity a)) -> m (NonDetC Identity a)
forall a. Identity a -> a
runIdentity (Identity (m (NonDetC Identity a)) -> m (NonDetC Identity a))
-> (NonDetC Identity (NonDetC m a)
-> Identity (m (NonDetC Identity a)))
-> NonDetC Identity (NonDetC m a)
-> m (NonDetC Identity a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity (m (NonDetC Identity a))
-> Identity (m (NonDetC Identity a))
-> Identity (m (NonDetC Identity a)))
-> (NonDetC m a -> Identity (m (NonDetC Identity a)))
-> Identity (m (NonDetC Identity a))
-> NonDetC Identity (NonDetC m a)
-> Identity (m (NonDetC Identity a))
forall (m :: * -> *) b a.
(m b -> m b -> m b) -> (a -> m b) -> m b -> NonDetC m a -> m b
runNonDet ((m (NonDetC Identity a)
-> m (NonDetC Identity a) -> m (NonDetC Identity a))
-> Identity (m (NonDetC Identity a))
-> Identity (m (NonDetC Identity a))
-> Identity (m (NonDetC Identity a))
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((NonDetC Identity a -> NonDetC Identity a -> NonDetC Identity a)
-> m (NonDetC Identity a)
-> m (NonDetC Identity a)
-> m (NonDetC Identity a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 NonDetC Identity a -> NonDetC Identity a -> NonDetC Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>))) (m (NonDetC Identity a) -> Identity (m (NonDetC Identity a))
forall a. a -> Identity a
Identity (m (NonDetC Identity a) -> Identity (m (NonDetC Identity a)))
-> (NonDetC m a -> m (NonDetC Identity a))
-> NonDetC m a
-> Identity (m (NonDetC Identity a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonDetC m a -> m (NonDetC Identity a)
forall (f :: * -> *) (m :: * -> *) a.
(Alternative f, Applicative m) =>
NonDetC m a -> m (f a)
runNonDetA) (m (NonDetC Identity a) -> Identity (m (NonDetC Identity a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonDetC Identity a -> m (NonDetC Identity a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonDetC Identity a
forall (f :: * -> *) a. Alternative f => f a
empty))
{-# INLINE alg #-}