From f0045d9d6ce023752f8b0e22cba02eb5080c1ffa Mon Sep 17 00:00:00 2001
From: Sam Quinn <lazersmoke@gmail.com>
Date: Sat, 21 Jan 2017 10:36:50 -0600
Subject: [PATCH] Added evalState and execState

---
 src/Control/Monad/Freer/State.hs | 10 ++++++++++
 tests/Tests.hs                   |  4 ++++
 tests/Tests/State.hs             | 16 +++++++++++++++-
 3 files changed, 29 insertions(+), 1 deletion(-)

diff --git a/src/Control/Monad/Freer/State.hs b/src/Control/Monad/Freer/State.hs
index 572e0ac..cf6331d 100644
--- a/src/Control/Monad/Freer/State.hs
+++ b/src/Control/Monad/Freer/State.hs
@@ -25,6 +25,8 @@ module Control.Monad.Freer.State (
   put,
   modify,
   runState,
+  evalState,
+  execState,
 
   transactionState
 ) where
@@ -61,6 +63,14 @@ runState (E u q) s = case decomp u of
   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 ': r) w -> s -> Eff r s
+execState st s = snd <$> runState st s
+
+-- | Run a State effect, discarding the final state
+evalState :: Eff (State s ': r) w -> s -> Eff r w
+evalState st s = fst <$> runState st s
+
 
 -- |
 -- An encapsulated State handler, for transactional semantics
diff --git a/tests/Tests.hs b/tests/Tests.hs
index 128147d..cebe841 100644
--- a/tests/Tests.hs
+++ b/tests/Tests.hs
@@ -125,6 +125,10 @@ stateTests = testGroup "State tests"
     \p1 p2 start -> testPutGetPutGetPlus p1 p2 start == testPutGetPutGetPlusRW p1 p2 start
   , testProperty "testGetStart: State == StateRW" $
     \n -> testGetStart n == testGetStartRW n
+  , testProperty "testEvalState: evalState discards final state" $
+    \n -> testEvalState n == n
+  , testProperty "testExecState: execState returns final state" $
+    \n -> testExecState n == n
   ]
 
 --------------------------------------------------------------------------------
diff --git a/tests/Tests/State.hs b/tests/Tests/State.hs
index 5c52eb8..157824c 100644
--- a/tests/Tests/State.hs
+++ b/tests/Tests/State.hs
@@ -2,7 +2,9 @@
 module Tests.State (
   testPutGet,
   testPutGetPutGetPlus,
-  testGetStart
+  testGetStart,
+  testEvalState,
+  testExecState
 ) where
 
 import Control.Monad.Freer
@@ -23,3 +25,15 @@ testPutGetPutGetPlus p1 p2 start = run (runState go start)
 
 testGetStart :: Int -> (Int,Int)
 testGetStart = run . runState get
+
+testEvalState :: Int -> Int
+testEvalState = run . evalState go
+  where
+    go = do
+      x <- get
+      -- destroy the previous state
+      put (0 :: Int)
+      return x
+
+testExecState :: Int -> Int
+testExecState n = run $ execState (put n) 0