git.iko.soy/effectful
on master help sign in
Add the Fail effect
commitfc8a1962ff4b87a0ec32cd2681de936be1ddc479 authorAndrzej Rybczak <andrzej@rybczak.net> dateWed 30 Jun 2021, 19:01 (5 years ago) parentacaf810
4 files changed+57−9
compare with master
unifiedsplit
effectful.cabal+1 src/Effectful/Error.hs+8−9 src/Effectful/Fail.hs+6 src/Effectful/Internal/Monad.hs+42
effectful.cabal+1
@@ -71,6 +71,7 @@ library
7171 Effectful.Class.State
7272 Effectful.Class.Writer
7373 Effectful.Error
74+ Effectful.Fail
7475 Effectful.Internal.Effect
7576 Effectful.Internal.Env
7677 Effectful.Internal.Monad
src/Effectful/Error.hs+8−9
@@ -65,7 +65,7 @@ throwError
6565 => e
6666 -> Eff es a
6767throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do
68− throwIO $ WrapErr tag callStack e
68+ throwIO $ ErrorEx tag callStack e
6969
7070catchError
7171 :: forall e es a. (Typeable e, Error e :> es)
@@ -88,19 +88,18 @@ tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
8888----------------------------------------
8989-- Helpers
9090
91−data WrapErr e = WrapErr Unique CallStack e
92−
93−instance Typeable e => Show (WrapErr e) where
94− showsPrec p (WrapErr _ cs e)
95− = showsPrec p "Effectful.Error.WrapErr ("
91+data ErrorEx e = ErrorEx Unique CallStack e
92+instance Typeable e => Show (ErrorEx e) where
93+ showsPrec p (ErrorEx _ cs e)
94+ = ("Effectful.Error.ErrorEx (" ++)
9695 . showsPrec p (typeOf e)
97− . showsPrec p ") "
96+ . (") " ++)
9897 . showsPrec p cs
99−instance Typeable e => Exception (WrapErr e)
98+instance Typeable e => Exception (ErrorEx e)
10099
101100catchErrorIO :: Typeable e => Unique -> IO a -> (CallStack -> e -> IO a) -> IO a
102101catchErrorIO tag m handler = do
103− m `catch` \err@(WrapErr etag e cs) -> do
102+ m `catch` \err@(ErrorEx etag e cs) -> do
104103 if tag == etag
105104 then handler e cs
106105 else throwIO err
src/Effectful/Fail.hsnew file+6
@@ -0,0 +1,6 @@
1+module Effectful.Fail
2+ ( Fail
3+ , runFail
4+ ) where
5+
6+import Effectful.Internal.Monad
src/Effectful/Internal/Monad.hs+42
@@ -17,6 +17,10 @@ module Effectful.Internal.Monad
1717 , unsafeEff_
1818 , unsafeUnliftEff
1919
20+ -- * Fail
21+ , Fail
22+ , runFail
23+
2024 -- * IO
2125 , IOE
2226 , runIOE
@@ -45,6 +49,7 @@ import Control.Monad.Fix
4549import Control.Monad.IO.Class
4650import Control.Monad.IO.Unlift
4751import Control.Monad.Trans.Control
52+import Data.Unique
4853import GHC.Magic (oneShot)
4954import System.IO.Unsafe (unsafeDupablePerformIO)
5055
@@ -172,6 +177,43 @@ instance MonadMask (Eff es) where
172177 c <- unEff (release resource $ ExitCaseSuccess b) es
173178 pure (b, c)
174179
180+----------------------------------------
181+-- Fail
182+
183+data Fail :: Effect where
184+ Fail :: Unique -> Fail m r
185+
186+runFail :: Eff (Fail : es) a -> Eff es (Either String a)
187+runFail m = unsafeEff $ \es0 -> mask $ \release -> do
188+ -- A unique tag is picked so that different runFail handlers don't catch each
189+ -- other's exceptions.
190+ tag <- newUnique
191+ size0 <- sizeEnv es0
192+ es <- unsafeConsEnv (IdE (Fail tag)) noRelinker es0
193+ r <- tryFailIO tag (release $ unEff m es) `onException` unsafeTailEnv size0 es
194+ _ <- unsafeTailEnv size0 es
195+ pure r
196+
197+instance Fail :> es => MonadFail (Eff es) where
198+ fail msg = readerEffectM $ \(IdE (Fail tag)) -> unsafeEff_ $ do
199+ throwM $ FailEx tag msg
200+
201+--------------------
202+
203+data FailEx = FailEx Unique String
204+instance Show FailEx where
205+ showsPrec p (FailEx _ msg)
206+ = ("Effectful.Internal.Monad.FailEx " ++)
207+ . showsPrec p msg
208+instance Exception FailEx
209+
210+tryFailIO :: Unique -> IO a -> IO (Either String a)
211+tryFailIO tag m =
212+ (Right <$> m) `catch` \err@(FailEx etag msg) -> do
213+ if tag == etag
214+ then pure $ Left msg
215+ else throwM err
216+
175217----------------------------------------
176218-- IO
177219