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 Control.Effect.Exception
build-depends: build-depends:
base >= 4.7 && < 5 base >= 4.7 && < 5
, fused-effects >= 1 , fused-effects >= 1.1
, transformers >= 0.4 && < 0.6 , transformers >= 0.4 && < 0.6
test-suite test 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'. {- | 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,8 +22,8 @@ module Control.Carrier.State.IORef
, module Control.Effect.State , module Control.Effect.State
) where ) where
import Control.Applicative (Alternative (..))
import Control.Algebra import Control.Algebra
import Control.Applicative (Alternative(..))
import Control.Carrier.Reader import Control.Carrier.Reader
import Control.Effect.State import Control.Effect.State
import Control.Monad (MonadPlus(..)) import Control.Monad (MonadPlus(..))
@ -62,11 +70,12 @@ execState s = fmap fst . runState s
newtype StateC s m a = StateC { runStateC :: ReaderC (IORef s) m a } newtype StateC s m a = StateC { runStateC :: ReaderC (IORef s) m a }
deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus) 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 instance (MonadIO m, Algebra sig m) => Algebra (State s :+: sig) (StateC s m) where
alg (L act) = do alg hdl sig ctx = case sig of
ref <- StateC ask L act -> do
case act of ref <- StateC (ask @(IORef s))
Put s k -> liftIO (writeIORef ref s) *> k (<$ ctx) <$> case act of
Get k -> liftIO (readIORef ref) >>= k Put s -> liftIO (writeIORef ref s)
alg (R other) = StateC (alg (R (handleCoercible other))) Get -> liftIO (readIORef ref)
R other -> StateC (alg (runStateC . hdl) (R other) ctx)
{-# INLINE alg #-} {-# INLINE alg #-}

View File

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