haskell - 编码单子变换器的选择
问题描述
> {-# 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 要求提供委托解释器提供它的证据。我们知道它确实如此,因为它满足MonadCostCenterTime
which 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)
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
解决方案
如果您将超类上下文简化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 一样,我迷失在类型中,所以我不明白为什么原始代码不起作用。
推荐阅读
- flutter - 如何为颤振列表视图中的每个项目提供自定义(id || 键)?
- javascript - 我想在元素不再具有特定类时调用函数(没有 jquery)
- android - Firebase如何为当前用户启用保存提示?
- java - 不推荐使用 RequestContext 类型的方法 update(String)
- python - asyncio:仅当所有其他任务都在等待时才运行任务
- swift - 寻找使用钥匙串和数据加密保存数据的正确方法 - Swift 5
- python - GRequests 猴子补丁警告
- javascript - 在两个略有不同的字符串中找到相同的位置
- php - Laravel whereNotIn 加上 whereIn 不等于总数
- python - 函数偶尔返回无,但如果我打印返回它似乎很好