-- | Support for early return from a computation.
--
-- >>> import Control.Monad (when)
--
-- >>> :{
--   classify :: ReturnWith String :> es => Int -> Eff es String
--   classify n = do
--     when (n < 0) $ returnWith "negative"
--     when (n == 0) $ returnWith "zero"
--     pure "positive"
-- :}
--
-- >>> runEff . runReturnWith $ classify 5
-- "positive"
--
-- >>> runEff . runReturnWith $ classify (-5)
-- "negative"
--
-- === Interaction with threads
--
-- The 'ReturnWith' effect uses runtime exceptions underneath, so the usual
-- rules apply. In particular, in multi-threaded code a call to 'returnWith' in
-- a child thread will not automatically propagate to the parent. If you need
-- that, use functions such as @withAsync@ from the
-- [Effectful.Concurrent.Async](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent-Async.html)
-- module of the @effectful@ package (which propagate exceptions from child
-- threads to their parents) or arrange the propagation yourself.
--
-- For more information see the documentation of the
-- [Concurrent](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent.html#t:Concurrent)
-- effect.
--
-- @since 2.7.0.0
module Effectful.ReturnWith.Static
  ( -- * Effect
    ReturnWith

    -- ** Handlers
  , runReturnWith

    -- ** Operations
  , returnWith
  ) where

import Data.Kind
import GHC.Stack

import Effectful
import Effectful.Dispatch.Static
import Effectful.Exception
import Effectful.Internal.Utils

-- | Provide the ability to return early with a value of type @r@.
data ReturnWith (r :: Type) :: Effect

type instance DispatchOf (ReturnWith r) = Static NoSideEffects
newtype instance StaticRep (ReturnWith r) = ReturnWith ReturnWithId

-- | Run a computation that can return early with a value of type @r@.
runReturnWith
  :: forall r es
   . HasCallStack
  => Eff (ReturnWith r : es) r
  -> Eff es r
runReturnWith :: forall r (es :: [(Type -> Type) -> Type -> Type]).
HasCallStack =>
Eff (ReturnWith r : es) r -> Eff es r
runReturnWith Eff (ReturnWith r : es) r
action = do
  ReturnWithId
rid <- IO ReturnWithId -> Eff es ReturnWithId
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ IO ReturnWithId
newReturnWithId
  StaticRep (ReturnWith r) -> Eff (ReturnWith r : es) r -> Eff es r
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects,
 MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es a
evalStaticRep (forall r. ReturnWithId -> StaticRep (ReturnWith r)
ReturnWith @r ReturnWithId
rid) (Eff (ReturnWith r : es) r -> Eff es r)
-> Eff (ReturnWith r : es) r -> Eff es r
forall a b. (a -> b) -> a -> b
$ do
    (ReturnWithWrapper -> Maybe r)
-> Eff (ReturnWith r : es) r
-> (r -> Eff (ReturnWith r : es) r)
-> Eff (ReturnWith r : es) r
forall e b (es :: [(Type -> Type) -> Type -> Type]) a.
Exception e =>
(e -> Maybe b) -> Eff es a -> (b -> Eff es a) -> Eff es a
catchJust (ReturnWithId -> ReturnWithWrapper -> Maybe r
forall r. ReturnWithId -> ReturnWithWrapper -> Maybe r
matchReturnWith ReturnWithId
rid) Eff (ReturnWith r : es) r
action r -> Eff (ReturnWith r : es) r
forall a. a -> Eff (ReturnWith r : es) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure

-- | Return early with the given value.
returnWith
  :: forall r es a. (HasCallStack, ReturnWith r :> es)
  => r
  -- ^ The value.
  -> Eff es a
returnWith :: forall r (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, ReturnWith r :> es) =>
r -> Eff es a
returnWith r
r = do
  ReturnWith ReturnWithId
rid <- forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, DispatchOf e ~ 'Static sideEffects, e :> es) =>
Eff es (StaticRep e)
getStaticRep @(ReturnWith r)
  (HasCallStack => ReturnWithWrapper -> Eff es a)
-> ReturnWithWrapper -> Eff es a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => ReturnWithWrapper -> Eff es a
ReturnWithWrapper -> Eff es a
forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO (ReturnWithWrapper -> Eff es a) -> ReturnWithWrapper -> Eff es a
forall a b. (a -> b) -> a -> b
$ ReturnWithId -> CallStack -> Any -> ReturnWithWrapper
ReturnWithWrapper ReturnWithId
rid CallStack
HasCallStack => CallStack
callStack (r -> Any
forall a. a -> Any
toAny r
r)

----------------------------------------
-- Helpers

newtype ReturnWithId = ReturnWithId Unique
  deriving newtype ReturnWithId -> ReturnWithId -> Bool
(ReturnWithId -> ReturnWithId -> Bool)
-> (ReturnWithId -> ReturnWithId -> Bool) -> Eq ReturnWithId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReturnWithId -> ReturnWithId -> Bool
== :: ReturnWithId -> ReturnWithId -> Bool
$c/= :: ReturnWithId -> ReturnWithId -> Bool
/= :: ReturnWithId -> ReturnWithId -> Bool
Eq

-- | A unique is picked so that distinct 'ReturnWith' handlers for the same
-- type don't catch each other's values.
newReturnWithId :: IO ReturnWithId
newReturnWithId :: IO ReturnWithId
newReturnWithId = Unique -> ReturnWithId
ReturnWithId (Unique -> ReturnWithId) -> IO Unique -> IO ReturnWithId
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique

data ReturnWithWrapper = ReturnWithWrapper !ReturnWithId CallStack Any

instance Show ReturnWithWrapper where
  showsPrec :: Int -> ReturnWithWrapper -> ShowS
showsPrec Int
p (ReturnWithWrapper ReturnWithId
_ CallStack
cs Any
_)
    = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
    (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (String
"Effectful.ReturnWith.Static.ReturnWithWrapper\n" ++)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CallStack -> String
prettyCallStack CallStack
cs ++)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"\n\nIf you see this message, most likely a call to returnWith " ++)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"escaped the scope of its handler, e.g. by being made from a thread " ++)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"that outlived it, or was caught by an overly zealous exception " ++)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"handler. For more information see the documentation of the " ++)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Effectful.ReturnWith.Static module." ++)

instance Exception ReturnWithWrapper where
  -- See discussion in https://github.com/haskell-effectful/effectful/pull/232.
  toException :: ReturnWithWrapper -> SomeException
toException = ReturnWithWrapper -> SomeException
forall e. Exception e => e -> SomeException
asyncExceptionToException
  fromException :: SomeException -> Maybe ReturnWithWrapper
fromException = SomeException -> Maybe ReturnWithWrapper
forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException

matchReturnWith :: ReturnWithId -> ReturnWithWrapper -> Maybe r
matchReturnWith :: forall r. ReturnWithId -> ReturnWithWrapper -> Maybe r
matchReturnWith ReturnWithId
rid (ReturnWithWrapper ReturnWithId
rtag CallStack
_ Any
r)
  | ReturnWithId
rid ReturnWithId -> ReturnWithId -> Bool
forall a. Eq a => a -> a -> Bool
== ReturnWithId
rtag = r -> Maybe r
forall a. a -> Maybe a
Just (Any -> r
forall a. Any -> a
fromAny Any
r)
  | Bool
otherwise = Maybe r
forall a. Maybe a
Nothing