free-monad-testing-interpreter.md

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}

module Main where

import Control.Monad.Free
import Control.Monad.Free.TH
import Control.Monad.State
import qualified Data.Map as M
import Prelude hiding (read)

type ID = String

data User = User
  { userId :: ID
  , userName :: String
  } deriving (Show, Eq)

data Users next
  = FindUser ID
             (Maybe User -> next)
  | InsertUser User
               next
  | UpdateUser User
               next
  deriving (Functor)

makeFree ''Users

upsertUser :: User -> Free Users ()
upsertUser user = do
  existing <- findUser (userId user)
  case existing of
    Nothing -> insertUser user
    Just e -> updateUser user

type FakeDB = State (M.Map ID User)

interpret' :: Free Users r -> FakeDB ()
interpret' (Free (FindUser uid n)) = do
  map' <- get
  interpret' $ n (M.lookup uid map')
interpret' (Free (InsertUser user n)) = do
  map' <- get
  put $ M.insert (userId user) user map'
  interpret' n
interpret' (Free (UpdateUser user n)) = do
  map' <- get
  put $ M.adjust (const user) (userId user) map'
  interpret' n
interpret' (Pure r) = return ()

main = do
  let user = User {userId = "5", userName = "Jim"}
  let actual =
        execState
          (interpret' $ upsertUser user)
          (M.fromList [("5", User {userId = "5", userName = "John"})])
  print $ actual == M.fromList [("5", User {userId = "5", userName = "Jim"})]