{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

-- SPDX-License-Identifier: MPL-2.0

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

Interpreters for the [non-determinism]("Data.Effect.NonDet") effects.
-}
module Control.Monad.Hefty.NonDet (
    module Control.Monad.Hefty.NonDet,
    module Data.Effect.NonDet,
)
where

import Control.Applicative (Alternative ((<|>)), (<|>))
#if ( __GLASGOW_HASKELL__ < 906 )
import Control.Applicative (liftA2)
#endif
import Control.Applicative qualified as A
import Control.Arrow ((>>>))
import Control.Monad.Hefty (
    Eff,
    bundleN,
    interpret,
    interpretBy,
    interpretH,
    nil,
    (!+),
    (&),
    type (<<|),
    type (<|),
    type (~>),
 )
import Data.Bool (bool)
import Data.Effect.NonDet
import Data.Effect.Unlift (UnliftIO)
import UnliftIO (Exception, SomeException, throwIO, try)

-- | [NonDet]("Data.Effect.NonDet") effects handler for alternative answer type.
runNonDet
    :: forall f ef a
     . (Alternative f)
    => Eff '[] (Choose ': Empty ': ef) a
    -> Eff '[] ef (f a)
runNonDet :: forall (f :: * -> *) (ef :: [* -> *]) a.
Alternative f =>
Eff '[] (Choose : Empty : ef) a -> Eff '[] ef (f a)
runNonDet =
    forall (len :: Nat) (ef :: [* -> *]) (eh :: [EffectH]).
KnownNat len =>
Eff eh ef ~> Eff eh (Union (Take len ef) : Drop len ef)
bundleN @2
        (Eff '[] (Choose : Empty : ef) a
 -> Eff '[] (Union '[Choose, Empty] : ef) a)
-> (Eff '[] (Union '[Choose, Empty] : ef) a -> Eff '[] ef (f a))
-> Eff '[] (Choose : Empty : ef) a
-> Eff '[] ef (f a)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (a -> Eff '[] ef (f a))
-> Interpreter (Union '[Choose, Empty]) (Eff '[] ef) (f a)
-> Eff '[] (Union '[Choose, Empty] : ef) a
-> Eff '[] ef (f a)
forall (e :: * -> *) (ef :: [* -> *]) ans a.
(a -> Eff '[] ef ans)
-> Interpreter e (Eff '[] ef) ans
-> Eff '[] (e : ef) a
-> Eff '[] ef ans
interpretBy
            (f a -> Eff '[] ef (f a)
forall a. a -> Eff '[] ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> Eff '[] ef (f a)) -> (a -> f a) -> a -> Eff '[] ef (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
            ( (\Choose x
Choose x -> Eff '[] ef (f a)
k -> (f a -> f a -> f a)
-> Eff '[] ef (f a) -> Eff '[] ef (f a) -> Eff '[] ef (f a)
forall a b c.
(a -> b -> c) -> Eff '[] ef a -> Eff '[] ef b -> Eff '[] ef c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f a -> f a -> f a
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (x -> Eff '[] ef (f a)
k x
Bool
False) (x -> Eff '[] ef (f a)
k x
Bool
True))
                (Choose x -> (x -> Eff '[] ef (f a)) -> Eff '[] ef (f a))
-> (Union '[Empty] x
    -> (x -> Eff '[] ef (f a)) -> Eff '[] ef (f a))
-> Union '[Choose, Empty] x
-> (x -> Eff '[] ef (f a))
-> Eff '[] ef (f a)
forall (e :: * -> *) a r (es :: [* -> *]).
(e a -> r) -> (Union es a -> r) -> Union (e : es) a -> r
!+ (\Empty x
Empty x -> Eff '[] ef (f a)
_ -> f a -> Eff '[] ef (f a)
forall a. a -> Eff '[] ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
A.empty)
                (Empty x -> (x -> Eff '[] ef (f a)) -> Eff '[] ef (f a))
-> (Union '[] x -> (x -> Eff '[] ef (f a)) -> Eff '[] ef (f a))
-> Union '[Empty] x
-> (x -> Eff '[] ef (f a))
-> Eff '[] ef (f a)
forall (e :: * -> *) a r (es :: [* -> *]).
(e a -> r) -> (Union es a -> r) -> Union (e : es) a -> r
!+ Union '[] x -> (x -> Eff '[] ef (f a)) -> Eff '[] ef (f a)
forall a r. Union '[] a -> r
nil
            )

-- | [NonDet]("Data.Effect.NonDet") effects handler for monoidal answer type.
runNonDetMonoid
    :: forall ans ef a
     . (Monoid ans)
    => (a -> Eff '[] ef ans)
    -> Eff '[] (Choose ': Empty ': ef) a
    -> Eff '[] ef ans
runNonDetMonoid :: forall ans (ef :: [* -> *]) a.
Monoid ans =>
(a -> Eff '[] ef ans)
-> Eff '[] (Choose : Empty : ef) a -> Eff '[] ef ans
runNonDetMonoid a -> Eff '[] ef ans
f =
    forall (len :: Nat) (ef :: [* -> *]) (eh :: [EffectH]).
KnownNat len =>
Eff eh ef ~> Eff eh (Union (Take len ef) : Drop len ef)
bundleN @2
        (Eff '[] (Choose : Empty : ef) a
 -> Eff '[] (Union '[Choose, Empty] : ef) a)
-> (Eff '[] (Union '[Choose, Empty] : ef) a -> Eff '[] ef ans)
-> Eff '[] (Choose : Empty : ef) a
-> Eff '[] ef ans
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (a -> Eff '[] ef ans)
-> Interpreter (Union '[Choose, Empty]) (Eff '[] ef) ans
-> Eff '[] (Union '[Choose, Empty] : ef) a
-> Eff '[] ef ans
forall (e :: * -> *) (ef :: [* -> *]) ans a.
(a -> Eff '[] ef ans)
-> Interpreter e (Eff '[] ef) ans
-> Eff '[] (e : ef) a
-> Eff '[] ef ans
interpretBy
            a -> Eff '[] ef ans
f
            ( (\Choose x
Choose x -> Eff '[] ef ans
k -> (ans -> ans -> ans)
-> Eff '[] ef ans -> Eff '[] ef ans -> Eff '[] ef ans
forall a b c.
(a -> b -> c) -> Eff '[] ef a -> Eff '[] ef b -> Eff '[] ef 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 '[] ef ans
k x
Bool
False) (x -> Eff '[] ef ans
k x
Bool
True))
                (Choose x -> (x -> Eff '[] ef ans) -> Eff '[] ef ans)
-> (Union '[Empty] x -> (x -> Eff '[] ef ans) -> Eff '[] ef ans)
-> Union '[Choose, Empty] x
-> (x -> Eff '[] ef ans)
-> Eff '[] ef ans
forall (e :: * -> *) a r (es :: [* -> *]).
(e a -> r) -> (Union es a -> r) -> Union (e : es) a -> r
!+ (\Empty x
Empty x -> Eff '[] ef ans
_ -> ans -> Eff '[] ef ans
forall a. a -> Eff '[] ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ans
forall a. Monoid a => a
mempty)
                (Empty x -> (x -> Eff '[] ef ans) -> Eff '[] ef ans)
-> (Union '[] x -> (x -> Eff '[] ef ans) -> Eff '[] ef ans)
-> Union '[Empty] x
-> (x -> Eff '[] ef ans)
-> Eff '[] ef ans
forall (e :: * -> *) a r (es :: [* -> *]).
(e a -> r) -> (Union es a -> r) -> Union (e : es) a -> r
!+ Union '[] x -> (x -> Eff '[] ef ans) -> Eff '[] ef ans
forall a r. Union '[] a -> r
nil
            )

-- | t'Choose' effect handler for alternative answer type.
runChoose
    :: forall f ef a
     . (Alternative f)
    => Eff '[] (Choose ': ef) a
    -> Eff '[] ef (f a)
runChoose :: forall (f :: * -> *) (ef :: [* -> *]) a.
Alternative f =>
Eff '[] (Choose : ef) a -> Eff '[] ef (f a)
runChoose =
    (a -> Eff '[] ef (f a))
-> Interpreter Choose (Eff '[] ef) (f a)
-> Eff '[] (Choose : ef) a
-> Eff '[] ef (f a)
forall (e :: * -> *) (ef :: [* -> *]) ans a.
(a -> Eff '[] ef ans)
-> Interpreter e (Eff '[] ef) ans
-> Eff '[] (e : ef) a
-> Eff '[] ef ans
interpretBy (f a -> Eff '[] ef (f a)
forall a. a -> Eff '[] ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> Eff '[] ef (f a)) -> (a -> f a) -> a -> Eff '[] ef (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) \Choose x
Choose x -> Eff '[] ef (f a)
k ->
        (f a -> f a -> f a)
-> Eff '[] ef (f a) -> Eff '[] ef (f a) -> Eff '[] ef (f a)
forall a b c.
(a -> b -> c) -> Eff '[] ef a -> Eff '[] ef b -> Eff '[] ef c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f a -> f a -> f a
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (x -> Eff '[] ef (f a)
k x
Bool
False) (x -> Eff '[] ef (f a)
k x
Bool
True)

-- | t'Choose' effect handler for monoidal answer type.
runChooseMonoid
    :: forall ans ef a
     . (Semigroup ans)
    => (a -> Eff '[] ef ans)
    -> Eff '[] (Choose ': ef) a
    -> Eff '[] ef ans
runChooseMonoid :: forall ans (ef :: [* -> *]) a.
Semigroup ans =>
(a -> Eff '[] ef ans) -> Eff '[] (Choose : ef) a -> Eff '[] ef ans
runChooseMonoid a -> Eff '[] ef ans
f =
    (a -> Eff '[] ef ans)
-> Interpreter Choose (Eff '[] ef) ans
-> Eff '[] (Choose : ef) a
-> Eff '[] ef ans
forall (e :: * -> *) (ef :: [* -> *]) ans a.
(a -> Eff '[] ef ans)
-> Interpreter e (Eff '[] ef) ans
-> Eff '[] (e : ef) a
-> Eff '[] ef ans
interpretBy a -> Eff '[] ef ans
f \Choose x
Choose x -> Eff '[] ef ans
k ->
        (ans -> ans -> ans)
-> Eff '[] ef ans -> Eff '[] ef ans -> Eff '[] ef ans
forall a b c.
(a -> b -> c) -> Eff '[] ef a -> Eff '[] ef b -> Eff '[] ef 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 '[] ef ans
k x
Bool
False) (x -> Eff '[] ef ans
k x
Bool
True)

-- | t'Empty' effect handler.
runEmpty :: forall a ef. Eff '[] (Empty ': ef) a -> Eff '[] ef (Maybe a)
runEmpty :: forall a (ef :: [* -> *]).
Eff '[] (Empty : ef) a -> Eff '[] ef (Maybe a)
runEmpty =
    (a -> Eff '[] ef (Maybe a))
-> Interpreter Empty (Eff '[] ef) (Maybe a)
-> Eff '[] (Empty : ef) a
-> Eff '[] ef (Maybe a)
forall (e :: * -> *) (ef :: [* -> *]) ans a.
(a -> Eff '[] ef ans)
-> Interpreter e (Eff '[] ef) ans
-> Eff '[] (e : ef) a
-> Eff '[] ef ans
interpretBy
        (Maybe a -> Eff '[] ef (Maybe a)
forall a. a -> Eff '[] ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Eff '[] ef (Maybe a))
-> (a -> Maybe a) -> a -> Eff '[] ef (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)
        \Empty x
Empty x -> Eff '[] ef (Maybe a)
_ -> Maybe a -> Eff '[] ef (Maybe a)
forall a. a -> Eff '[] ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

{- | 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
    :: (Choose <| ef)
    => Eff (ChooseH ': eh) ef ~> Eff eh ef
runChooseH :: forall (ef :: [* -> *]) (eh :: [EffectH]).
(Choose <| ef) =>
Eff (ChooseH : eh) ef ~> Eff eh ef
runChooseH = (ChooseH ~~> Eff eh ef) -> Eff (ChooseH : eh) ef ~> Eff eh ef
forall (e :: EffectH) (eh :: [EffectH]) (ef :: [* -> *]).
HFunctor e =>
(e ~~> Eff eh ef) -> Eff (e : eh) ef ~> Eff eh ef
interpretH \(ChooseH Eff eh ef x
a Eff eh ef x
b) -> Eff eh ef x -> Eff eh ef x -> Eff eh ef x
forall (ef :: [* -> *]) (eh :: [EffectH]) a.
(Choose <| ef) =>
Eff eh ef a -> Eff eh ef a -> Eff eh ef a
branch Eff eh ef x
a Eff eh ef x
b

-- | Faster than `<|>`.
branch :: (Choose <| ef) => Eff eh ef a -> Eff eh ef a -> Eff eh ef a
branch :: forall (ef :: [* -> *]) (eh :: [EffectH]) a.
(Choose <| ef) =>
Eff eh ef a -> Eff eh ef a -> Eff eh ef a
branch Eff eh ef a
a Eff eh ef a
b = do
    Bool
world <- Eff eh ef Bool
forall (f :: * -> *). SendFOE Choose f => f Bool
choose
    Eff eh ef a -> Eff eh ef a -> Bool -> Eff eh ef a
forall a. a -> a -> Bool -> a
bool Eff eh ef a
a Eff eh ef 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 :: (Choose <| ef, Empty <| ef) => [a] -> Eff eh ef a
choice :: forall (ef :: [* -> *]) a (eh :: [EffectH]).
(Choose <| ef, Empty <| ef) =>
[a] -> Eff eh ef a
choice = \case
    [] -> Eff eh ef a
forall a (f :: * -> *). SendFOE Empty f => f a
empty
    a
x : [a]
xs -> a -> Eff eh ef a
forall a. a -> Eff eh ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x Eff eh ef a -> Eff eh ef a -> Eff eh ef a
forall (ef :: [* -> *]) (eh :: [EffectH]) a.
(Choose <| ef) =>
Eff eh ef a -> Eff eh ef a -> Eff eh ef a
`branch` [a] -> Eff eh ef a
forall (ef :: [* -> *]) a (eh :: [EffectH]).
(Choose <| ef, Empty <| ef) =>
[a] -> Eff eh ef a
choice [a]
xs

-- | Selects one element from the list nondeterministically, branching the control as many times as the number of elements. Uses t'ChooseH'.
choiceH :: (ChooseH <<| eh, Empty <| ef) => [a] -> Eff eh ef a
choiceH :: forall (eh :: [EffectH]) (ef :: [* -> *]) a.
(ChooseH <<| eh, Empty <| ef) =>
[a] -> Eff eh ef a
choiceH = \case
    [] -> Eff eh ef a
forall a (f :: * -> *). SendFOE Empty f => f a
empty
    a
x : [a]
xs -> a -> Eff eh ef a
forall a. a -> Eff eh ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x Eff eh ef a -> Eff eh ef a -> Eff eh ef a
forall a. Eff eh ef a -> Eff eh ef a -> Eff eh ef a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> Eff eh ef a
forall (eh :: [EffectH]) (ef :: [* -> *]) a.
(ChooseH <<| eh, Empty <| ef) =>
[a] -> Eff eh ef a
choiceH [a]
xs

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

When 'empty' occurs, an '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
    :: (UnliftIO <<| eh, IO <| ef)
    => Eff (ChooseH ': eh) (Empty ': ef) a
    -> Eff eh ef (Either SomeException a)
runNonDetIO :: forall (eh :: [EffectH]) (ef :: [* -> *]) a.
(UnliftIO <<| eh, IO <| ef) =>
Eff (ChooseH : eh) (Empty : ef) a
-> Eff eh ef (Either SomeException a)
runNonDetIO Eff (ChooseH : eh) (Empty : ef) a
m = Eff eh ef a -> Eff eh ef (Either SomeException a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try do
    Eff (ChooseH : eh) (Empty : ef) a
m
        Eff (ChooseH : eh) (Empty : ef) a
-> (Eff (ChooseH : eh) (Empty : ef) a -> Eff eh (Empty : ef) a)
-> Eff eh (Empty : ef) a
forall a b. a -> (a -> b) -> b
& (ChooseH ~~> Eff eh (Empty : ef))
-> Eff (ChooseH : eh) (Empty : ef) ~> Eff eh (Empty : ef)
forall (e :: EffectH) (eh :: [EffectH]) (ef :: [* -> *]).
HFunctor e =>
(e ~~> Eff eh ef) -> Eff (e : eh) ef ~> Eff eh ef
interpretH
            ( \(ChooseH Eff eh (Empty : ef) x
a Eff eh (Empty : ef) x
b) ->
                Eff eh (Empty : ef) x
-> Eff eh (Empty : ef) (Either SomeException x)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try Eff eh (Empty : ef) x
a Eff eh (Empty : ef) (Either SomeException x)
-> (Either SomeException x -> Eff eh (Empty : ef) x)
-> Eff eh (Empty : ef) x
forall a b.
Eff eh (Empty : ef) a
-> (a -> Eff eh (Empty : ef) b) -> Eff eh (Empty : ef) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Right x
x -> x -> Eff eh (Empty : ef) x
forall a. a -> Eff eh (Empty : ef) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x
                    Left (SomeException
_ :: SomeException) -> Eff eh (Empty : ef) x
b
            )
        Eff eh (Empty : ef) a
-> (Eff eh (Empty : ef) a -> Eff eh ef a) -> Eff eh ef a
forall a b. a -> (a -> b) -> b
& (Empty ~> Eff eh ef) -> Eff eh (Empty : ef) ~> Eff eh ef
forall (e :: * -> *) (ef :: [* -> *]) (eh :: [EffectH]).
(e ~> Eff eh ef) -> Eff eh (e : ef) ~> Eff eh ef
interpret (\Empty x
Empty -> EmptyException -> Eff eh ef x
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO EmptyException
EmptyException)

-- | 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)