如何使`co-log` 的`withLog` 与`Scotty` 一起工作？

问题描述

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

这是一个包含代码的存储库，您可以为最小测试用例运行这些代码：https://github.com/cideM/co_log_issue

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

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

我不知道如何编写这个实例。

我正在尝试比较 co-log 和 Katip。我有一个 Scotty 路由处理程序（更准确地说，它是处理程序的包装器）并且在该处理程序内部我想修改我的应用程序环境中的日志操作。此处的用例是添加到记录器的上下文中，以便所有后续日志操作都自动添加字符串或类似内容。

这是处理程序的相关部分：

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() 并且我无法在同一范围内解除它。我有一个类似的 issue with katip。

由于 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

即使没有那个错误，我也不确定它是否可以派生出来。我试图只处理转储的派生实例（即使结果代码没有编译），但我最终无法使其工作：

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

我没有想法了。

解决方法

您尝试做的事情可能是不可能的，至少在目前的假设下是这样，但我很乐意被证明是错误的。

介绍

让我们先说这个错误：

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 是我们操作的 monad。你有：

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 的 ActionT（和 LogAction），但仅用于基础 monad 并且无法“升级”它，因为它已嵌入应用程序中。

我们能做什么？

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

setLogAction 是纯的，我们需要构造只有 msg -> m () 的 msg -> ActionT e 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,MonadReader env (t b))
  => (LogAction (t b) msg -> LogAction (t b) msg) -> (t b) a -> (t b) a
allegedlySafeUselessWithLog = veryUnsafeWithLog

deriving haskell haskell scotty