{-# LANGUAGE AllowAmbiguousTypes #-}

-- |
-- Module:       Control.Monad.Freer.State
-- Description:  State effects, for state-carrying computations.
-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King
-- License:      BSD3
-- Maintainer:   Alexis King <lexi.lambda@gmail.com>
-- Stability:    experimental
-- Portability:  GHC specific language extensions.
--
-- Composable handler for 'State' effects. Handy for passing an updatable state
-- through a computation.
--
-- Some computations may not require the full power of 'State' effect:
--
-- * For a read-only state, see "Control.Monad.Freer.Reader".
-- * To accumulate a value without using it on the way, see
--   "Control.Monad.Freer.Writer".
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.State
  ( -- * State Effect
    State(..)

    -- * State Operations
  , get
  , put
  , modify
  , gets

    -- * State Handlers
  , runState
  , evalState
  , execState

    -- * State Utilities
  , transactionState
  , transactionState'
  ) where

import Data.Proxy (Proxy)

import Control.Monad.Freer (Eff, Member, send)
import Control.Monad.Freer.Internal (Arr, handleRelayS, interposeS)

-- | Strict 'State' effects: one can either 'Get' values or 'Put' them.
data State s r where
  Get :: State s s
  Put :: !s -> State s ()

-- | Retrieve the current value of the state of type @s :: *@.
get :: forall s effs. Member (State s) effs => Eff effs s
get :: Eff effs s
get = State s s -> Eff effs s
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send State s s
forall s. State s s
Get

-- | Set the current state to a specified value of type @s :: *@.
put :: forall s effs. Member (State s) effs => s -> Eff effs ()
put :: s -> Eff effs ()
put s
s = State s () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (s -> State s ()
forall s. s -> State s ()
Put s
s)

-- | Modify the current state of type @s :: *@ using provided function
-- @(s -> s)@.
modify :: forall s effs. Member (State s) effs => (s -> s) -> Eff effs ()
modify :: (s -> s) -> Eff effs ()
modify s -> s
f = (s -> s) -> Eff effs s -> Eff effs s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> s
f Eff effs s
forall s (effs :: [* -> *]). Member (State s) effs => Eff effs s
get Eff effs s -> (s -> Eff effs ()) -> Eff effs ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
s -> Eff effs ()
put

-- | Retrieve a specific component of the current state using the provided
-- projection function.
gets :: forall s a effs. Member (State s) effs => (s -> a) -> Eff effs a
gets :: (s -> a) -> Eff effs a
gets s -> a
f = s -> a
f (s -> a) -> Eff effs s -> Eff effs a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff effs s
forall s (effs :: [* -> *]). Member (State s) effs => Eff effs s
get

-- | Handler for 'State' effects.
runState :: forall s effs a. s -> Eff (State s ': effs) a -> Eff effs (a, s)
runState :: s -> Eff (State s : effs) a -> Eff effs (a, s)
runState s
s0 = s
-> (s -> a -> Eff effs (a, s))
-> (forall v.
    s -> State s v -> (s -> Arr effs v (a, s)) -> Eff effs (a, s))
-> Eff (State s : effs) a
-> Eff effs (a, s)
forall s a (effs :: [* -> *]) b (eff :: * -> *).
s
-> (s -> a -> Eff effs b)
-> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
-> Eff (eff : effs) a
-> Eff effs b
handleRelayS s
s0 (\s
s a
x -> (a, s) -> Eff effs (a, s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x, s
s)) ((forall v.
  s -> State s v -> (s -> Arr effs v (a, s)) -> Eff effs (a, s))
 -> Eff (State s : effs) a -> Eff effs (a, s))
-> (forall v.
    s -> State s v -> (s -> Arr effs v (a, s)) -> Eff effs (a, s))
-> Eff (State s : effs) a
-> Eff effs (a, s)
forall a b. (a -> b) -> a -> b
$ \s
s State s v
x s -> Arr effs v (a, s)
k -> case State s v
x of
  State s v
Get -> s -> Arr effs v (a, s)
k s
s s
v
s
  Put s' -> s -> Arr effs v (a, s)
k s
s' ()

-- | Run a 'State' effect, returning only the final state.
execState :: forall s effs a. s -> Eff (State s ': effs) a -> Eff effs s
execState :: s -> Eff (State s : effs) a -> Eff effs s
execState s
s = ((a, s) -> s) -> Eff effs (a, s) -> Eff effs s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, s) -> s
forall a b. (a, b) -> b
snd (Eff effs (a, s) -> Eff effs s)
-> (Eff (State s : effs) a -> Eff effs (a, s))
-> Eff (State s : effs) a
-> Eff effs s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Eff (State s : effs) a -> Eff effs (a, s)
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs (a, s)
runState s
s

-- | Run a State effect, discarding the final state.
evalState :: forall s effs a. s -> Eff (State s ': effs) a -> Eff effs a
evalState :: s -> Eff (State s : effs) a -> Eff effs a
evalState s
s = ((a, s) -> a) -> Eff effs (a, s) -> Eff effs a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, s) -> a
forall a b. (a, b) -> a
fst (Eff effs (a, s) -> Eff effs a)
-> (Eff (State s : effs) a -> Eff effs (a, s))
-> Eff (State s : effs) a
-> Eff effs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Eff (State s : effs) a -> Eff effs (a, s)
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs (a, s)
runState s
s

-- | An encapsulated State handler, for transactional semantics. The global
-- state is updated only if the 'transactionState' finished successfully.
--
-- GHC cannot infer the @s@ type parameter for this function, so it must be
-- specified explicitly with @TypeApplications@. Alternatively, it can be
-- specified by supplying a 'Proxy' to 'transactionState''.
transactionState
  :: forall s effs a
   . Member (State s) effs
  => Eff effs a
  -> Eff effs a
transactionState :: Eff effs a -> Eff effs a
transactionState Eff effs a
m = do
    s
s0 <- forall (effs :: [* -> *]). Member (State s) effs => Eff effs s
forall s (effs :: [* -> *]). Member (State s) effs => Eff effs s
get @s
    (a
x, s
s) <- s
-> (s -> a -> Eff effs (a, s))
-> (forall v.
    s -> State s v -> (s -> Arr effs v (a, s)) -> Eff effs (a, s))
-> Eff effs a
-> Eff effs (a, s)
forall (eff :: * -> *) (effs :: [* -> *]) s a b.
Member eff effs =>
s
-> (s -> a -> Eff effs b)
-> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
-> Eff effs a
-> Eff effs b
interposeS s
s0 (\s
s a
x -> (a, s) -> Eff effs (a, s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x, s
s)) forall v.
s -> State s v -> (s -> Arr effs v (a, s)) -> Eff effs (a, s)
forall v b. s -> State s v -> (s -> Arr effs v b) -> Eff effs b
handle Eff effs a
m
    s -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
s -> Eff effs ()
put s
s
    a -> Eff effs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  where
    handle :: s -> State s v -> (s -> Arr effs v b) -> Eff effs b
    handle :: s -> State s v -> (s -> Arr effs v b) -> Eff effs b
handle s
s State s v
x s -> Arr effs v b
k = case State s v
x of
      State s v
Get -> s -> Arr effs v b
k s
s s
v
s
      Put s
s' -> s -> Arr effs v b
k s
s' ()

-- | Like 'transactionState', but @s@ is specified by providing a 'Proxy'
-- instead of requiring @TypeApplications@.
transactionState'
  :: forall s effs a
   . Member (State s) effs
  => Proxy s
  -> Eff effs a
  -> Eff effs a
transactionState' :: Proxy s -> Eff effs a -> Eff effs a
transactionState' Proxy s
_ = forall (effs :: [* -> *]) a.
Member (State s) effs =>
Eff effs a -> Eff effs a
forall s (effs :: [* -> *]) a.
Member (State s) effs =>
Eff effs a -> Eff effs a
transactionState @s
{-# INLINE transactionState' #-}