State.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Description: The 'State' effect
module Polysemy.State
  ( -- * Effect
    State (..)

    -- * Actions
  , get
  , gets
  , put
  , modify
  , modify'

    -- * Interpretations
  , runState
  , evalState
  , execState
  , runLazyState
  , evalLazyState
  , execLazyState
  , runStateIORef
  , stateToIO
  , runStateSTRef
  , stateToST

    -- * Interoperation with MTL
  , hoistStateIntoStateT
  ) where

import Control.Monad.ST
import qualified Control.Monad.Trans.State as S
import Data.IORef
import Data.STRef
import Data.Tuple (swap)
import Polysemy
import Polysemy.Internal
import Polysemy.Internal.Combinators
import Polysemy.Internal.Union


------------------------------------------------------------------------------
-- | An effect for providing statefulness. Note that unlike mtl's
-- 'Control.Monad.Trans.State.StateT', there is no restriction that the 'State'
-- effect corresponds necessarily to /local/ state. It could could just as well
-- be interrpeted in terms of HTTP requests or database access.
--
-- Interpreters which require statefulness can 'Polysemy.reinterpret'
-- themselves in terms of 'State', and subsequently call 'runState'.
data State s m a where
  -- | Get the state.
  Get :: State s m s
  -- | Update the state.
  Put :: s -> State s m ()

makeSem ''State


------------------------------------------------------------------------------
-- | Apply a function to the state and return the result.
gets :: forall s a r. Member (State s) r => (s -> a) -> Sem r a
gets f = f <$> get
{-# INLINABLE gets #-}


------------------------------------------------------------------------------
-- | Modify the state.
modify :: Member (State s) r => (s -> s) -> Sem r ()
modify f = do
  s <- get
  put $ f s
{-# INLINABLE modify #-}

------------------------------------------------------------------------------
-- | A variant of 'modify' in which the computation is strict in the
-- new state.
modify' :: Member (State s) r => (s -> s) -> Sem r ()
modify' f = do
  s <- get
  put $! f s
{-# INLINABLE modify' #-}


------------------------------------------------------------------------------
-- | Run a 'State' effect with local state.
runState :: s -> Sem (State s ': r) a -> Sem r (s, a)
runState = stateful $ \case
  Get   -> \s -> pure (s, s)
  Put s -> const $ pure (s, ())
{-# INLINE[3] runState #-}


------------------------------------------------------------------------------
-- | Run a 'State' effect with local state.
--
-- @since 1.0.0.0
evalState :: s -> Sem (State s ': r) a -> Sem r a
evalState s = fmap snd . runState s
{-# INLINE evalState #-}

------------------------------------------------------------------------------
-- | Run a 'State' effect with local state.
--
-- @since 1.2.3.1
execState :: s -> Sem (State s ': r) a -> Sem r s
execState s = fmap fst . runState s
{-# INLINE execState #-}



------------------------------------------------------------------------------
-- | Run a 'State' effect with local state, lazily.
runLazyState :: s -> Sem (State s ': r) a -> Sem r (s, a)
runLazyState = lazilyStateful $ \case
  Get   -> \s -> pure (s, s)
  Put s -> const $ pure (s, ())
{-# INLINE[3] runLazyState #-}

------------------------------------------------------------------------------
-- | Run a 'State' effect with local state, lazily.
--
-- @since 1.0.0.0
evalLazyState :: s -> Sem (State s ': r) a -> Sem r a
evalLazyState s = fmap snd . runLazyState s
{-# INLINE evalLazyState #-}


------------------------------------------------------------------------------
-- | Run a 'State' effect with local state, lazily.
--
-- @since 1.2.3.1
execLazyState :: s -> Sem (State s ': r) a -> Sem r s
execLazyState s = fmap fst . runLazyState s
{-# INLINE execLazyState #-}



------------------------------------------------------------------------------
-- | Run a 'State' effect by transforming it into operations over an 'IORef'.
--
-- /Note/: This is not safe in a concurrent setting, as 'modify' isn't atomic.
-- If you need operations over the state to be atomic,
-- use 'Polysemy.AtomicState.runAtomicStateIORef' or
-- 'Polysemy.AtomicState.runAtomicStateTVar' instead.
--
-- @since 1.0.0.0
runStateIORef
    :: forall s r a
     . Member (Embed IO) r
    => IORef s
    -> Sem (State s ': r) a
    -> Sem r a
runStateIORef ref = interpret $ \case
  Get   -> embed $ readIORef ref
  Put s -> embed $ writeIORef ref s
{-# INLINE runStateIORef #-}

--------------------------------------------------------------------
-- | Run an 'State' effect in terms of operations
-- in 'IO'.
--
-- Internally, this simply creates a new 'IORef', passes it to
-- 'runStateIORef', and then returns the result and the final value
-- of the 'IORef'.
--
-- /Note/: This is not safe in a concurrent setting, as 'modify' isn't atomic.
-- If you need operations over the state to be atomic,
-- use 'Polysemy.AtomicState.atomicStateToIO' instead.
--
-- /Beware/: As this uses an 'IORef' internally,
-- all other effects will have local
-- state semantics in regards to 'State' effects
-- interpreted this way.
-- For example, 'Polysemy.Error.throw' and 'Polysemy.Error.catch' will
-- never revert 'put's, even if 'Polysemy.Error.runError' is used
-- after 'stateToIO'.
--
-- @since 1.2.0.0
stateToIO
    :: forall s r a
     . Member (Embed IO) r
    => s
    -> Sem (State s ': r) a
    -> Sem r (s, a)
stateToIO s sem = do
  ref <- embed $ newIORef s
  res <- runStateIORef ref sem
  end <- embed $ readIORef ref
  return (end, res)
{-# INLINE stateToIO #-}

------------------------------------------------------------------------------
-- | Run a 'State' effect by transforming it into operations over an 'STRef'.
--
-- @since 1.3.0.0
runStateSTRef
    :: forall s st r a
     . Member (Embed (ST st)) r
    => STRef st s
    -> Sem (State s ': r) a
    -> Sem r a
runStateSTRef ref = interpret $ \case
  Get   -> embed $ readSTRef ref
  Put s -> embed $ writeSTRef ref s
{-# INLINE runStateSTRef #-}

--------------------------------------------------------------------
-- | Run an 'State' effect in terms of operations
-- in 'ST'.
--
-- Internally, this simply creates a new 'STRef', passes it to
-- 'runStateSTRef', and then returns the result and the final value
-- of the 'STRef'.
--
-- /Beware/: As this uses an 'STRef' internally,
-- all other effects will have local
-- state semantics in regards to 'State' effects
-- interpreted this way.
-- For example, 'Polysemy.Error.throw' and 'Polysemy.Error.catch' will
-- never revert 'put's, even if 'Polysemy.Error.runError' is used
-- after 'stateToST'.
--
-- When not using the plugin, one must introduce the existential @st@ type to
-- 'stateToST', so that the resulting type after 'runM' can be resolved into
-- @forall st. ST st (s, a)@ for use with 'runST'. Doing so requires
-- @-XScopedTypeVariables@.
--
-- @
-- stResult :: forall s a. (s, a)
-- stResult = runST ( (runM $ stateToST \@_ \@st undefined $ pure undefined) :: forall st. ST st (s, a) )
-- @
--
-- @since 1.3.0.0
stateToST
    :: forall s st r a
     . Member (Embed (ST st)) r
    => s
    -> Sem (State s ': r) a
    -> Sem r (s, a)
stateToST s sem = do
  ref <- embed @(ST st) $ newSTRef s
  res <- runStateSTRef ref sem
  end <- embed $ readSTRef ref
  return (end, res)
{-# INLINE stateToST #-}

------------------------------------------------------------------------------
-- | Hoist a 'State' effect into a 'S.StateT' monad transformer. This can be
-- useful when writing interpreters that need to interop with MTL.
--
-- @since 0.1.3.0
hoistStateIntoStateT
    :: Sem (State s ': r) a
    -> S.StateT s (Sem r) a
hoistStateIntoStateT (Sem m) = m $ \u ->
  case decomp u of
    Left x -> S.StateT $ \s ->
      liftSem . fmap swap
              . weave (s, ())
                      (\(s', m') -> swap <$> S.runStateT m' s')
                      (Just . snd)
              $ hoist hoistStateIntoStateT x
    Right (Weaving Get z _ y _)     -> y . (<$ z) <$> S.get
    Right (Weaving (Put s) z _ y _) -> y . (<$ z) <$> S.put s
{-# INLINE hoistStateIntoStateT #-}


{-# RULES "runState/reinterpret"
   forall s e (f :: forall m x. e m x -> Sem (State s ': r) x).
     runState s (reinterpret f e) = stateful (\x s' -> runState s' $ f x) s e
     #-}

{-# RULES "runLazyState/reinterpret"
   forall s e (f :: forall m x. e m x -> Sem (State s ': r) x).
     runLazyState s (reinterpret f e) = lazilyStateful (\x s' -> runLazyState s' $ f x) s e
     #-}