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 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 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 #-} 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'@. --