对选择的 monad 转换器进行编码
Encoding a choice of monad transformers
> {-# 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
一种可能的实现为成本中心的每个 start/complete 事件生成日志行：
> 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 样板文件的其余部分（实例，运行 函数）并不漂亮，留作 reader 的练习。
有没有更好的方法？
效果解释器
上述问题不适用于某些效果系统，如 polysemy，
没有明确载体的地方。具有显式载体的效果系统，例如 fused-effects
transformers 可以通过定义 Interpreter transformer 来解决这个问题。
事实上，fused-effects 包括 monad transfomer 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)
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
如果将 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 一样，我迷失在类型中，所以我看不出为什么原始代码不起作用。
> {-# 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
一种可能的实现为成本中心的每个 start/complete 事件生成日志行：
> 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 样板文件的其余部分（实例，运行 函数）并不漂亮，留作 reader 的练习。
有没有更好的方法？
效果解释器
上述问题不适用于某些效果系统，如 polysemy，
没有明确载体的地方。具有显式载体的效果系统，例如 fused-effects
transformers 可以通过定义 Interpreter transformer 来解决这个问题。
事实上，fused-effects 包括 monad transfomer 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)
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
如果将 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 一样，我迷失在类型中，所以我看不出为什么原始代码不起作用。