main
parent
82d0d51810
commit
c699bee3df
|
@ -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:
|
||||||
|
|
|
@ -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 #-}
|
|
|
@ -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
|
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue