2

無料のモナドを使用して、Redis リクエストの実行とその使用を分離するために、このブログ投稿をフォローしようとしています。hedis を Redis クライアントとして使用するために提供されたコードに小さな変更を加えましたが、その変更はタイプ チェックのようです。残念ながら、runTest および runRedis 関数の型制約を満たす型クラス インスタンスを見つけることも書き込むこともできず、foo で runTest を呼び出すと次のエラーが発生します。

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

ストレージ/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

ストレージ/実装.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
4

1 に答える 1

1

の型シグネチャを見てください: である限りrunTest、モナドの値を返します。したがって、runTest を呼び出すときは、それをそのようなモナドにバインドする必要がありますが、そうではありません (それはエラー メッセージが伝えていることです)。試してください(最初の引数でそのようなモナド コンテキストを作成します)。mmMonadState FakeDBIOrunStateT (runTest foo) Map.empty

于 2015-04-06T18:10:13.240 に答える