编码单子变换器的选择

Question

> {-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
> {-# LANGUAGE ConstraintKinds, DerivingVia, DerivingStrategies, GeneralizedNewtypeDeriving, KindSignatures, NoMonomorphismRestriction, RecordWildCards #-}
> {-# LANGUAGE GADTs, QuantifiedConstraints, RankNTypes #-}
> import Control.Monad.Identity
> import Control.Monad.IO.Class
> import Control.Monad.Trans.Reader
> import Control.Monad.Trans.State
> import Control.Monad.Trans.Class
> import Control.Monad.Trans.Control
> import Data.Time.Clock (NominalDiffTime, diffUTCTime)
> import qualified Data.Time.Clock as Time

有时可能需要动态拦截或更改一元效应的行为。 为了使事情具体化，让我们假设一个允许声明成本中心的效果：

> class Monad m => MonadCostCenter m where
>   registerCostCenter :: Name -> m a -> m a

一种可能的实现为成本中心的每个开始/完成事件生成日志行：

> newtype ViaLogging m a = ViaLogging {runViaLogging :: m a}
>   deriving (Applicative, Functor, Monad, MonadIO) via (IdentityT m)
>   deriving MonadTrans via IdentityT

> instance MonadLog m => MonadCostCenter (ViaLogging m) where
>   registerCostCenter name action = do
>     ViaLogging $ logMsg ("Starting cost center " <> name)
>     res <- action
>     ViaLogging $ logMsg ("Completed cost center" <> name)
>     return res

另一种可能性是收集数据结构中的所有时间以供以后处理：

> data Timing = Timing {name :: String, duration :: NominalDiffTime}

> newtype CollectTimingsT m a = CollectTimingsT (StateT [Timing] m a)
>   deriving newtype (Applicative, Functor, Monad, MonadIO, MonadTrans, MonadTransControl)

> runCollectTimings :: Monad m => ([Timing] -> m ()) -> CollectTimingsT m a -> m a
> runCollectTimings doSomethingWithTimings (CollectTimingsT action) = do
>   (res, timings) <- runStateT action []
>   doSomethingWithTimings timings
>   return res

> instance MonadTime m => MonadCostCenter (CollectTimingsT m) where
>   registerCostCenter name action = do
>     startTime <- CollectTimingsT $ lift getCurrentTime
>     res <- action
>     endTime <- CollectTimingsT $ lift getCurrentTime
>     let duration = diffUTCTime endTime startTime
>     CollectTimingsT $ modify (Timing{..} :)
>     return res

假设我们的应用程序是一个网络服务，它不关心收集时间，除非 正在处理的请求明确要求。我们的代码如下所示：

> type HandlerMonad = WebT (CostCenterT (LogT (TimeT IO)))
>
> runHandler :: HandlerMonad a -> IO a
> runHandler = undefined

但是CostCenterT 的类型是什么？我们不是说这取决于要求吗？ 是的，我们希望根据请求以不同的方式处理成本中心， 但是 Haskell 类型系统要求 carrier HandlerMonad 的类型是固定的。 可以使用基于Either 的运营商对该选择进行显式编码：

> type HandlerMonad' = WebT (EitherT ViaLogging CollectTimingsT (LogT (TimeT IO)))
>
> newtype EitherT t1 t2 (m :: * -> *) a = EitherT {runEitherT :: Either (t1 m a) (t2 m a)}

EitherT 样板的其余部分（实例、运行函数）并不漂亮，留给读者作为练习。 有没有更好的办法？

效果解释器

上述问题不适用于polysemy等一些效果系统， 没有明确的载体。具有显式载体的效果系统，例如 fused-effects transformers 可以通过定义Interpreter 转换器来解决这个问题。 实际上，fused-effects 包括 monad 转换器 Control.Effect.Interpret.InterpretC s sig 可用于拦截由底层 monad m 实现的效果 sig。

我们可以为 vanilla transformers 定义一个类似的抽象，如下所示：

> newtype InterpretT c m a = InterpretT (ReaderT (Interpreter c m) m a)
>   deriving (Applicative, Functor, Monad, MonadIO)
>
> instance MonadTrans (InterpretT c) where
>   lift = InterpretT . lift
>
> data Interpreter c (m :: * -> *) where
>   Interpreter :: c (t m) => (forall a . t m a -> m a) -> Interpreter c m
>
> runInterpretT :: Interpreter c m -> InterpretT c m a -> m a
> runInterpretT run (InterpretT action) = runReaderT action run
>
> wrapEffect :: Monad m => (forall m . c m => m a) -> InterpretT c m a
> wrapEffect action = InterpretT $ do
>   Interpreter run <- ask
>   lift (run action)

现在我们可以定义HandlerMonad和runHandler如下：

> type HandlerMonad'' = InterpretT MonadCostCenter (WebT (LogT (TimeT IO)))
>
> runHandler'' = runTimeT
>              . runLogT
>              . runWebT
>              . runInterpretT (if True then Interpreter runViaLogging else Interpreter (runCollectTimings sendTimings))

动态效果解释器

上面的解决方案适用于简单的动态，但有时我们想改变 或在计算中扩展解释器。比如：

> localInterpreter :: (Interpreter c m -> Interpreter c m) -> InterpretT c m a -> InterpretT c m a
> localInterpreter f (InterpretT action) = InterpretT $ local f action

这几乎是有用的，除了没有实际的方法可以委托给 以前的口译员。它只允许覆盖：

> switchToCollectTimings :: ([Timing -> m ()]) -> HandlerMonad'' a -> HandlerMonad'' a
> switchToCollectTimings doTimings = localInterpreter (const $ Interpreter $ runCollectTimings sendTimings)

为了启用委托，我们不得不求助于另一个 monad 转换器：

> newtype Both (t1 :: (* -> *) -> * -> *) t2 (m :: * -> *) a = Both {runBoth :: t1 (t2 m) a}
>   deriving (Applicative, Functor, Monad, MonadIO)

> instance (forall m . Monad m => Monad (t2 m), MonadTrans t2, MonadTrans t1) => MonadTrans (Both t1 t2) where
>   lift = Both . lift . lift

> instance (forall n. Monad n =>
>          (MonadCostCenter (t1 n)
>          ,MonadCostCenter (t2 n)
>          ,Monad (t1 n)
>          ,Monad (t2 n))
>          ,MonadTransControl t1
>          ,Monad m
>          ) => MonadCostCenter (Both t1 t2 m) where
>   registerCostCenter name (Both action) = Both
>     $ registerCostCenter name
>     $ liftWith (\runInT2 -> registerCostCenter name (runInT2 action)) >>= restoreT . return

现在我们几乎可以写出下面的函数了：

> class (MonadTime m, MonadCostCenter m) => MonadCostCenterTime m
> instance (MonadTime m, MonadCostCenter m) => MonadCostCenterTime m

> type HandlerMonad''' = InterpretT MonadCostCenterTime (WebT (LogT (TimeT IO)))

> addTimingsCollection :: (forall m . MonadTime m => [Timing] -> m ()) -> HandlerMonad''' a -> HandlerMonad''' a
> addTimingsCollection doTimings = localInterpreter $ \(Interpreter delegate) ->
>    Interpreter (delegate . runCollectTimings doTimings . runBoth)

但是它失败并出现以下类型错误，其中instance MonadCostCenter CollectTimingsT 引入MonadTime 约束，GHC 需要委托解释器提供它的证据。 我们知道确实如此，因为它满足 MonadCostCenterTime 包括 MonadTime，但对于某些 原因检查的类型不接受这个。

    * Could not deduce (MonadIO n) arising from a use of `Interpreter'
      from the context: MonadCostCenterTime (t (WebT (LogT (TimeT IO))))
        bound by a pattern with constructor:
                   Interpreter :: forall (c :: (* -> *) -> Constraint) (t :: (* -> *)
                                                                             -> * -> *) (m :: *
                                                                                              -> *).
                                  c (t m) =>
                                  (forall a. t m a -> m a) -> Interpreter c m,
                 in a lambda abstraction
        at interpreter.lhs:161:57-76
      or from: Monad n
        bound by a quantified context at interpreter.lhs:1:1
      Possible fix:
        add (MonadIO n) to the context of a quantified context
    * In the expression:
        Interpreter (delegate . runCollectTimings doTimings . runBoth)
      In the second argument of `($)', namely
        `\ (Interpreter delegate)
           -> Interpreter (delegate . runCollectTimings doTimings . runBoth)'
      In the expression:
        localInterpreter
          $ \ (Interpreter delegate)
              -> Interpreter (delegate . runCollectTimings doTimings . runBoth)
    |
162 | >    Interpreter (delegate . runCollectTimings doTimings . runBoth)
    |      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Answer 1

如果您将instance MonadCostCenter (Both t1 t2 m) 上的超类上下文简化为所需的最小值：

instance (MonadTransControl t1, MonadCostCenter (t2 m), MonadCostCenter (t1 (t2 m)))
         => MonadCostCenter (Both t1 t2 m) where
  registerCostCenter name (Both action) = ...

它似乎在进行类型检查。像@luqui 一样，我迷失在类型中，所以我无法确切了解为什么原始代码不起作用。