Merge pull request #1 from IxpertaSolutions/evalstate-execstate

Added evalState and execState

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

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
   ]
 
 --------------------------------------------------------------------------------

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