编码单台变压器的选择

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

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

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

但是CostCenterT类型是什么呢？我们不是说这要看要求吗？是的，我们想根据不同的请求处理不同的成本中心，但是Haskell类型的系统要求运营商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样板的其余部分(实例、运行函数)并不好看，而是留给读者的练习。有更好的办法吗？

效果口译员

上述问题不适用于某些效应系统，如多义词，其中没有明确的载体。像熔融效应和变压器这样的显式载流子的效应系统可以通过定义一个Interpreter变压器来解决这个问题。事实上，融合效应包括单基因转染的Control.Effect.Interpret.InterpretC s sig，它可以用来拦截由底层的monad m实现的效果sig。

我们可以为香草变压器定义如下类似的抽象：

> 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)

为了使代表团能够得到授权，我们不得不求助于另一个单一变压器：

> 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一样，我在类型中迷失了方向，所以我不知道为什么原始代码不能工作。