如何使“共同登录”与“`Scotty`”一起工作？

Question

我已经在Reddit上问过了，但想寻求更广泛的帮助。

下面是一个包含代码的存储库，您可以为一个最小的测试用例运行它：问题

如果您运行stack build，您将得到：

    • Could not deduce (HasLog
                          (AppEnv App) Message (Scotty.ActionT TL.Text m))

我不知道怎么写这个例子。

我试着比较co-log和Katip。我有一个Scotty路由处理程序(更确切地说，它是一个处理程序的包装器)，在处理程序的内部，我想在我的app环境中修改日志操作。这里的用例将添加到记录器的上下文中，这样所有后续的日志操作都会自动地加上一个字符串，或者类似的内容。

下面是处理程序的相关部分：

withSession ::
  ( WithLog (AppEnv App) Message m,
    MonadIO m
  ) =>
  SQLite.Connection ->
  (Session -> Scotty.ActionT TL.Text m ()) ->
  Scotty.ActionT TL.Text m () ->
  Scotty.ActionT TL.Text m ()
withSession dbConn handler defaultAction =
  withLog (cmap (\(msg :: Message) -> msg {msgText = "foo"})) $ do
    log I "Hi"
    sessionCookie <- Scotty.getCookie "lions-session"
    ...

但是，withLog函数会导致一个错误：

• Occurs check: cannot construct the infinite type:
    m ~ Scotty.ActionT TL.Text m
  Expected type: Scotty.ActionT TL.Text m ()
    Actual type: Scotty.ActionT TL.Text (Scotty.ActionT TL.Text m) ()

这是有意义的，因为do块中withLog之后的所有内容都是Scotty.ActionT TL.Text m()，而我不能在相同的范围内提升它。我有一个类似的katip。

由于GHC错误，我无法导出实例，因为GHC错误给出了：

The exact Name ‘f’ is not in scope
  Probable cause: you used a unique Template Haskell name (NameU),
  perhaps via newName, but did not bind it
  If that's it, then -ddump-splices might be useful

即使没有那个bug，我也不确定它是否可以派生。我试图只使用转储派生实例(即使结果代码没有编译)，但最终无法使其工作：

deriving instance HasLog (AppEnv App) Message (Scotty.ActionT TL.Text App)

给我

instance HasLog (AppEnv App) Message (Scotty.ActionT TL.Text App) where
  getLogAction
    = coerce
        @(AppEnv App -> LogAction (ExceptT (Scotty.ActionError TL.Text) (ReaderT Scotty.ActionEnv (StateT Scotty.ScottyResponse App))) Message)
        @(AppEnv App -> LogAction (Scotty.ActionT TL.Text App) Message)
        (getLogAction
           @(AppEnv App) @Message
           @(ExceptT (Scotty.ActionError TL.Text) (ReaderT Scotty.ActionEnv (StateT Scotty.ScottyResponse App)))) ::
          AppEnv App -> LogAction (Scotty.ActionT TL.Text App.App) Message

这是失踪

No instance for (HasLog
                     (AppEnv App)
                     Message
                     (ExceptT
                        (Scotty.ActionError TL.Text)
                        (ReaderT Scotty.ActionEnv (StateT Scotty.ScottyResponse App))))

而且我无法推导出

deriving instance HasLog (AppEnv App) Message (ExceptT (Scotty.ActionError TL.Text) (ReaderT Scotty.ActionEnv (StateT Scotty.ScottyResponse App)))

Can't make a derived instance of
    ‘HasLog
       (AppEnv App)
       Message
       (ExceptT
          (Scotty.ActionError TL.Text)
          (ReaderT Scotty.ActionEnv (StateT Scotty.ScottyResponse App)))’
    (even with cunning GeneralizedNewtypeDeriving):
    cannot eta-reduce the representation type enough

我没有主意了。

Answer 1

你想要做的事情也许是不可能的，至少在目前的假设下是这样，但是我很乐意被证明是错误的。

简介

让我们首先说这个错误：

Could not deduce (HasLog (AppEnv App) Message (ActionT e m))

应该让我们停下来，因为它说我们在ActionT e App中运行，但是只有LogAction App Message。LogAction m msg是msg -> m ()的包装器，因此为了为这个实例编写getLogAction和setLogAction，我们需要一个iso：

get :: (msg -> m ()) -> (msg -> ActionT e m ()) -- fmap lift
set :: (msg -> ActionT e m ()) -> (msg -> m ()) -- ?

我们是怎么陷入这场混乱的？

来自Colog.Monad

type WithLog env msg m = (MonadReader env m, HasLog env msg m, HasCallStack) 

withLog :: WithLog env msg m => (LogAction m msg -> LogAction m msg) -> m a -> m a 

它将m和env紧紧地结合在一起，其中m是我们操作的单体。你有：

newtype App a = App {unApp :: AppEnv App -> IO a}
  deriving (MonadReader (AppEnv App)) via ReaderT (AppEnv App) IO

App和AppEnv App紧紧结合在一起。到目前一切尚好。在scotty中，我们有ActionT e m，它实现：

(MonadReader r m, ScottyError e) => MonadReader r (ActionT e m)

这基本上解除了m的操作。ActionT实际上是假装它有一个env，而实际上将所有东西都委托给了m。但是呢，哦，这和上面的两个观测结果不完全一致，这就是为什么会产生这个麻烦的错误。我们希望有一个env (和LogAction)专门为ActionT，但只有它的基础单，不能“升级”，因为它是烘焙到应用程序。

我们能做什么？

instance (Monad m) => HasLog (AppEnv m) Message (ActionT e m) where
  getLogAction = liftLogAction . logAction
  setLogAction newact env = _ -- ?

setLogAction是纯的，我们需要构造只有msg -> ActionT e m ()的msg -> m ()。我很确定这是不可能的

我们还能做什么？

在精神上如果这是愚蠢但有效的..。

data AppEnv = AppEnv
  { appLogAction :: LogAction App Message
  , actLogAction :: LogAction (ActionT TL.Text App) Message
  }

instance HasLog AppEnv Message App where
  getLogAction = appLogAction
  setLogAction newact env = env { appLogAction = newact }

instance HasLog AppEnv Message (ActionT TL.Text App) where
  getLogAction = actLogAction
  setLogAction newact env = env { actLogAction = newact }

没有测试。

我们还能做什么？

当然不是这样：

instance (Monad m) => HasLog (AppEnv m) Message (ActionT TL.Text m) where
  getLogAction = liftLogAction . logAction
  setLogAction newact = id -- who needs the co in colog anyway?

veryUnsafeWithLog
  :: ( MonadTrans t
     , MonadBaseControl b (t b)
     , WithLog env msg b
     , MonadReader env (t b))
  => (LogAction (t b) msg -> LogAction (t b) msg) -> (t b) a -> (t b) a
veryUnsafeWithLog f act = do
  LogAction newlog <- asks (f . liftLogAction . getLogAction)
  x <- liftBaseWith $ \rib -> do
    pure $ LogAction $ \msg -> void $ rib (newlog msg) -- discards state!
  local (setLogAction x) act

allegedlySafeUselessWithLog
  :: ( StM (t b) a ~ StM b a -- not satisfied for ActionT
     , MonadTrans t
     , MonadBaseControl b (t b)
     , WithLog env msg b
     , MonadReader env (t b))
  => (LogAction (t b) msg -> LogAction (t b) msg) -> (t b) a -> (t b) a
allegedlySafeUselessWithLog = veryUnsafeWithLog