Joshua Potter 2022-04-02 11:05:39 -04:00
parent 82d0d51810
commit c699bee3df
3 changed files with 0 additions and 89 deletions

View File

@ -31,7 +31,6 @@ library
import: common import: common
hs-source-dirs: src hs-source-dirs: src
exposed-modules: exposed-modules:
Control.Carrier.State.IORef
Control.Effect.Exception Control.Effect.Exception
Control.Effect.Exception.UnliftIO Control.Effect.Exception.UnliftIO
other-modules: other-modules:

View File

@ -1,81 +0,0 @@
{-# 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'.
Note that the parameter order in 'runState', 'evalState', and 'execState' is reversed compared the equivalent functions provided by @transformers@. This is an intentional decision made to enable the composition of effect handlers with '.' without invoking 'flip'.
-}
module Control.Carrier.State.IORef
( -- * Strict state carrier
runState
, evalState
, execState
, StateC(..)
-- * State effect
, module Control.Effect.State
) where
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.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.IORef
-- | Run a 'State' effect starting from the passed value.
--
-- prop> run (runState a (pure b)) === (a, b)
--
-- @since 1.0.0.0
runState :: MonadIO m => s -> StateC s m a -> m (s, a)
runState s x = do
ref <- liftIO $ newIORef s
result <- runReader ref . runStateC $ x
final <- liftIO . readIORef $ ref
pure (final, result)
{-# INLINE[3] runState #-}
-- | Run a 'State' effect, yielding the result value and discarding the final state.
--
-- prop> run (evalState a (pure b)) === b
--
-- @since 1.0.0.0
evalState :: forall s m a . MonadIO m => s -> StateC s m a -> m a
evalState s x = do
ref <- liftIO $ newIORef s
runReader ref . runStateC $ x
{-# INLINE[3] evalState #-}
-- | Run a 'State' effect, yielding the final state and discarding the return value.
--
-- prop> run (execState a (pure b)) === a
--
-- @since 1.0.0.0
execState :: forall s m a . MonadIO m => s -> StateC s m a -> m s
execState s = fmap fst . runState s
{-# INLINE[3] execState #-}
-- | @since 1.0.0.0
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) => 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

@ -6,7 +6,6 @@ module Main where
import Prelude hiding (ioError) import Prelude hiding (ioError)
import Control.Carrier.Lift (runM) import Control.Carrier.Lift (runM)
import qualified Control.Carrier.State.IORef as IOState
import qualified Control.Carrier.State.Strict as State import qualified Control.Carrier.State.Strict as State
import Control.Effect.Exception import Control.Effect.Exception
import Control.Effect.State import Control.Effect.State
@ -23,16 +22,10 @@ testStateDropsWrites = HUnit.testCase "State.Strict drops writes" $ do
result <- State.execState 'a' problematic result <- State.execState 'a' problematic
result HUnit.@?= 'a' -- writes are lost result HUnit.@?= 'a' -- writes are lost
testIOStatePreservesWrites :: Tasty.TestTree
testIOStatePreservesWrites = HUnit.testCase "State.IORef preserves writes" $ do
result <- IOState.execState 'a' problematic
result HUnit.@?= 'x'
tests :: Tasty.TestTree tests :: Tasty.TestTree
tests = Tasty.testGroup "Control.Carrier.Exception" tests = Tasty.testGroup "Control.Carrier.Exception"
[ Tasty.testGroup "finally" [ Tasty.testGroup "finally"
[ testStateDropsWrites [ testStateDropsWrites
, testIOStatePreservesWrites
] ]
] ]