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