{-# LANGUAGE DeriveAnyClass  #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Description: Interpreters for 'NonDet'
module Polysemy.NonDet
  ( -- * Effect
    NonDet (..)

    -- * Interpretations
  , runNonDet
  , runNonDetMaybe
  , nonDetToError
  ) where

import Control.Applicative
import Control.Monad.Trans.Maybe
import Data.Maybe

import Polysemy
import Polysemy.Error
import Polysemy.Internal
import Polysemy.Internal.NonDet
import Polysemy.Internal.Union

------------------------------------------------------------------------------
-- | Run a 'NonDet' effect in terms of some underlying 'Alternative' @f@.
runNonDet :: Alternative f => Sem (NonDet ': r) a -> Sem r (f a)
runNonDet :: forall (f :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Alternative f =>
Sem (NonDet : r) a -> Sem r (f a)
runNonDet = forall (f :: * -> *) (m :: * -> *) a.
(Alternative f, Applicative m) =>
NonDetC m a -> m (f a)
runNonDetC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: [(* -> *) -> * -> *]) a.
Sem (NonDet : r) a -> NonDetC (Sem r) a
runNonDetInC
{-# INLINE runNonDet #-}

------------------------------------------------------------------------------
-- | Run a 'NonDet' effect in terms of an underlying 'Maybe'
--
-- Unlike 'runNonDet', uses of '<|>' will not execute the
-- second branch at all if the first option succeeds.
--
-- @since 1.1.0.0
runNonDetMaybe :: Sem (NonDet ': r) a -> Sem r (Maybe a)
runNonDetMaybe :: forall (r :: [(* -> *) -> * -> *]) a.
Sem (NonDet : r) a -> Sem r (Maybe a)
runNonDetMaybe (Sem forall (m :: * -> *).
Monad m =>
(forall x. Union (NonDet : r) (Sem (NonDet : r)) x -> m x) -> m a
sem) = forall (r :: [(* -> *) -> * -> *]) a.
(forall (m :: * -> *).
 Monad m =>
 (forall x. Union r (Sem r) x -> m x) -> m a)
-> Sem r a
Sem forall a b. (a -> b) -> a -> b
$ \forall x. Union r (Sem r) x -> m x
k -> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
(forall x. Union (NonDet : r) (Sem (NonDet : r)) x -> m x) -> m a
sem forall a b. (a -> b) -> a -> b
$ \Union (NonDet : r) (Sem (NonDet : r)) x
u ->
  case forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (NonDet : r) (Sem (NonDet : r)) x
u of
    Right (Weaving NonDet (Sem rInitial) a
e f ()
s forall x. f (Sem rInitial x) -> Sem (NonDet : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
_) ->
      case NonDet (Sem rInitial) a
e of
        NonDet (Sem rInitial) a
Empty -> forall (f :: * -> *) a. Alternative f => f a
empty
        Choose Sem rInitial a
left Sem rInitial a
right ->
          forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> Sem r a -> m a
usingSem forall x. Union r (Sem r) x -> m x
k forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> x
ex forall a b. (a -> b) -> a -> b
$
              forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (forall (r :: [(* -> *) -> * -> *]) a.
Sem (NonDet : r) a -> Sem r (Maybe a)
runNonDetMaybe (forall x. f (Sem rInitial x) -> Sem (NonDet : r) (f x)
wv (Sem rInitial a
left forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)))
          forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (forall (r :: [(* -> *) -> * -> *]) a.
Sem (NonDet : r) a -> Sem r (Maybe a)
runNonDetMaybe (forall x. f (Sem rInitial x) -> Sem (NonDet : r) (f x)
wv (Sem rInitial a
right forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)))
    Left Union r (Sem (NonDet : r)) x
x -> forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$
      forall x. Union r (Sem r) x -> m x
k forall a b. (a -> b) -> a -> b
$ forall (s :: * -> *) (n :: * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]) a.
(Functor s, Functor n) =>
s ()
-> (forall x. s (m x) -> n (s x))
-> (forall x. s x -> Maybe x)
-> Union r m a
-> Union r n (s a)
weave (forall a. a -> Maybe a
Just ())
          (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall (r :: [(* -> *) -> * -> *]) a.
Sem (NonDet : r) a -> Sem r (Maybe a)
runNonDetMaybe)
          forall a. a -> a
id
          Union r (Sem (NonDet : r)) x
x
{-# INLINE runNonDetMaybe #-}

------------------------------------------------------------------------------
-- | Transform a 'NonDet' effect into an @'Error' e@ effect,
-- through providing an exception that 'empty' may be mapped to.
--
-- This allows '<|>' to handle 'throw's of the @'Error' e@ effect.
--
-- @since 1.1.0.0
nonDetToError :: Member (Error e) r
              => e
              -> Sem (NonDet ': r) a
              -> Sem r a
nonDetToError :: forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
e -> Sem (NonDet : r) a -> Sem r a
nonDetToError (e
e :: e) = forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH forall a b. (a -> b) -> a -> b
$ \case
  NonDet (Sem rInitial) x
Empty -> forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
e -> Sem r a
throw e
e
  Choose Sem rInitial x
left Sem rInitial x
right -> do
    Sem r (f x)
left'  <- forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
e -> Sem (NonDet : r) a -> Sem r a
nonDetToError e
e forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: [(* -> *) -> * -> *]).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial x
left
    Sem r (f x)
right' <- forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
e -> Sem (NonDet : r) a -> Sem r a
nonDetToError e
e forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: [(* -> *) -> * -> *]).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial x
right
    forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (Sem r (f x)
left' forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
`catch` \(e
_ :: e) -> Sem r (f x)
right')
{-# INLINE nonDetToError #-}


--------------------------------------------------------------------------------
-- This stuff is lifted from 'fused-effects'. Thanks guys!
runNonDetC :: (Alternative f, Applicative m) => NonDetC m a -> m (f a)
runNonDetC :: forall (f :: * -> *) (m :: * -> *) a.
(Alternative f, Applicative m) =>
NonDetC m a -> m (f a)
runNonDetC (NonDetC forall b. (a -> m b -> m b) -> m b -> m b
m) = forall b. (a -> m b -> m b) -> m b -> m b
m (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Alternative f => f a
empty)
{-# INLINE runNonDetC #-}


newtype NonDetC m a = NonDetC
  { -- | A higher-order function receiving two parameters: a function to combine
    -- each solution with the rest of the solutions, and an action to run when no
    -- results are produced.
    forall {k} (m :: k -> *) a.
NonDetC m a -> forall (b :: k). (a -> m b -> m b) -> m b -> m b
unNonDetC :: forall b . (a -> m b -> m b) -> m b -> m b
  }
  deriving (forall a b. a -> NonDetC m b -> NonDetC m a
forall a b. (a -> b) -> NonDetC m a -> NonDetC m b
forall k (m :: k -> *) a b. a -> NonDetC m b -> NonDetC m a
forall k (m :: k -> *) 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 a b. a -> NonDetC m b -> NonDetC m a
$c<$ :: forall k (m :: k -> *) a b. a -> NonDetC m b -> NonDetC m a
fmap :: forall a b. (a -> b) -> NonDetC m a -> NonDetC m b
$cfmap :: forall k (m :: k -> *) a b. (a -> b) -> NonDetC m a -> NonDetC m b
Functor)

instance Applicative (NonDetC m) where
  pure :: forall a. a -> NonDetC m a
pure a
a = forall {k} (m :: k -> *) a.
(forall (b :: k). (a -> m b -> m b) -> m b -> m b) -> NonDetC m a
NonDetC (\ a -> m b -> m b
cons -> a -> m b -> m b
cons a
a)
  {-# INLINE pure #-}

  NonDetC forall (b :: k). ((a -> b) -> m b -> m b) -> m b -> m b
f <*> :: forall a b. NonDetC m (a -> b) -> NonDetC m a -> NonDetC m b
<*> NonDetC forall (b :: k). (a -> m b -> m b) -> m b -> m b
a = forall {k} (m :: k -> *) a.
(forall (b :: k). (a -> m b -> m b) -> m b -> m b) -> NonDetC m a
NonDetC forall a b. (a -> b) -> a -> b
$ \ b -> m b -> m b
cons ->
    forall (b :: k). ((a -> b) -> m b -> m b) -> m b -> m b
f (\ a -> b
f' -> forall (b :: k). (a -> m b -> m b) -> m b -> m b
a (b -> m b -> m b
cons forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f'))
  {-# INLINE (<*>) #-}

instance Alternative (NonDetC m) where
  empty :: forall a. NonDetC m a
empty = forall {k} (m :: k -> *) a.
(forall (b :: k). (a -> m b -> m b) -> m b -> m b) -> NonDetC m a
NonDetC (\ a -> m b -> m b
_ m b
nil -> m b
nil)
  {-# INLINE empty #-}

  NonDetC forall (b :: k). (a -> m b -> m b) -> m b -> m b
l <|> :: forall a. NonDetC m a -> NonDetC m a -> NonDetC m a
<|> NonDetC forall (b :: k). (a -> m b -> m b) -> m b -> m b
r = forall {k} (m :: k -> *) a.
(forall (b :: k). (a -> m b -> m b) -> m b -> m b) -> NonDetC m a
NonDetC forall a b. (a -> b) -> a -> b
$ \ a -> m b -> m b
cons -> forall (b :: k). (a -> m b -> m b) -> m b -> m b
l a -> m b -> m b
cons forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: k). (a -> m b -> m b) -> m b -> m b
r a -> m b -> m b
cons
  {-# INLINE (<|>) #-}

instance Monad (NonDetC m) where
  NonDetC forall (b :: k). (a -> m b -> m b) -> m b -> m b
a >>= :: forall a b. NonDetC m a -> (a -> NonDetC m b) -> NonDetC m b
>>= a -> NonDetC m b
f = forall {k} (m :: k -> *) a.
(forall (b :: k). (a -> m b -> m b) -> m b -> m b) -> NonDetC m a
NonDetC forall a b. (a -> b) -> a -> b
$ \ b -> m b -> m b
cons ->
    forall (b :: k). (a -> m b -> m b) -> m b -> m b
a (\ a
a' -> forall {k} (m :: k -> *) a.
NonDetC m a -> forall (b :: k). (a -> m b -> m b) -> m b -> m b
unNonDetC (a -> NonDetC m b
f a
a') b -> m b -> m b
cons)
  {-# INLINE (>>=) #-}

runNonDetInC :: Sem (NonDet ': r) a -> NonDetC (Sem r) a
runNonDetInC :: forall (r :: [(* -> *) -> * -> *]) a.
Sem (NonDet : r) a -> NonDetC (Sem r) a
runNonDetInC = forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> Sem r a -> m a
usingSem forall a b. (a -> b) -> a -> b
$ \Union (NonDet : r) (Sem (NonDet : r)) x
u ->
  case forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (NonDet : r) (Sem (NonDet : r)) x
u of
    Left Union r (Sem (NonDet : r)) x
x  -> forall {k} (m :: k -> *) a.
(forall (b :: k). (a -> m b -> m b) -> m b -> m b) -> NonDetC m a
NonDetC forall a b. (a -> b) -> a -> b
$ \x -> Sem r b -> Sem r b
c Sem r b
b -> do
      [x]
l <- forall (r :: [(* -> *) -> * -> *]) a. Union r (Sem r) a -> Sem r a
liftSem forall a b. (a -> b) -> a -> b
$ forall (s :: * -> *) (n :: * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]) a.
(Functor s, Functor n) =>
s ()
-> (forall x. s (m x) -> n (s x))
-> (forall x. s x -> Maybe x)
-> Union r m a
-> Union r n (s a)
weave [()]
                  -- KingoftheHomeless: This is NOT the right semantics, but
                  -- the known alternatives are worse. See Issue #246.
                  (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (f :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Alternative f =>
Sem (NonDet : r) a -> Sem r (f a)
runNonDet)
                  forall a. [a] -> Maybe a
listToMaybe
                  Union r (Sem (NonDet : r)) x
x
      forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr x -> Sem r b -> Sem r b
c Sem r b
b [x]
l
    Right (Weaving NonDet (Sem rInitial) a
Empty f ()
_ forall x. f (Sem rInitial x) -> Sem (NonDet : r) (f x)
_ f a -> x
_ forall x. f x -> Maybe x
_) -> forall (f :: * -> *) a. Alternative f => f a
empty
    Right (Weaving (Choose Sem rInitial a
left Sem rInitial a
right) f ()
s forall x. f (Sem rInitial x) -> Sem (NonDet : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
_) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> x
ex forall a b. (a -> b) -> a -> b
$
      forall (r :: [(* -> *) -> * -> *]) a.
Sem (NonDet : r) a -> NonDetC (Sem r) a
runNonDetInC (forall x. f (Sem rInitial x) -> Sem (NonDet : r) (f x)
wv (Sem rInitial a
left forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (r :: [(* -> *) -> * -> *]) a.
Sem (NonDet : r) a -> NonDetC (Sem r) a
runNonDetInC (forall x. f (Sem rInitial x) -> Sem (NonDet : r) (f x)
wv (Sem rInitial a
right forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
{-# INLINE runNonDetInC #-}