Merge pull request #15 from fused-effects/distributive-algebra

Distributive algebra
main
Rob Rix 2020-07-08 13:34:33 -04:00 committed by GitHub
commit 6dc3043254
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
4 changed files with 62 additions and 20 deletions

33
.stylish-haskell.yaml Normal file
View File

@ -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

View File

@ -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

View File

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

View File

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