MovingConstraints.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE PostfixOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GADTs #-}

import Control.Monad ((<=<))
import Control.Monad.Reader (ReaderT (..), ask)
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Trans.Control (MonadTransControl (..), Run)
import Control.Monad.Identity (IdentityT (..))
import Control.Monad.IO.Class (MonadIO (..))
import Data.Coerce (coerce)

import System.IO (IOMode, Handle, withFile)

--------------------------------------------------------------------------------
-- # Correlation
newtype CorrelationId = CorrelationId String

class Monad m => Correlated m where
  getCorrelationId :: m CorrelationId

-- | Pass-through instance for transformers
--   We use these at work to avoid having to write one instance for each
--   possible MonadBar >< QuxT combination (the "N^2 issue")
--
--   Felix Mulder (\@FelixMulder, <https://twitter.com/FelixMulder>) explains
--   it on his post [Revisiting application structure](http://felixmulder.com/writing/2020/08/08/Revisiting-application-structure.html)
instance {-# OVERLAPPABLE #-}
  ( MonadTrans t
  , Monad (t m)
  , Correlated m
  ) => Correlated (t m) where
  getCorrelationId = lift getCorrelationId

newtype CorrelatedT m a = CorrelatedT
  { unCorrelatedT :: ReaderT CorrelationId m a }
  deriving newtype (Functor, Applicative, Monad, MonadTrans, MonadTransControl)

runCorrelatedT :: forall m a. CorrelationId -> CorrelatedT m a -> m a
runCorrelatedT = flip coerce

instance Monad m => Correlated (CorrelatedT m) where
  getCorrelationId = CorrelatedT ask

--------------------------------------------------------------------------------
-- # Logging
newtype Msg = Msg { unMsg :: String }

class Monad m => MonadLog m where
  logMsg :: Msg -> m ()

-- | Pass-through instance for transformers
instance {-# OVERLAPPABLE #-}
  ( MonadTrans t
  , Monad (t m)
  , MonadLog m
  ) => MonadLog (t m) where
  logMsg msg = lift (logMsg msg)

newtype ConsoleLogT m a = ConsoleLogT
  { unConsoleLogT :: m a }
  deriving newtype (Functor, Applicative, Monad)
  deriving (MonadTrans, MonadTransControl) via IdentityT

runConsoleLogT :: forall m a. ConsoleLogT m a -> m a
runConsoleLogT = coerce

instance MonadIO m => MonadLog (ConsoleLogT m) where
  logMsg = ConsoleLogT . liftIO . putStrLn . unMsg

--------------------------------------------------------------------------------
-- # Logging with a Correlation ID
correlatedLog :: (Correlated m, MonadLog m) => Msg -> m ()
correlatedLog (Msg msg) = do
  CorrelationId correlationId <- getCorrelationId
  logMsg (Msg (correlationId <> ": " <> msg))

--------------------------------------------------------------------------------
-- # "Business logic", Original idea
data Foo = Foo

class Monad m => MonadFoo0 m where
  foo0 :: m Foo

-- | Pass-through instance for transformers
instance {-# OVERLAPPABLE #-}
  ( MonadTrans t
  , Monad (t m)
  , MonadFoo0 m
  ) => MonadFoo0 (t m) where
    foo0 = lift foo0

newtype FooT m a = FooT { unFooT :: ReaderT Foo m a }
  deriving newtype (Functor, Applicative, Monad, MonadTrans, MonadTransControl)

runFooT :: Foo -> FooT m a -> m a
runFooT = flip coerce

-- | This is the problematic instance, because of the @Correlated m@ constraint.
instance (Correlated m, MonadLog m) => MonadFoo0 (FooT m) where
  foo0 :: FooT m Foo
  foo0 = do
    correlatedLog (Msg "fetching foo")
    pure Foo

main0 :: IO ()
main0
  = runConsoleLogT
  . runCorrelatedT ("what correlation id" ???)
      -- There's no correlation ID to pass here!
  . runFooT Foo
  $ abstractMain0

abstractMain0 ::
     MonadFoo0 m
  => m ()
abstractMain0 = handleRequests requestHandler0

requestHandler0 ::
     MonadFoo0 m
  => CorrelationId
  -> m Foo
requestHandler0 _correlationId = do
  -- we would like to use _this_ correlationId,
  -- but the type of Foo0 doesn't require us to
  foo0

--------------------------------------------------------------------------------
-- # "Business logic", new idea
--   thanks to Manuel Gómez (\@mgomezch, <https://twitter.com/mgomezch>)
--   for suggesting that the method should take a logging function explicitly
--   <https://twitter.com/mgomezch/status/1316784380929552385>
class Monad m => MonadFoo m where
  -- | fooWithLog takes a new argument, a logging function.
  fooWithLog :: (Msg -> m ()) -> m Foo

-- | Pass-through instance for transformers
--   This one is slightly trickier than the one for @MonadFoo0@, since
--   there's an @m@ in negative position, which means we need
--   to use 'MonadTransControl'.
--
--   Alexis King's (\@lexi_lambda, <https://twitter.com/lexi_lambda>) post
--   [Demystifying MonadBaseControl](https://lexi-lambda.github.io/blog/2019/09/07/demystifying-monadbasecontrol)
--   has helped me a lot when trying to understand 'MonadTransControl'
--   and the related 'MonadBaseControl'
instance {-# OVERLAPPABLE #-}
  ( MonadTransControl t
  , Monad (t m)
  , MonadFoo m
    {-
    We need the following constraints because the actions in 'fooWithLog'
    always return monomorphic types (@m ()@ and @m Foo@). As explained in
    Alexis King's post, the MonadTransControl machinery needs the return type
    to be polymorphic, since that's how it passes along the monadic state from
    the transformer. These constraints mean that @t@ does not have any
    monadic state of its own, which works in this small example, but prevents
    us from lifting this effect through stateful transformers such as
    @ExceptT@, @MaybeT@ or @StateT@
    -}
  , StT t () ~ ()
  , StT t Foo ~ Foo
  ) => MonadFoo (t m) where
    fooWithLog log = controlT \run -> fooWithLog @m (run . log)
    {-
    A previous version of this gist had
      fooWithLog log' = controlT \run -> run (fooWithLog log')
    which I then realized was defining 'fooWithLog @(t m)' in terms of itself,
    rather than in terms of 'fooWithLog @m'
    -}

-- liftWith action >>= restoreT . return

-- | Compared with the instance @MonadFoo0 (FooT m)@,
--   this instance doesn't have a @Correlated m@ constraint
--   -- nor a @MonadLog m@ constraint (though that would have been alright)
instance Monad m => MonadFoo (FooT m) where
  fooWithLog log = do
    log (Msg "x y z")
    pure Foo

-- | The 'foo' method now lives outside of the class 'MonadFoo'.
--   Compared with the signature of 'foo0', this _adds_ the @Correlated m@ and
--   @MonadLog m@ constraints. This means they are exposed when using
--   'foo', rather than when using 'runFooT'.
foo :: (Correlated m, MonadLog m, MonadFoo m) => m Foo
foo = fooWithLog correlatedLog

main :: IO ()
main
  = runConsoleLogT
  . runFooT Foo -- this does not require us to fulfill a
                -- @Correlated m@ constraint, like we wanted!
  $ abstractMain

abstractMain ::
     MonadLog m
  => MonadFoo m
  => m ()
abstractMain = handleRequests requestHandler

requestHandler ::
     MonadLog m
  => MonadFoo m
  => CorrelationId
  -> m Foo
requestHandler correlationId = do
  -- The type of @foo@ requires a @Correlated m@ context,
  -- which we can provide with @CorrelatedT@ using the
  -- @correlationId@ from the request.
  runCorrelatedT correlationId foo

--------------------------------------------------------------------------------
-- # MonadTransControl helper
-- | Analogous to @Control.Monad.Trans.Control.control@
--   Not sure why this isn't provided in @monad-control@
controlT ::
     MonadTransControl t
  => Monad (t m)
  => Monad m
  => (Run t -> m (StT t a)) -> t m a
controlT action = liftWith action >>= restoreT . return

--------------------------------------------------------------------------------
-- # etc
-- | Pretend this is a handler for HTTP requests, SQS messages, whatever.
handleRequests :: (a -> m b) -> m ()
handleRequests = undefined

(???) :: String -> a
(???) = error

Hi @symbiont-eric-torreborre, thanks for your solution. I didn't state it in the gist, but another goal of mine is to keep runFooT in main, since many different handlers will make use of the MonadFoo effect and I want them to share the same implementation. In other words, abstractMain should have a MonadFoo m constraint. Another problem with your solution is that the user (requestHandler) needs to remember to use runCorrelatedConsoleLogT, and I don't trust myself to remember that :) so I want the type of foo to remind me in some way (in my solution, foo has a Correlated m constraint).

Thanks for giving me all the constraints. We actually have a fairly similar problem at work :-). But we are using records-of-functions instead of monad transformers. I give you a solution which uses registry, a library for constructing records of functions but you could do all the wiring manually:

import Control.Monad.Reader (ReaderT (..), ask)
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.IO.Class (MonadIO (..))
import Prelude hiding (log)
import Data.Registry

--------------------------------------------------------------------------------
-- # Logging

newtype CorrelationId = CorrelationId String
newtype Msg = Msg { unMsg :: String }

newtype Logger m = Logger { logMsg :: Msg -> m () }

newLogger :: MonadIO m => Logger m
newLogger = Logger (liftIO . putStrLn . unMsg)

-- | This logger requires a context with a CorrelationId
-- | This logger requires a context with a CorrelationId
newCorrelatedLogger :: Monad m => Logger m -> Logger (ReaderT CorrelationId m)
newCorrelatedLogger logger = Logger {..} where

  logMsg :: Msg -> m ()
  logMsg (Msg msg) = do
    CorrelationId correlationId <- ask
    lift $ logMsg logger (Msg $ correlationId <> ":" <> msg)

--------------------------------------------------------------------------------
-- # Fooing

data Foo = Foo deriving (Eq, Show)
newtype FooService m = FooService { doFoo :: m Foo }

newFooService :: Monad m => Foo -> Logger m -> FooService m
newFooService foo logger = FooService $ do
  logMsg logger (Msg "produce a Foo")
  pure foo

--------------------------------------------------------------------------------
-- # Handling requests

newtype RequestHandler m = RequestHandler { requestHandler :: CorrelationId -> m Foo }

-- | The FooService is constrained to use correlation ids
newRequestHandler :: FooService (ReaderT CorrelationId m) -> RequestHandler m
newRequestHandler fooService = RequestHandler $ \correlationId ->
  flip runReaderT correlationId $ doFoo fooService

-- | Define a registry containing all the components constructors
registry =
    -- this value is used to setup the FooService
     val Foo
  -- the Handler needs a FooService (ReaderT CorrelationId IO)
  -- (other handlers would use the same implementation)
  <: fun (newRequestHandler @IO)
  -- this requires to have a Logger (ReaderT CorrelationId IO) in the registry
  <: fun (newFooService @(ReaderT CorrelationId IO))
  -- this is a Logger (ReaderT CorrelationId IO), it needs a Logger IO
  <: fun (newCorrelatedLogger @IO)
  -- this is a Logger IO
  <: fun (newLogger @IO)


--------------------------------------------------------------------------------
-- # Main

main :: IO ()
main = do
  -- we make all the top-level handlers here
  let RequestHandler requestHandler = make @(RequestHandler IO) registry
  -- and start handling requests
  handleRequests requestHandler

-- | Pretend this is a handler for HTTP requests, SQS messages, whatever.
handleRequests :: (a -> m b) -> m ()
handleRequests = undefined

I think that satisfies your constraints:

• the FooService implementation is shared by all the handlers
• it uses a Logger and does not need to know about CorrelationIds
• when used inside a handler the FooService has to be passed a CorrelationId in order to be called
• logging with a CorrelationId uses the general code for logging messages

All in all I find using records of functions more practical when there are lots of components provided there's a good wiring solution (registry is one of them, there can be other approaches)