haskell - 将 MonadReader/MonadError 实例添加到 Transformer 类型

Question

与使用 Happstack 时一样，我一直在制作自己的服务器 monad 用于处理程序，以覆盖我的数据库和 session ，以及一些错误处理。我最近发现了happstack-clientsession -这个包很有帮助，并且阻止我编写自己的解决方案。

尽管在 ClientSessionT monad 中连接到我自己的单子(monad)有点麻烦。事实证明，它没有 MonadReader 或 MonadError 实例，因此我无法在包装器 monad 中实例化它们。

这是该模块的完整代码:

{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, DeriveDataTypeable, EmptyDataDecls, TemplateHaskell #-}
module Server where

import Control.Monad
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.Trans
import Data.Data (Data, Typeable)
import Data.SafeCopy (base, deriveSafeCopy)
import Database.MongoDB as M
import Happstack.Server
import Happstack.Server.Error
import Happstack.Server.ClientSession
import System.IO.Pool
import System.IO.Error
import Web.ClientSession (getDefaultKey)

type MongoPool e = Pool e Pipe

data PonySession = PonySession -- TODO: Fill in User type when available
    deriving (Ord, Read,Show, Eq, Typeable, Data)
$(deriveSafeCopy 0 'base ''PonySession)

instance ClientSession PonySession where
    empty = PonySession

newtype PonyServerPartT e m a = PonyServerPart (ClientSessionT PonySession (ReaderT (MongoPool IOError) (ServerPartT (ErrorT e m))) a)
    deriving (Monad, MonadIO, MonadReader (MongoPool e), MonadError e, ServerMonad, MonadPlus)

type PonyServerPart = PonyServerPartT IOError IO

runServerT s = mapServerPartT' (spUnwrapErrorT errorHandler) $ do
    key <- liftIO getDefaultKey
    let sessConf = (mkSessionConf key) { sessionCookieLife = MaxAge $ 60 * 60 * 24 * 7 }
    pool <- liftIO mongoPool
    runReaderT (runClientSessionT s sessConf) pool
    where errorHandler = simpleErrorHandler . show

mongoPool :: IO (MongoPool IOError)
mongoPool = newPool fac 10
    where fac = Factory {
            newResource = connect $ M.host "127.0.0.1",
            killResource = close,
            isExpired = isClosed
        }

我得到的错误很明显:从 MonadError 和 MonadReader 派生不起作用。但我需要这些，否则整个表演就没啥用了。

由于我一直无法弄清楚这些是如何完成的(并且依赖于推导)，因此我想要一个涵盖这个特定问题并告诉我它是如何实现的答案一般完成。

Answer 1

理论上，您可以编写类似这样的内容，但您不能这样做，因为 ClientSessionT 构造函数和 'unClientSessionT` 函数未导出:

instance (Monad m, MonadError e m) => MonadError e (ClientSessionT st m) where
    throwError = ClientSessionT . throwError
    catchError (ClientSessionT m) f =
        ClientSessionT $ ReaderT $ \r -> StateT $ \s ->
          (runStateT (runReaderT m r) s) `catchError` (\e -> runStateT (runReaderT (unClientSessionT (f e)) r) s)

instance (Functor m, Monad m, MonadReader r m) => MonadReader r (ClientSessionT st m) where
    ask = ClientSessionT $ lift $ lift ask
    local f (ClientSessionT m) = ClientSessionT $ mapReaderT (mapStateT (local f)) m

手动编写这些类型的实例非常机械——您会看到一些模式一次又一次出现。 (这就是为什么编译器在大多数情况下可以弄清楚如何自动执行此操作)。

在这种情况下，最好的解决办法是向作者提示缺少实例。

darcs 版本现在包括 MonadError、MonadReader 等。再加上其他一些改变，这些改变会稍微破坏一些东西，但总体上会让事情变得更好。

现在还有一个 demo 目录:

http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-clientsession

我可能会在一两天内发布它，进行一些小的更改和更多评论。