Using free monads to test Redis calls

Question

I am trying to follow this blog post in order to separate the execution of Redis requests from their usage by using free monads. I made some small changes to the code provided in order to use hedis as the Redis client and the changes seem to type check. Unfortunately I have not been able to find or write a type class instance that satisfies the type constraints for the runTest and runRedis functions and I get the following error when I call runTest with foo.

No instance for (Control.Monad.State.Class.MonadState FakeDB IO)

Storage/Types.hs

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

module Storage.Types where

import Control.Monad.Free
import Control.Monad.Free.TH

data RedisCmd next = Get' String (Maybe String -> next) |
                     Set' String String next      |
                     Multi' (RedisCmdM ()) next deriving (Functor)

type RedisCmdM = Free RedisCmd

makeFree ''RedisCmd

Storage/Implementations.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}

module Storage.Implementations where

import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.Free
import Control.Monad.Free.TH
import Data.Functor
import Data.Map (Map)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import qualified Data.Map as M
import qualified Database.Redis as R
import Storage.Types

runDebug :: RedisCmdM a -> IO a
runDebug = iterM run
  where
    run :: RedisCmd (IO a) -> IO a
    run (Get' k f) = do
      putStrLn $ unwords ["GET", k]
      f . Just =<< getLine
    run (Set' k v n) = do
      putStrLn $ unwords ["SET", k, v]
      n
    run (Multi' txn n) = do
      putStrLn "MULTI"
      runDebug txn
      putStrLn "EXEC"
      n

-- newtype FakeDB = FakeDB { insideFDB :: Map String String }
type FakeDB = Map String String

-- instance (MonadIO m) => MonadState R.Connection m where
--   get = lift get
--   put = lift . put

runTest :: MonadState FakeDB m => RedisCmdM a -> m a
runTest = iterM run
  where
    run (Get' k f) = f =<< gets (M.lookup k)
    run (Set' k v n) = do
      modify $ M.insert k v
      n
    run (Multi' txn n) = do
      runTest txn
      n

getC :: R.Connection -> String -> IO (Maybe String)
getC c k = R.runRedis c (getRedis k)

getRedis :: String -> R.Redis (Maybe String)
getRedis k = convert <$> (R.get . C8.pack) k
  where
   convert (Left _)  = Nothing
   convert (Right r) = C8.unpack <$> r

setC :: R.Connection -> String -> String -> IO ()
setC c k v = do
  _ <- R.runRedis c $ R.set (C8.pack k) (C8.pack v)
  return ()

multi :: R.Connection -> (RedisCmdM ()) -> IO ()
multi = undefined

db :: IO R.Connection
db = R.connect R.defaultConnectInfo

runRedis :: (MonadState R.Connection m, MonadIO m) => RedisCmdM a -> m a
runRedis rcmd = withConn $ \c -> (iterM (run c) rcmd)
  where
    run :: R.Connection -> RedisCmd (IO a) -> IO a
    run c (Get' k f) = f =<< getC c k
    run c (Set' k v n) = setC c k v >> n
    run c (Multi' txn n) = undefined --multi c txn >> n
    withConn action = liftIO (join (action <$> db))

Main.hs

{-# LANGUAGE OverloadedStrings #-}

import Storage.Types
import Storage.Implementations (runDebug, runTest, runRedis)

foo :: RedisCmdM ()
foo = do
  mv <- get' "foo"
  case mv of
    Nothing -> return ()
    Just v -> multi' $ do
      set' "foo1" v
      set' "foo2" v

main = do
  runTest foo

Answer 1

Look at the type signature for runTest: it returns a value in a monad m as long as m is a MonadState FakeDB. So when you call runTest you need to bind it into such a monad, which IO is not (that's what the error message is telling you). Try runStateT (runTest foo) Map.empty (which creates such a monadic context in its first argument).