State.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module:       Control.Monad.Freer.State
-- Description:  State effects, for state-carrying computations.
-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.
-- License:      BSD3
-- Maintainer:   ixcom-core@ixperta.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

    -- * State Handlers
    , runState
    , evalState
    , execState

    -- * State Utilities
    , transactionState
    )
  where

import Control.Monad ((>>), (>>=), return)
import Data.Either (Either(Left, Right))
import Data.Functor ((<$>), fmap)
import Data.Maybe (Maybe(Just))
import Data.Proxy (Proxy)
import Data.Tuple (fst, snd)

import Control.Monad.Freer.Internal
    ( Eff(E, Val)
    , Member
    , Union
    , decomp
    , prj
    , qApp
    , qComp
    , send
    , tsingleton
    )


--------------------------------------------------------------------------------
                         -- State, strict --
--------------------------------------------------------------------------------

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

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

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

-- | Modify the current state of type @s :: *@ using provided function
-- @(s -> s)@.
modify :: Member (State s) effs => (s -> s) -> Eff effs ()
modify f = fmap f get >>= put

-- | Handler for 'State' effects.
runState :: Eff (State s ': effs) a -> s -> Eff effs (a, s)
runState (Val x) s = return (x, s)
runState (E u q) s = case decomp u of
    Right Get      -> runState (qApp q s) s
    Right (Put s') -> runState (qApp q ()) s'
    Left  u'       -> E u' (tsingleton (\x -> runState (qApp q x) s))

-- | Run a 'State' effect, returning only the final state.
execState :: Eff (State s ': effs) a -> s -> Eff effs s
execState st s = snd <$> runState st s

-- | Run a State effect, discarding the final state.
evalState :: Eff (State s ': effs) a -> s -> Eff effs a
evalState st s = fst <$> runState st s

-- | An encapsulated State handler, for transactional semantics. The global
-- state is updated only if the 'transactionState' finished successfully.
transactionState
    :: forall s effs a
    .  Member (State s) effs
    => Proxy s
    -> Eff effs a
    -> Eff effs a
transactionState _ m = do s <- get; loop s m
  where
    loop :: s -> Eff effs a -> Eff effs a
    loop s (Val x)                = put s >> return x
    loop s (E (u :: Union r b) q) = case prj u :: Maybe (State s b) of
        Just Get      -> loop s (qApp q s)
        Just (Put s') -> loop s'(qApp q ())
        _             -> E u (tsingleton k) where k = qComp q (loop s)