How to make `co-log`'s `withLog` work with `Scotty`?

Question

I already asked on Reddit but wanted to ask a wider circle for help.

Here's a repository with code that you can run for a minimal test case: https://github.com/cideM/co_log_issue

If you run stack build you'll get:

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

and I don't know how to write this instance.

I'm trying to compare co-log and Katip. I have a Scotty route handler (more precisely it's a wrapper for a handler) and inside of that handler I want to modify the log action in my app environment. The use case here would be to add to the context of the logger so that all subsequent log actions are automatically prepended with a string, or something like that.

Here's the relevant part of the handler:

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"
    ...

The withLog function causes an error though:

• 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) ()

which makes sense, since everything in the do block after withLog is Scotty.ActionT TL.Text m() and I can't lift that in the same scope. I had a similar issue with katip.

I can't derive the instance due to a GHC bug which gives me:

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

even without that bug I'm not sure if it can be derived though. I tried to just work with the dumped derived instances (even if the resulting code didn't compile) but I couldn't make it work in the end:

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

gives me

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

which is missing

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

and that I can't derive

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

I'm out of ideas.

Answer 1

What you're trying to do may be impossible, at least with the current assumptions, but I would be happy to be proven wrong.

Intro

Lets start by saying that this error:

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

should give us pause because it says we are operating in ActionT e App but only have LogAction App Message. LogAction m msg is a wrapper around msg -> m (), so in order to write getLogAction and setLogAction for this instance we require an iso:

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

How did we get into this mess?

From 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 

which tightly couples m and env where m is the monad we operate in. You have:

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

which tightly couples App and AppEnv App. So far so good. In scotty we have ActionT e m which implements:

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

that basically lifts operations in m. ActionT is sort of pretending it has an env while really delegating everything to m. But uh oh, that is not quite compatible with the two observations above and this is how the troubling error arises. We would like to have an env (and LogAction) specifically for ActionT but only have it for the base monad and cannot "upgrade" it because it's baked into App.

What can we do?

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

setLogAction is pure and we need to construct msg -> m () having only msg -> ActionT e m (). I'm pretty sure this is not possible :(

What else can we do?

In the spirit of if it's stupid but works...

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 }

Did not test.

What else-else can we do?

Surely not this:

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