Church Free monad based State

StateLangSpec.hs

module StateLangSpec where

import Test.Hspec
import Data.IORef
import Control.Monad.Free.Church


data StateMethod s next
  = Put s (() -> next)
  | Get (s -> next)
  | PrintIO String (() -> next)

instance Functor (StateMethod s) where
  fmap f (Put st next) = Put st (f . next)
  fmap f (Get next)    = Get (f . next)
  fmap f (PrintIO val next) = PrintIO val (f . next)

type FreePoweredState s a = F (StateMethod s) a

put :: s -> FreePoweredState s ()
put st = liftF (Put st id)

get :: FreePoweredState s s
get = liftF (Get id)

printIO :: Show a => a -> FreePoweredState s ()
printIO val = liftF (PrintIO (show val) id)

interpretStateMethod :: IORef s -> StateMethod s a -> IO a
interpretStateMethod stRef (Put st next) = do
  writeIORef stRef st
  pure (next ())

interpretStateMethod stRef (Get next) = do
  st <- readIORef stRef
  pure (next st)

interpretStateMethod stRef (PrintIO val next) = do
  putStrLn val
  pure (next ())



runFreePoweredState :: FreePoweredState s a -> s -> IO (s, a)
runFreePoweredState scenario st = do
  stRef <- newIORef st
  res <- foldF (interpretStateMethod stRef) scenario
  st' <- readIORef stRef
  pure (st', res)


myStatefulScenario :: FreePoweredState Int Int
myStatefulScenario = do
  printIO "Hello world!"
  st1 <- get
  printIO ("Current state: " <> show st1)
  put 42
  st2 <- get
  printIO ("New state: " <> show st2)
  pure (st1 + st2)

spec :: Spec
spec =
  describe "Church-Free powered State eDSL test" $ do
    it "Stateful scenario test" $ do
      (st, res) <- runFreePoweredState myStatefulScenario 58
      st `shouldBe` 42
      res `shouldBe` 100

-- Test passes.

-- Output:

-- StateLang
-- Church-Free powered State eDSL test
-- "Hello world!"
-- "Current state: 58"
-- "New state: 42"
-- Stateful scenario test