Add new EarlyReturn effect

effectful-core/effectful-core.cabal

@@ -86,6 +86,7 @@ library
                      Effectful.Dispatch.Static
                      Effectful.Dispatch.Static.Primitive
                      Effectful.Dispatch.Static.Unsafe
+                     Effectful.EarlyReturn.Dynamic
                      Effectful.Error.Dynamic
                      Effectful.Error.Static
                      Effectful.Exception

effectful-core/src/Effectful/EarlyReturn/Dynamic.hs

@@ -0,0 +1,98 @@
+-- | Dynamically dispatched EarlyReturn effect.
+--
+-- The @EarlyReturn@ effect allows you to define a block from which you can
+-- return early. Implemented as an exception.
+--
+-- Unlike many handlers which will be run near the entrypoint of a program, you
+-- will most likely run your @EarlyReturn@ effect handler in the block you want
+-- to return early from. As example of the former, with the handler in @main@:
+--
+-- @
+-- early1 :: forall es. (HasCallStack, IOE :> es, EarlyReturn Bool :> es) => Int -> Eff es Bool
+-- early1 n = do
+--   when (n > 10) $ do
+--     returnWith True
+--   pure False
+-- 
+-- f1 :: forall es. (HasCallStack, IOE :> es, EarlyReturn Bool :> es) => Int -> Eff es Bool
+-- f1 x = do
+--   y <- early1 x
+--   liftIO $ putStrLn $ "in f1, y=" <> show y
+--   pure y
+--
+-- main1 :: IO ()
+-- main1 = do
+--   x <- runEff . runEarlyReturn $ f1 20
+--   print x
+-- @
+--
+-- >>> main1
+-- True
+--
+-- Note @"in f1, y=True"@ was not printed, the handler caught our @EarlyReturn@
+-- and we end up back in @main1@.
+--
+-- Now with our handler running in the block we want to be able to return early
+-- from:
+--
+-- @
+-- early2 :: forall es. (HasCallStack, IOE :> es) => Int -> Eff es Bool
+-- early2 x = runEarlyReturn $ do
+--   when (x > 10) $ do
+--     returnWith True
+--   pure False
+-- 
+-- f2 :: forall es a. (HasCallStack, IOE :> es) => Int -> Eff es Bool
+-- f2 x = do
+--   y <- early2 x
+--   liftIO $ putStrLn $ "in f2, y=" <> show y
+--   pure y
+--
+-- main2 :: IO ()
+-- main2 = do
+--   y <- runEff $ f2 20
+--   print y
+-- @
+--
+-- >>> main2
+-- in f2, y=True
+-- True
+--
+-- This way the EarlyReturn effect is handled in @early2@ and we see @"in f2,
+-- y=True"@.
+--
+module Effectful.EarlyReturn.Dynamic
+  ( -- * Effect
+    EarlyReturn(..)
+
+    -- ** Handlers
+  , runEarlyReturn
+  , runEarlyReturnEither
+
+    -- ** Operations
+  , returnWith
+  ) where
+
+import           Effectful                  (Dispatch (..), DispatchOf, Eff,
+                                             Effect, (:>))
+import           Effectful.Dispatch.Dynamic (HasCallStack, reinterpret_, send)
+import           Effectful.Error.Dynamic    (runErrorNoCallStack, throwError_)
+
+data EarlyReturn r :: Effect where
+  ReturnWith :: r -> EarlyReturn r m a
+
+type instance DispatchOf (EarlyReturn r) = Dynamic
+
+returnWith
+  :: (HasCallStack, EarlyReturn r :> es)
+  => r
+  -> Eff es a
+returnWith = send . ReturnWith
+
+runEarlyReturnEither :: Eff (EarlyReturn r : es) a -> Eff es (Either r a)
+runEarlyReturnEither = reinterpret_ runErrorNoCallStack $ \case
+  ReturnWith r -> throwError_ r
+
+runEarlyReturn :: Eff (EarlyReturn a : es) a -> Eff es a
+runEarlyReturn = fmap (either id id) . runEarlyReturnEither
+

effectful/effectful.cabal

@@ -115,6 +115,7 @@ library
     reexported-modules:    Effectful
                          , Effectful.Dispatch.Dynamic
                          , Effectful.Dispatch.Static
+                         , Effectful.EarlyReturn.Dynamic
                          , Effectful.Error.Static
                          , Effectful.Error.Dynamic
                          , Effectful.Exception
@@ -162,6 +163,7 @@ test-suite test
 
     other-modules:  AsyncTests
                     ConcurrencyTests
+                    EarlyReturnTests
                     EnvTests
                     EnvironmentTests
                     ErrorTests

effectful/tests/EarlyReturnTests.hs

@@ -0,0 +1,75 @@
+module EarlyReturnTests (earlyReturnTests) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Control.Monad (when)
+import Effectful
+import Effectful.EarlyReturn.Dynamic (runEarlyReturn, returnWith)
+import           Effectful.Reader.Dynamic   (Reader, asks, runReader)
+import Utils qualified as U
+
+earlyReturnTests :: TestTree
+earlyReturnTests = testGroup "EarlyReturn"
+  [ testCase "early return" $ test_earlyReturn
+  , testCase "early return within early return" $ test_nestedEarlyReturn
+  , testCase "other effects with early return" $ test_earlyReturnOtherEffects
+  ]
+
+data Config = Config {
+  foo  :: Int
+}
+
+helper1 :: forall es. HasCallStack => Int -> Eff es String
+helper1 x = runEarlyReturn $ do
+  when (x < 10) $ do
+    returnWith "lt10"
+  when (x < 20) $ do
+    returnWith "lt20"
+  pure "gte20"
+
+helper2 :: forall es. HasCallStack => Int -> Eff es Int
+helper2 x = runEarlyReturn $ do
+  when (x < 20) $ do
+    y <- helper1 x
+    returnWith @Int $ if y == "lt10" then 1 else 2
+  pure 3
+
+earlyAndReaderHelper :: forall es. (HasCallStack, Reader Config :> es) => Eff es Bool
+earlyAndReaderHelper = runEarlyReturn $ do
+  x <- asks foo
+  when (x < 10) $ do
+    returnWith @Bool True
+  pure False
+
+test_earlyReturn
+  :: Assertion
+test_earlyReturn = runEff $ do
+  val1 <- helper1 5
+  U.assertEqual "val1" val1 "lt10"
+  val2 <- helper1 30
+  U.assertEqual "val2" val2 "gte20"
+
+test_nestedEarlyReturn
+  :: Assertion
+test_nestedEarlyReturn = runEff $ do
+  val1 <- helper2 1
+  U.assertEqual "val1" val1 1
+  val2 <- helper2 15
+  U.assertEqual "val2" val2 2
+  val3 <- helper2 25
+  U.assertEqual "val3" val3 3
+
+test_earlyReturnOtherEffects
+  :: Assertion
+test_earlyReturnOtherEffects = do
+  let config1 = Config { foo = 1 }
+  runEff $ runReader config1 $ do
+    val1 <- earlyAndReaderHelper
+    U.assertEqual "val1" val1 True
+
+  let config2 = Config { foo = 20 }
+  runEff $ runReader config2 $ do
+    val2 <- earlyAndReaderHelper
+    U.assertEqual "val2" val2 False
+

effectful/tests/Main.hs

@@ -4,6 +4,7 @@ import Test.Tasty
 
 import AsyncTests
 import ConcurrencyTests
+import EarlyReturnTests
 import EnvTests
 import EnvironmentTests
 import ErrorTests
@@ -19,6 +20,7 @@ main :: IO ()
 main = defaultMain $ testGroup "effectful"
   [ asyncTests
   , concurrencyTests
+  , earlyReturnTests
   , envTests
   , environmentTests
   , errorTests