{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}

-- SPDX-License-Identifier: MPL-2.0

{- |
Copyright   : (c) 2024-2025 Sayo contributors
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp

Effects that realize non-deterministic computations.
-}
module Data.Effect.NonDet (
    module Data.Effect.NonDet,
    Empty (..),
    Choose (..),
    ChooseH (..),
)
where

#if ( __GLASGOW_HASKELL__ < 906 )
import Control.Applicative (liftA2)
#endif
import Control.Applicative ((<|>))
import Control.Effect.Interpret (interprets)
import Control.Exception (Exception, SomeException)
import Data.Bool (bool)
import Data.Effect (Choose (Choose), ChooseH (ChooseH), Emb, Empty (Empty), UnliftIO)
import Data.Effect.OpenUnion (nil, (!:))
import Data.Effect.Shift (Shift, abort, shift)
import UnliftIO (throwIO, try)

makeEffectF_' (def & noGenerateLabel & noGenerateOrderInstance) ''Empty
makeEffectF_' (def & noGenerateLabel & noGenerateOrderInstance) ''Choose
makeEffectH_' (def & noGenerateLabel & noGenerateOrderInstance) ''ChooseH

{- | t'ChooseH' effect elaborator.

    Convert a higher-order effect of the form

        @chooseH :: m a -> m a -> m a@

    into a first-order effect of the form:

        @choose :: m Bool@
-}
runChooseH
    :: forall es a ff c
     . (Choose :> es, Monad (Eff ff es), Free c ff)
    => Eff ff (ChooseH ': es) a
    -> Eff ff es a
runChooseH :: forall (es :: [Effect]) a (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Choose :> es, Monad (Eff ff es), Free c ff) =>
Eff ff (ChooseH : es) a -> Eff ff es a
runChooseH = (ChooseH ~~> Eff ff es) -> Eff ff (ChooseH : es) a -> Eff ff es a
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownOrder e, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff (e : es) a -> Eff ff es a
interpret \(ChooseH Eff ff es x
a Eff ff es x
b) -> Eff ff es x -> Eff ff es x -> Eff ff es x
forall (es :: [Effect]) a (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Choose :> es, Monad (Eff ff es), Free c ff) =>
Eff ff es a -> Eff ff es a -> Eff ff es a
branch Eff ff es x
a Eff ff es x
b
{-# INLINE runChooseH #-}

-- | Faster than `<|>`.
branch :: forall es a ff c. (Choose :> es, Monad (Eff ff es), Free c ff) => Eff ff es a -> Eff ff es a -> Eff ff es a
branch :: forall (es :: [Effect]) a (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Choose :> es, Monad (Eff ff es), Free c ff) =>
Eff ff es a -> Eff ff es a -> Eff ff es a
branch Eff ff es a
a Eff ff es a
b = do
    Bool
world <- Eff ff es Bool
forall (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, Choose :> es) =>
a Bool
choose
    Eff ff es a -> Eff ff es a -> Bool -> Eff ff es a
forall a. a -> a -> Bool -> a
bool Eff ff es a
a Eff ff es a
b Bool
world
{-# INLINE branch #-}

infixl 3 `branch`

-- | Selects one element from the list nondeterministically, branching the control as many times as the number of elements.
choice :: forall es a ff c. (Choose :> es, Empty :> es, Monad (Eff ff es), Free c ff) => [a] -> Eff ff es a
choice :: forall (es :: [Effect]) a (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Choose :> es, Empty :> es, Monad (Eff ff es), Free c ff) =>
[a] -> Eff ff es a
choice = \case
    [] -> Eff ff es a
forall b (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, Empty :> es) =>
a b
empty
    a
x : [a]
xs -> a -> Eff ff es a
forall a. a -> Eff ff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x Eff ff es a -> Eff ff es a -> Eff ff es a
forall (es :: [Effect]) a (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Choose :> es, Monad (Eff ff es), Free c ff) =>
Eff ff es a -> Eff ff es a -> Eff ff es a
`branch` [a] -> Eff ff es a
forall (es :: [Effect]) a (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Choose :> es, Empty :> es, Monad (Eff ff es), Free c ff) =>
[a] -> Eff ff es a
choice [a]
xs
{-# INLINE choice #-}

-- | Selects one element from the list nondeterministically, branching the control as many times as the number of elements. Uses t'ChooseH'.
choiceH :: forall es a ff c. (ChooseH :> es, Empty :> es, Monad (Eff ff es), Free c ff) => [a] -> Eff ff es a
choiceH :: forall (es :: [Effect]) a (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(ChooseH :> es, Empty :> es, Monad (Eff ff es), Free c ff) =>
[a] -> Eff ff es a
choiceH = \case
    [] -> Eff ff es a
forall b (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, Empty :> es) =>
a b
empty
    a
x : [a]
xs -> a -> Eff ff es a
forall a. a -> Eff ff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x Eff ff es a -> Eff ff es a -> Eff ff es a
forall a. Eff ff es a -> Eff ff es a -> Eff ff es a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> Eff ff es a
forall (es :: [Effect]) a (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(ChooseH :> es, Empty :> es, Monad (Eff ff es), Free c ff) =>
[a] -> Eff ff es a
choiceH [a]
xs
{-# INLINE choiceH #-}

runNonDetShift
    :: forall ans a es ref ff c
     . (Monoid ans, Shift ans ref :> es, forall f. Monad (ff f), Free c ff)
    => Eff ff (Choose ': Empty ': es) a
    -> Eff ff es a
runNonDetShift :: forall ans a (es :: [Effect]) (ref :: * -> *) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Monoid ans, Shift ans ref :> es,
 forall (f :: * -> *). Monad (ff f), Free c ff) =>
Eff ff (Choose : Empty : es) a -> Eff ff es a
runNonDetShift =
    (Union '[Choose, Empty] ~~> Eff ff es)
-> Eff ff ('[Choose, Empty] ++ es) a -> Eff ff es a
forall (es :: [Effect]) (r :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownLength es, Free c ff) =>
(Union es ~~> Eff ff r) -> Eff ff (es ++ r) a -> Eff ff r a
interprets ((Union '[Choose, Empty] ~~> Eff ff es)
 -> Eff ff ('[Choose, Empty] ++ es) a -> Eff ff es a)
-> (Union '[Choose, Empty] ~~> Eff ff es)
-> Eff ff ('[Choose, Empty] ++ es) a
-> Eff ff es a
forall a b. (a -> b) -> a -> b
$
        (\Choose (Eff ff es) x
Choose -> ((x -> Eff ff es ans) -> Eff ff es ans) -> Eff ff es x
forall a (es :: [Effect]) ans (ref :: * -> *) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Shift ans ref :> es, Monad (Eff ff es), Free c ff) =>
((a -> Eff ff es ans) -> Eff ff es ans) -> Eff ff es a
shift \x -> Eff ff es ans
k' -> (ans -> ans -> ans)
-> Eff ff es ans -> Eff ff es ans -> Eff ff es ans
forall a b c.
(a -> b -> c) -> Eff ff es a -> Eff ff es b -> Eff ff es c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ans -> ans -> ans
forall a. Semigroup a => a -> a -> a
(<>) (x -> Eff ff es ans
k' x
Bool
False) (x -> Eff ff es ans
k' x
Bool
True))
            (Choose (Eff ff es) x -> Eff ff es x)
-> (Union '[Empty] (Eff ff es) x -> Eff ff es x)
-> Union '[Choose, Empty] (Eff ff es) x
-> Eff ff es x
forall (f :: * -> *) a r (es :: [Effect]).
(Choose f a -> r)
-> (Union es f a -> r) -> Union (Choose : es) f a -> r
forall (e :: Effect) (order :: EffectOrder) (f :: * -> *) a r
       (es :: [Effect]).
Elem e order =>
(e f a -> r) -> (Union es f a -> r) -> Union (e : es) f a -> r
!: (\Empty (Eff ff es) x
Empty -> ans -> Eff ff es x
forall ans (ref :: * -> *) a (f :: * -> *) (es :: [Effect])
       (ff :: Effect) (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Shift ans ref :> es) =>
ans -> f a
abort ans
forall a. Monoid a => a
mempty)
            (Empty (Eff ff es) x -> Eff ff es x)
-> (Union '[] (Eff ff es) x -> Eff ff es x)
-> Union '[Empty] (Eff ff es) x
-> Eff ff es x
forall (f :: * -> *) a r (es :: [Effect]).
(Empty f a -> r)
-> (Union es f a -> r) -> Union (Empty : es) f a -> r
forall (e :: Effect) (order :: EffectOrder) (f :: * -> *) a r
       (es :: [Effect]).
Elem e order =>
(e f a -> r) -> (Union es f a -> r) -> Union (e : es) f a -> r
!: Union '[] (Eff ff es) x -> Eff ff es x
forall (f :: * -> *) a r. Union '[] f a -> r
nil
{-# INLINE runNonDetShift #-}

{- |
Interprets the [NonDet]("Data.Effect.NonDet") effects using IO-level exceptions.

When 'empty' occurs, an v'EmptyException' is thrown, and unless all branches from
 'chooseH' fail due to IO-level exceptions, only the leftmost result is returned
 as the final result.
-}
runNonDetIO
    :: forall es a ff c
     . (UnliftIO :> es, Emb IO :> es, forall f. Monad (Eff ff f), Free c ff)
    => Eff ff (ChooseH ': Empty ': es) a
    -> Eff ff es (Either SomeException a)
runNonDetIO :: forall (es :: [Effect]) a (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(UnliftIO :> es, Emb IO :> es,
 forall (f :: [Effect]). Monad (Eff ff f), Free c ff) =>
Eff ff (ChooseH : Empty : es) a
-> Eff ff es (Either SomeException a)
runNonDetIO Eff ff (ChooseH : Empty : es) a
m = Eff ff es a -> Eff ff es (Either SomeException a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try do
    let hdl :: Union '[ChooseH, Empty] (Eff ff es) b -> Eff ff es b
hdl =
            ( \(ChooseH Eff ff es b
a Eff ff es b
b) ->
                Eff ff es b -> Eff ff es (Either SomeException b)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try Eff ff es b
a Eff ff es (Either SomeException b)
-> (Either SomeException b -> Eff ff es b) -> Eff ff es b
forall a b. Eff ff es a -> (a -> Eff ff es b) -> Eff ff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Right b
x -> b -> Eff ff es b
forall a. a -> Eff ff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x
                    Left (SomeException
_ :: SomeException) -> Eff ff es b
b
            )
                (ChooseH (Eff ff es) b -> Eff ff es b)
-> (Union '[Empty] (Eff ff es) b -> Eff ff es b)
-> Union '[ChooseH, Empty] (Eff ff es) b
-> Eff ff es b
forall (f :: * -> *) a r (es :: [Effect]).
(ChooseH f a -> r)
-> (Union es f a -> r) -> Union (ChooseH : es) f a -> r
forall (e :: Effect) (order :: EffectOrder) (f :: * -> *) a r
       (es :: [Effect]).
Elem e order =>
(e f a -> r) -> (Union es f a -> r) -> Union (e : es) f a -> r
!: (\Empty (Eff ff es) b
Empty -> EmptyException -> Eff ff es b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO EmptyException
EmptyException)
                (Empty (Eff ff es) b -> Eff ff es b)
-> (Union '[] (Eff ff es) b -> Eff ff es b)
-> Union '[Empty] (Eff ff es) b
-> Eff ff es b
forall (f :: * -> *) a r (es :: [Effect]).
(Empty f a -> r)
-> (Union es f a -> r) -> Union (Empty : es) f a -> r
forall (e :: Effect) (order :: EffectOrder) (f :: * -> *) a r
       (es :: [Effect]).
Elem e order =>
(e f a -> r) -> (Union es f a -> r) -> Union (e : es) f a -> r
!: Union '[] (Eff ff es) b -> Eff ff es b
forall (f :: * -> *) a r. Union '[] f a -> r
nil
     in (Union '[ChooseH, Empty] ~~> Eff ff es)
-> Eff ff ('[ChooseH, Empty] ++ es) a -> Eff ff es a
forall (es :: [Effect]) (r :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownLength es, Free c ff) =>
(Union es ~~> Eff ff r) -> Eff ff (es ++ r) a -> Eff ff r a
interprets Union '[ChooseH, Empty] (Eff ff es) x -> Eff ff es x
Union '[ChooseH, Empty] ~~> Eff ff es
hdl Eff ff (ChooseH : Empty : es) a
Eff ff ('[ChooseH, Empty] ++ es) a
m
{-# INLINE runNonDetIO #-}

-- | Exception thrown when 'empty' occurs in 'runNonDetIO'.
data EmptyException = EmptyException
    deriving stock (Int -> EmptyException -> ShowS
[EmptyException] -> ShowS
EmptyException -> String
(Int -> EmptyException -> ShowS)
-> (EmptyException -> String)
-> ([EmptyException] -> ShowS)
-> Show EmptyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EmptyException -> ShowS
showsPrec :: Int -> EmptyException -> ShowS
$cshow :: EmptyException -> String
show :: EmptyException -> String
$cshowList :: [EmptyException] -> ShowS
showList :: [EmptyException] -> ShowS
Show)
    deriving anyclass (Show EmptyException
Typeable EmptyException
(Typeable EmptyException, Show EmptyException) =>
(EmptyException -> SomeException)
-> (SomeException -> Maybe EmptyException)
-> (EmptyException -> String)
-> Exception EmptyException
SomeException -> Maybe EmptyException
EmptyException -> String
EmptyException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: EmptyException -> SomeException
toException :: EmptyException -> SomeException
$cfromException :: SomeException -> Maybe EmptyException
fromException :: SomeException -> Maybe EmptyException
$cdisplayException :: EmptyException -> String
displayException :: EmptyException -> String
Exception)