-
-
Save akrmn/5d883ab5d8ea51a1604eb51ca53679a4 to your computer and use it in GitHub Desktop.
{-# 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 aboutCorrelationId
s - when used inside a handler the
FooService
has to be passed aCorrelationId
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)
Would you consider this a good solution instead?
In the code above
requestHandler0
discharge theCorrelated
constraint by using aCorrelatedConsoleLogT
which leaves only theMonadLog
constraint which can then be fulfilled by a regularrunConsoleT
.The main difference is that the
MonadLog
instance for "correlated logging" is implemented with anotherMonadLog
instance which does not require correlation.