fused-effects-exceptions 1.0.0.0 → 1.1.0.0

raw patch · 5 files changed

+39/−25 lines, 5 filesdep ~fused-effectsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: fused-effects

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• fused-effects-exceptions.cabal +4/−3
• src/Control/Carrier/State/IORef.hs +20/−11
• src/Control/Effect/Exception.hs +8/−8
• test/Main.hs +2/−3

@@ -1,3 +1,8 @@+# 1.1.0.0++* Port to fused-effects 1.1.++ # 1.0.0.0  * Port to fused-effects 1.0.

@@ -1,7 +1,7 @@ cabal-version:       2.4  name:                fused-effects-exceptions-version:             1.0.0.0+version:             1.1.0.0 synopsis:            Handle exceptions thrown in IO with fused-effects. description:         Provides Resource and Catch effects capable of reacting to and catching GHC's dynamic exceptions. homepage:            https://github.com/fused-effects/fused-effects-exceptions#readme@@ -20,7 +20,8 @@   GHC == 8.2.2   GHC == 8.4.4   GHC == 8.6.5-  GHC == 8.8.1+  GHC == 8.8.3+  GHC == 8.10.1  common common   default-language: Haskell2010@@ -33,7 +34,7 @@     Control.Effect.Exception   build-depends:       base             >= 4.7 && < 5-    , fused-effects    >= 1+    , fused-effects    >= 1.1     , transformers     >= 0.4 && < 0.6  test-suite test

@@ -1,4 +1,12 @@-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}  {- | A carrier for the 'State' effect. It uses an 'IORef' internally to handle its state, and thus is safe to use with "Control.Carrier.Resource". Underlying 'IORef' operations are performed with 'readIORef' and 'writeIORef'. @@ -14,12 +22,12 @@ , module Control.Effect.State ) where -import           Control.Applicative       (Alternative (..)) import           Control.Algebra+import           Control.Applicative (Alternative(..)) import           Control.Carrier.Reader import           Control.Effect.State-import           Control.Monad             (MonadPlus (..))-import qualified Control.Monad.Fail        as Fail+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.Fail as Fail import           Control.Monad.Fix import           Control.Monad.IO.Class import           Control.Monad.Trans.Class@@ -62,11 +70,12 @@ newtype StateC s m a = StateC { runStateC :: ReaderC (IORef s) m a }   deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus) -instance (MonadIO m, Algebra sig m, Effect sig) => Algebra (State s :+: sig) (StateC s m) where-  alg (L act) = do-    ref <- StateC ask-    case act of-      Put s k -> liftIO (writeIORef ref s) *> k-      Get k   -> liftIO (readIORef ref) >>= k-  alg (R other) = StateC (alg (R (handleCoercible other)))+instance (MonadIO m, Algebra sig m) => Algebra (State s :+: sig) (StateC s m) where+  alg hdl sig ctx = case sig of+    L act -> do+      ref <- StateC (ask @(IORef s))+      (<$ ctx) <$> case act of+        Put s -> liftIO (writeIORef ref s)+        Get   -> liftIO (readIORef ref)+    R other -> StateC (alg (runStateC . hdl) (R other) ctx)   {-# INLINE alg #-}

@@ -92,13 +92,13 @@ -- -- @since 1.0.0.0 catch :: (Exc.Exception e, Has (Lift IO) sig m) => m a -> (e -> m a) -> m a-catch m h = liftWith $ \ ctx run -> run (m <$ ctx) `Exc.catch` (run . (<$ ctx) . h)+catch m h = liftWith $ \ run ctx -> run (m <$ ctx) `Exc.catch` (run . (<$ ctx) . h)  -- | See @"Control.Exception".'Exc.catches'@. -- -- @since 1.0.0.0 catches :: Has (Lift IO) sig m => m a -> [Handler m a] -> m a-catches m hs = liftWith $ \ ctx run ->+catches m hs = liftWith $ \ run ctx ->   Exc.catches (run (m <$ ctx)) (map (\ (Handler h) -> Exc.Handler (run . (<$ ctx) . h)) hs)  -- | See @"Control.Exception".'Exc.Handler'@.@@ -118,7 +118,7 @@   -> m a   -> (b -> m a)   -> m a-catchJust p m h = liftWith $ \ ctx run -> Exc.catchJust p (run (m <$ ctx)) (run . (<$ ctx) . h)+catchJust p m h = liftWith $ \ run ctx -> Exc.catchJust p (run (m <$ ctx)) (run . (<$ ctx) . h)  -- | See @"Control.Exception".'Exc.handle'@. --@@ -159,8 +159,8 @@ -- -- @since 1.0.0.0 mask :: Has (Lift IO) sig m => ((forall a . m a -> m a) -> m b) -> m b-mask with = liftWith $ \ ctx run -> Exc.mask $ \ restore ->-  run (with (\ m -> liftWith $ \ ctx' run' -> restore (run' (m <$ ctx'))) <$ ctx)+mask with = liftWith $ \ run ctx -> Exc.mask $ \ restore ->+  run (with (\ m -> liftWith $ \ run' ctx' -> restore (run' (m <$ ctx'))) <$ ctx)  -- | See @"Control.Exception".'Exc.mask_'@. --@@ -172,8 +172,8 @@ -- -- @since 1.0.0.0 uninterruptibleMask :: Has (Lift IO) sig m => ((forall a . m a -> m a) -> m b) -> m b-uninterruptibleMask with = liftWith $ \ ctx run -> Exc.uninterruptibleMask $ \ restore ->-  run (with (\ m -> liftWith $ \ ctx' run' -> restore (run' (m <$ ctx'))) <$ ctx)+uninterruptibleMask with = liftWith $ \ run ctx -> Exc.uninterruptibleMask $ \ restore ->+  run (with (\ m -> liftWith $ \ run' ctx' -> restore (run' (m <$ ctx'))) <$ ctx)  -- | See @"Control.Exception".'Exc.uninterruptibleMask_'@. --@@ -191,7 +191,7 @@ -- -- @since 1.0.0.0 interruptible :: Has (Lift IO) sig m => m a -> m a-interruptible m = liftWith $ \ ctx run -> Exc.interruptible (run (m <$ ctx))+interruptible m = liftWith $ \ run ctx -> Exc.interruptible (run (m <$ ctx))  -- | See @"Control.Exception".'Exc.allowInterrupt'@. --

@@ -19,12 +19,12 @@  testStateDropsWrites :: Tasty.TestTree testStateDropsWrites = HUnit.testCase "State.Strict drops writes" $ do-  result <- State.execState 'a' $ problematic+  result <- State.execState 'a' problematic   result HUnit.@?= 'a' -- writes are lost  testIOStatePreservesWrites :: Tasty.TestTree testIOStatePreservesWrites = HUnit.testCase "State.IORef preserves writes" $ do-  result <- IOState.execState 'a' $ problematic+  result <- IOState.execState 'a' problematic   result HUnit.@?= 'x'  tests :: Tasty.TestTree@@ -37,4 +37,3 @@  main :: IO () main = Tasty.defaultMain tests-