将 MonadReader/MonadError 实例添加到转换器类型

Question

与使用 Happstack 时一样，我一直在制作自己的服务器 monad 用于处理程序，以覆盖我的数据库和会话，以及一些错误处理。我最近发现了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派生不起作用。但我需要这些，否则整个表演就有点没用了。

由于我从未能够弄清楚这些是如何完成的（并且依赖于deriving），我想要一个涵盖这个特定问题的答案，并告诉我它是如何完成的。

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 和更多。再加上一些其他的变化，这些变化稍微破坏了事情，但总体上使事情变得更好。

现在还有一个演示目录：

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

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

Answer 2

newtype派生机制期望ClientSessionT具有所需类型类的实例。 我在您链接到的 haddock 文档中没有看到ClientSessionT具有MonadError或MonadReader实例的位置. 追逐类型类约束（例如Happstack）也不会显示MonadError或'MonadReader的实例。

一般机制记录在GHC用户指南的第7.5节中。 这个想法是，对于类型类CanBark和数据类型Dog的实例（即 instance CanBark Dog where ... ），围绕Dog DomesticDog的 newtype 包装器可以通过搜索和替换Dog来自动访问CanBark Dog DomesticDog。