2 
> {-# 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。实际上，融合效果包括 monadControl.Effect.Interpret.InterpretC s sig 转换器，可用于拦截sig由底层 monad 实现的效果m。

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

> 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 要求提供委托解释器提供它的证据。我们知道它确实如此，因为它满足MonadCostCenterTimewhich includes 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)
    |      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
4

1 回答 1

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 一样，我迷失在类型中，所以我不明白为什么原始代码不起作用。

于 2019-12-15T16:08:57.473 回答