From fc8a1962ff4b87a0ec32cd2681de936be1ddc479 Mon Sep 17 00:00:00 2001
From: Andrzej Rybczak <andrzej@rybczak.net>
Date: Wed, 30 Jun 2021 19:01:39 +0200
Subject: [PATCH] Add the Fail effect

---
 effectful.cabal                 |  1 +
 src/Effectful/Error.hs          | 17 +++++++------
 src/Effectful/Fail.hs           |  6 +++++
 src/Effectful/Internal/Monad.hs | 42 +++++++++++++++++++++++++++++++++
 4 files changed, 57 insertions(+), 9 deletions(-)
 create mode 100644 src/Effectful/Fail.hs

diff --git a/effectful.cabal b/effectful.cabal
index bb6fa91..777592f 100644
--- a/effectful.cabal
+++ b/effectful.cabal
@@ -71,6 +71,7 @@ library
                      Effectful.Class.State
                      Effectful.Class.Writer
                      Effectful.Error
+                     Effectful.Fail
                      Effectful.Internal.Effect
                      Effectful.Internal.Env
                      Effectful.Internal.Monad
diff --git a/src/Effectful/Error.hs b/src/Effectful/Error.hs
index 67692d1..db1264f 100644
--- a/src/Effectful/Error.hs
+++ b/src/Effectful/Error.hs
@@ -65,7 +65,7 @@ throwError
   => e
   -> Eff es a
 throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do
-  throwIO $ WrapErr tag callStack e
+  throwIO $ ErrorEx tag callStack e
 
 catchError
   :: forall e es a. (Typeable e, Error e :> es)
@@ -88,19 +88,18 @@ tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
 ----------------------------------------
 -- Helpers
 
-data WrapErr e = WrapErr Unique CallStack e
-
-instance Typeable e => Show (WrapErr e) where
-  showsPrec p (WrapErr _ cs e)
-    = showsPrec p "Effectful.Error.WrapErr ("
+data ErrorEx e = ErrorEx Unique CallStack e
+instance Typeable e => Show (ErrorEx e) where
+  showsPrec p (ErrorEx _ cs e)
+    = ("Effectful.Error.ErrorEx (" ++)
     . showsPrec p (typeOf e)
-    . showsPrec p ") "
+    . (") " ++)
     . showsPrec p cs
-instance Typeable e => Exception (WrapErr e)
+instance Typeable e => Exception (ErrorEx e)
 
 catchErrorIO :: Typeable e => Unique -> IO a -> (CallStack -> e -> IO a) -> IO a
 catchErrorIO tag m handler = do
-  m `catch` \err@(WrapErr etag e cs) -> do
+  m `catch` \err@(ErrorEx etag e cs) -> do
     if tag == etag
       then handler e cs
       else throwIO err
diff --git a/src/Effectful/Fail.hs b/src/Effectful/Fail.hs
new file mode 100644
index 0000000..ca330c5
--- /dev/null
+++ b/src/Effectful/Fail.hs
@@ -0,0 +1,6 @@
+module Effectful.Fail
+  ( Fail
+  , runFail
+  ) where
+
+import Effectful.Internal.Monad
diff --git a/src/Effectful/Internal/Monad.hs b/src/Effectful/Internal/Monad.hs
index 3d385d9..7f15f47 100644
--- a/src/Effectful/Internal/Monad.hs
+++ b/src/Effectful/Internal/Monad.hs
@@ -17,6 +17,10 @@ module Effectful.Internal.Monad
   , unsafeEff_
   , unsafeUnliftEff
 
+  -- * Fail
+  , Fail
+  , runFail
+
   -- * IO
   , IOE
   , runIOE
@@ -45,6 +49,7 @@ import Control.Monad.Fix
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Trans.Control
+import Data.Unique
 import GHC.Magic (oneShot)
 import System.IO.Unsafe (unsafeDupablePerformIO)
 
@@ -172,6 +177,43 @@ instance MonadMask (Eff es) where
     c <- unEff (release resource $ ExitCaseSuccess b) es
     pure (b, c)
 
+----------------------------------------
+-- Fail
+
+data Fail :: Effect where
+  Fail :: Unique -> Fail m r
+
+runFail :: Eff (Fail : es) a -> Eff es (Either String a)
+runFail m = unsafeEff $ \es0 -> mask $ \release -> do
+  -- A unique tag is picked so that different runFail handlers don't catch each
+  -- other's exceptions.
+  tag <- newUnique
+  size0 <- sizeEnv es0
+  es <- unsafeConsEnv (IdE (Fail tag)) noRelinker es0
+  r <- tryFailIO tag (release $ unEff m es) `onException` unsafeTailEnv size0 es
+  _ <- unsafeTailEnv size0 es
+  pure r
+
+instance Fail :> es => MonadFail (Eff es) where
+  fail msg = readerEffectM $ \(IdE (Fail tag)) -> unsafeEff_ $ do
+    throwM $ FailEx tag msg
+
+--------------------
+
+data FailEx = FailEx Unique String
+instance Show FailEx where
+  showsPrec p (FailEx _ msg)
+    = ("Effectful.Internal.Monad.FailEx " ++)
+    . showsPrec p msg
+instance Exception FailEx
+
+tryFailIO :: Unique -> IO a -> IO (Either String a)
+tryFailIO tag m =
+  (Right <$> m) `catch` \err@(FailEx etag msg) -> do
+    if tag == etag
+      then pure $ Left msg
+      else throwM err
+
 ----------------------------------------
 -- IO