From bce1613a2de9cce953eec8a86c47ca400dc2d485 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 3 Jul 2020 13:38:20 -0400 Subject: [PATCH 1/5] Depend on fused-effects@master. --- cabal.project | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/cabal.project b/cabal.project index e6fdbad..4661747 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,6 @@ packages: . + +source-repository-package + type: git + location: https://github.com/fused-effects/fused-effects.git + tag: e677228b1f9c69a9378c3f33ea9ca798b06831d3 From 4d63df6eb35a3d6fe02a19a0d33e195c3b8862f5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 3 Jul 2020 13:39:05 -0400 Subject: [PATCH 2/5] Add the stylish-haskell config. --- .stylish-haskell.yaml | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 .stylish-haskell.yaml diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..c8406d0 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,33 @@ +steps: + - simple_align: + cases: true + top_level_patterns: true + records: true + + - imports: + align: file + list_align: after_alias + pad_module_names: false + long_list_align: new_line_multiline + empty_list_align: inherit + list_padding: 2 + separate_lists: false + space_surround: false + + - language_pragmas: + style: vertical + align: false + remove_redundant: true + + - tabs: + spaces: 2 + + - trailing_whitespace: {} + +columns: 120 + +newline: native + +language_extensions: +- FlexibleContexts +- MultiParamTypeClasses From f478f9bffbe84cab7da33be8c5abfbe42ec35a3f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 3 Jul 2020 13:42:20 -0400 Subject: [PATCH 3/5] Update Control.Carrier.State.IORef. --- src/Control/Carrier/State/IORef.hs | 31 +++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/src/Control/Carrier/State/IORef.hs b/src/Control/Carrier/State/IORef.hs index f9a26b9..b60b1a0 100644 --- a/src/Control/Carrier/State/IORef.hs +++ b/src/Control/Carrier/State/IORef.hs @@ -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.Carrier.State.IORef , 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 @@ execState s = fmap fst . runState s 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 #-} From e3a3dae17c89c427760eb53d996fc640311c898e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 3 Jul 2020 13:44:08 -0400 Subject: [PATCH 4/5] Update all the uses of liftWith for the new ordering. --- src/Control/Effect/Exception.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Control/Effect/Exception.hs b/src/Control/Effect/Exception.hs index 05e571e..9978fac 100644 --- a/src/Control/Effect/Exception.hs +++ b/src/Control/Effect/Exception.hs @@ -92,13 +92,13 @@ throwTo thread = sendM . Exc.throwTo thread -- -- @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 @@ catchJust -> 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 @@ evaluate = sendM . Exc.evaluate -- -- @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 @@ mask_ m = mask $ const m -- -- @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 @@ getMaskingState = sendM Exc.getMaskingState -- -- @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'@. -- From aaaee45efc9453e797a191be937b81a8d8fc149f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 8 Jul 2020 11:09:01 -0400 Subject: [PATCH 5/5] Bump to 1.1. --- cabal.project | 5 ----- fused-effects-exceptions.cabal | 2 +- 2 files changed, 1 insertion(+), 6 deletions(-) diff --git a/cabal.project b/cabal.project index 4661747..e6fdbad 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1 @@ packages: . - -source-repository-package - type: git - location: https://github.com/fused-effects/fused-effects.git - tag: e677228b1f9c69a9378c3f33ea9ca798b06831d3 diff --git a/fused-effects-exceptions.cabal b/fused-effects-exceptions.cabal index 0c1035a..2f922c2 100644 --- a/fused-effects-exceptions.cabal +++ b/fused-effects-exceptions.cabal @@ -33,7 +33,7 @@ library Control.Effect.Exception build-depends: base >= 4.7 && < 5 - , fused-effects >= 1 + , fused-effects >= 1.1 , transformers >= 0.4 && < 0.6 test-suite test