fc8a196 · effectful · git.iko.soy

effectful.cabal+1

compare with master

unifiedsplit

@@ -71,6 +71,7 @@ library

71 Effectful.Class.State

72 Effectful.Class.Writer

73 Effectful.Error

74+ Effectful.Fail

74 Effectful.Internal.Effect

75 Effectful.Internal.Effect

75 Effectful.Internal.Env

76 Effectful.Internal.Env

76 Effectful.Internal.Monad

77 Effectful.Internal.Monad

src/Effectful/Error.hs+8−9

@@ -65,7 +65,7 @@ throwError

65 => e

66 -> Eff es a

67throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do

68− throwIO $ WrapErr tag callStack e

68+ throwIO $ ErrorEx tag callStack e

69

70catchError

71 :: forall e es a. (Typeable e, Error e :> es)

@@ -88,19 +88,18 @@ tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)

88----------------------------------------

89-- Helpers

90

91−data WrapErr e = WrapErr Unique CallStack e

91+data ErrorEx e = ErrorEx Unique CallStack e

92−

93−instance Typeable e => Show (WrapErr e) where

92+instance Typeable e => Show (ErrorEx e) where

94− showsPrec p (WrapErr _ cs e)

93+ showsPrec p (ErrorEx _ cs e)

95− = showsPrec p "Effectful.Error.WrapErr ("

94+ = ("Effectful.Error.ErrorEx (" ++)

96 . showsPrec p (typeOf e)

95 . showsPrec p (typeOf e)

97− . showsPrec p ") "

96+ . (") " ++)

98 . showsPrec p cs

97 . showsPrec p cs

99−instance Typeable e => Exception (WrapErr e)

98+instance Typeable e => Exception (ErrorEx e)

100

99

101catchErrorIO :: Typeable e => Unique -> IO a -> (CallStack -> e -> IO a) -> IO a

100catchErrorIO :: Typeable e => Unique -> IO a -> (CallStack -> e -> IO a) -> IO a

102catchErrorIO tag m handler = do

101catchErrorIO tag m handler = do

103− m `catch` \err@(WrapErr etag e cs) -> do

102+ m `catch` \err@(ErrorEx etag e cs) -> do

104 if tag == etag

103 if tag == etag

105 then handler e cs

104 then handler e cs

106 else throwIO err

105 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

17 , unsafeEff_

18 , unsafeUnliftEff

19

20+ -- * Fail

21+ , Fail

22+ , runFail

23+

20 -- * IO

24 -- * IO

21 , IOE

25 , IOE

22 , runIOE

26 , runIOE

@@ -45,6 +49,7 @@ import Control.Monad.Fix

45import Control.Monad.IO.Class

49import Control.Monad.IO.Class

46import Control.Monad.IO.Unlift

50import Control.Monad.IO.Unlift

47import Control.Monad.Trans.Control

51import Control.Monad.Trans.Control

52+import Data.Unique

48import GHC.Magic (oneShot)

53import GHC.Magic (oneShot)

49import System.IO.Unsafe (unsafeDupablePerformIO)

54import System.IO.Unsafe (unsafeDupablePerformIO)

50

55

@@ -172,6 +177,43 @@ instance MonadMask (Eff es) where

172 c <- unEff (release resource $ ExitCaseSuccess b) es

177 c <- unEff (release resource $ ExitCaseSuccess b) es

173 pure (b, c)

178 pure (b, c)

174

179

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+

175----------------------------------------

217----------------------------------------

176-- IO

218-- IO

177

219