-- | Provider of the t'Control.Applicative.Alternative' and
-- t'Control.Monad.MonadPlus' instance for 'Eff'.
module Effectful.NonDet
  ( -- * Effect
    NonDet(..)
  , OnEmptyPolicy(..)

    -- ** Handlers
  , runNonDet

  -- * Utils
  , emptyEff
  , sumEff

    -- * Re-exports
  , Alternative(..)
  , HasCallStack
  , CallStack
  , getCallStack
  , prettyCallStack
  ) where

import Control.Applicative
import Data.Coerce
import GHC.Generics
import GHC.Stack

import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Dispatch.Static
import Effectful.Dispatch.Static.Primitive
import Effectful.Error.Static
import Effectful.Internal.Monad (LocalEnv(..), NonDet(..))

-- | Policy of dealing with modifications to __thread local__ state in the
-- environment in branches that end up calling the 'Empty' operation.
--
-- /Note:/ 'OnEmptyKeep' is significantly faster as there is no need to back up
-- the environment on each call to ':<|>:'.
--
-- @since 2.2.0.0
data OnEmptyPolicy
  = OnEmptyKeep     -- ^ Keep modifications on 'Empty'.
  | OnEmptyRollback -- ^ Rollback modifications on 'Empty'.
  deriving (OnEmptyPolicy -> OnEmptyPolicy -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OnEmptyPolicy -> OnEmptyPolicy -> Bool
$c/= :: OnEmptyPolicy -> OnEmptyPolicy -> Bool
== :: OnEmptyPolicy -> OnEmptyPolicy -> Bool
$c== :: OnEmptyPolicy -> OnEmptyPolicy -> Bool
Eq, forall x. Rep OnEmptyPolicy x -> OnEmptyPolicy
forall x. OnEmptyPolicy -> Rep OnEmptyPolicy x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OnEmptyPolicy x -> OnEmptyPolicy
$cfrom :: forall x. OnEmptyPolicy -> Rep OnEmptyPolicy x
Generic, Eq OnEmptyPolicy
OnEmptyPolicy -> OnEmptyPolicy -> Bool
OnEmptyPolicy -> OnEmptyPolicy -> Ordering
OnEmptyPolicy -> OnEmptyPolicy -> OnEmptyPolicy
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OnEmptyPolicy -> OnEmptyPolicy -> OnEmptyPolicy
$cmin :: OnEmptyPolicy -> OnEmptyPolicy -> OnEmptyPolicy
max :: OnEmptyPolicy -> OnEmptyPolicy -> OnEmptyPolicy
$cmax :: OnEmptyPolicy -> OnEmptyPolicy -> OnEmptyPolicy
>= :: OnEmptyPolicy -> OnEmptyPolicy -> Bool
$c>= :: OnEmptyPolicy -> OnEmptyPolicy -> Bool
> :: OnEmptyPolicy -> OnEmptyPolicy -> Bool
$c> :: OnEmptyPolicy -> OnEmptyPolicy -> Bool
<= :: OnEmptyPolicy -> OnEmptyPolicy -> Bool
$c<= :: OnEmptyPolicy -> OnEmptyPolicy -> Bool
< :: OnEmptyPolicy -> OnEmptyPolicy -> Bool
$c< :: OnEmptyPolicy -> OnEmptyPolicy -> Bool
compare :: OnEmptyPolicy -> OnEmptyPolicy -> Ordering
$ccompare :: OnEmptyPolicy -> OnEmptyPolicy -> Ordering
Ord, Int -> OnEmptyPolicy -> ShowS
[OnEmptyPolicy] -> ShowS
OnEmptyPolicy -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OnEmptyPolicy] -> ShowS
$cshowList :: [OnEmptyPolicy] -> ShowS
show :: OnEmptyPolicy -> String
$cshow :: OnEmptyPolicy -> String
showsPrec :: Int -> OnEmptyPolicy -> ShowS
$cshowsPrec :: Int -> OnEmptyPolicy -> ShowS
Show)

-- | Run the 'NonDet' effect with a given 'OnEmptyPolicy'.
--
-- /Note:/ ':<|>:' executes the second computation if (and only if) the first
-- computation calls 'Empty'.
--
-- @since 2.2.0.0
runNonDet :: OnEmptyPolicy -> Eff (NonDet : es) a -> Eff es (Either CallStack a)
runNonDet :: forall (es :: [(Type -> Type) -> Type -> Type]) a.
OnEmptyPolicy -> Eff (NonDet : es) a -> Eff es (Either CallStack a)
runNonDet = \case
  OnEmptyPolicy
OnEmptyKeep     -> forall (es :: [(Type -> Type) -> Type -> Type]) a.
Eff (NonDet : es) a -> Eff es (Either CallStack a)
runNonDetKeep
  OnEmptyPolicy
OnEmptyRollback -> forall (es :: [(Type -> Type) -> Type -> Type]) a.
Eff (NonDet : es) a -> Eff es (Either CallStack a)
runNonDetRollback

runNonDetKeep :: Eff (NonDet : es) a -> Eff es (Either CallStack a)
runNonDetKeep :: forall (es :: [(Type -> Type) -> Type -> Type]) a.
Eff (NonDet : es) a -> Eff es (Either CallStack a)
runNonDetKeep = forall (e :: (Type -> Type) -> Type -> Type)
       (handlerEs :: [(Type -> Type) -> Type -> Type]) a
       (es :: [(Type -> Type) -> Type -> Type]) b.
(DispatchOf e ~ 'Dynamic) =>
(Eff handlerEs a -> Eff es b)
-> EffectHandler e handlerEs -> Eff (e : es) a -> Eff es b
reinterpret (forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall cs e a. Either (cs, e) a -> Either cs a
noError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (es :: [(Type -> Type) -> Type -> Type]) a.
Eff (Error e : es) a -> Eff es (Either (CallStack, e) a)
runError @()) forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs (Error () : es)
env -> \case
  NonDet (Eff localEs) a
Empty       -> forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError ()
  Eff localEs a
m1 :<|>: Eff localEs a
m2 -> forall (es :: [(Type -> Type) -> Type -> Type])
       (handlerEs :: [(Type -> Type) -> Type -> Type])
       (localEs :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, SharedSuffix es handlerEs) =>
LocalEnv localEs handlerEs
-> ((forall r. Eff localEs r -> Eff es r) -> Eff es a) -> Eff es a
localSeqUnlift LocalEnv localEs (Error () : es)
env forall a b. (a -> b) -> a -> b
$ \forall r. Eff localEs r -> Eff (Error () : es) r
unlift -> do
    Maybe a
mr <- (forall a. a -> Maybe a
Just forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r. Eff localEs r -> Eff (Error () : es) r
unlift Eff localEs a
m1) forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(Error e :> es) =>
Eff es a -> (CallStack -> e -> Eff es a) -> Eff es a
`catchError` \CallStack
_ () -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    case Maybe a
mr of
      Just a
r  -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
r
      Maybe a
Nothing -> forall r. Eff localEs r -> Eff (Error () : es) r
unlift Eff localEs a
m2

runNonDetRollback :: Eff (NonDet : es) a -> Eff es (Either CallStack a)
runNonDetRollback :: forall (es :: [(Type -> Type) -> Type -> Type]) a.
Eff (NonDet : es) a -> Eff es (Either CallStack a)
runNonDetRollback = forall (e :: (Type -> Type) -> Type -> Type)
       (handlerEs :: [(Type -> Type) -> Type -> Type]) a
       (es :: [(Type -> Type) -> Type -> Type]) b.
(DispatchOf e ~ 'Dynamic) =>
(Eff handlerEs a -> Eff es b)
-> EffectHandler e handlerEs -> Eff (e : es) a -> Eff es b
reinterpret (forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall cs e a. Either (cs, e) a -> Either cs a
noError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (es :: [(Type -> Type) -> Type -> Type]) a.
Eff (Error e : es) a -> Eff es (Either (CallStack, e) a)
runError @()) forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs (Error () : es)
env -> \case
  NonDet (Eff localEs) a
Empty       -> forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError ()
  Eff localEs a
m1 :<|>: Eff localEs a
m2 -> do
    LocalEnv localEs (Error () : es)
backupEnv <- forall (localEs :: [(Type -> Type) -> Type -> Type])
       (handlerEs :: [(Type -> Type) -> Type -> Type])
       (es :: [(Type -> Type) -> Type -> Type]).
LocalEnv localEs handlerEs -> Eff es (LocalEnv localEs handlerEs)
cloneLocalEnv LocalEnv localEs (Error () : es)
env
    forall (es :: [(Type -> Type) -> Type -> Type])
       (handlerEs :: [(Type -> Type) -> Type -> Type])
       (localEs :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, SharedSuffix es handlerEs) =>
LocalEnv localEs handlerEs
-> ((forall r. Eff localEs r -> Eff es r) -> Eff es a) -> Eff es a
localSeqUnlift LocalEnv localEs (Error () : es)
env forall a b. (a -> b) -> a -> b
$ \forall r. Eff localEs r -> Eff (Error () : es) r
unlift -> do
      Maybe a
mr <- (forall a. a -> Maybe a
Just forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r. Eff localEs r -> Eff (Error () : es) r
unlift Eff localEs a
m1) forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(Error e :> es) =>
Eff es a -> (CallStack -> e -> Eff es a) -> Eff es a
`catchError` \CallStack
_ () -> do
        -- If m1 failed, roll back the environment.
        forall (localEs :: [(Type -> Type) -> Type -> Type])
       (handlerEs :: [(Type -> Type) -> Type -> Type])
       (es :: [(Type -> Type) -> Type -> Type]).
LocalEnv localEs handlerEs
-> LocalEnv localEs handlerEs -> Eff es ()
restoreLocalEnv LocalEnv localEs (Error () : es)
env LocalEnv localEs (Error () : es)
backupEnv
        forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      case Maybe a
mr of
        Just a
r  -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
r
        Maybe a
Nothing -> forall r. Eff localEs r -> Eff (Error () : es) r
unlift Eff localEs a
m2

----------------------------------------

-- | Specialized version of 'empty' with the 'HasCallStack' constraint for
-- tracking purposes.
--
-- @since 2.2.0.0
emptyEff :: (HasCallStack, NonDet :> es) => Eff es a
emptyEff :: forall (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, NonDet :> es) =>
Eff es a
emptyEff = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send forall (m :: Type -> Type) a. NonDet m a
Empty

-- | Specialized version of 'asum' with the 'HasCallStack' constraint for
-- tracking purposes.
--
-- @since 2.2.0.0
sumEff :: (HasCallStack, Foldable t, NonDet :> es) => t (Eff es a) -> Eff es a
sumEff :: forall (t :: Type -> Type) (es :: [(Type -> Type) -> Type -> Type])
       a.
(HasCallStack, Foldable t, NonDet :> es) =>
t (Eff es a) -> Eff es a
sumEff = forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
(<|>) forall (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, NonDet :> es) =>
Eff es a
emptyEff

----------------------------------------
-- Internal helpers

noError :: Either (cs, e) a -> Either cs a
noError :: forall cs e a. Either (cs, e) a -> Either cs a
noError = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. b -> Either a b
Right

cloneLocalEnv
  :: LocalEnv localEs handlerEs
  -> Eff es (LocalEnv localEs handlerEs)
cloneLocalEnv :: forall (localEs :: [(Type -> Type) -> Type -> Type])
       (handlerEs :: [(Type -> Type) -> Type -> Type])
       (es :: [(Type -> Type) -> Type -> Type]).
LocalEnv localEs handlerEs -> Eff es (LocalEnv localEs handlerEs)
cloneLocalEnv = coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (es :: [(Type -> Type) -> Type -> Type]).
Env es -> IO (Env es)
cloneEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce

restoreLocalEnv
  :: LocalEnv localEs handlerEs
  -> LocalEnv localEs handlerEs
  -> Eff es ()
restoreLocalEnv :: forall (localEs :: [(Type -> Type) -> Type -> Type])
       (handlerEs :: [(Type -> Type) -> Type -> Type])
       (es :: [(Type -> Type) -> Type -> Type]).
LocalEnv localEs handlerEs
-> LocalEnv localEs handlerEs -> Eff es ()
restoreLocalEnv LocalEnv localEs handlerEs
dest LocalEnv localEs handlerEs
src = forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ forall a b. (a -> b) -> a -> b
$ forall (es :: [(Type -> Type) -> Type -> Type]).
Env es -> Env es -> IO ()
restoreEnv (coerce :: forall a b. Coercible a b => a -> b
coerce LocalEnv localEs handlerEs
dest) (coerce :: forall a b. Coercible a b => a -> b
coerce LocalEnv localEs handlerEs
src)