Skip to content

Instantly share code, notes, and snippets.

@jship

jship/MTLiens.md

Created October 28, 2022 00:21
Show Gist options
  • Save jship/e9e995ed42b4077fd79cec0824660c13 to your computer and use it in GitHub Desktop.
Save jship/e9e995ed42b4077fd79cec0824660c13 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
MTLiens.md

title: MTLiens author: Jason Shipman | jship patat: wrap: true margins: left: 10 right: 10 incrementalLists: true ...

MTLiens

A mostly modern revisiting of MTL

What all's a'comin':

  • MTL/transformers refresher 🔎
  • The logging lesson 🍎
  • Reading between the lines 📑

MTL/transformers refresher 🔎

ReaderT

newtype ReaderT r m a = ReaderT
  { runReaderT :: r -> m a
  }

ask :: (Monad m) => ReaderT r m r
ask = asks id

asks :: (Monad m) => (r -> a) -> ReaderT r m a
asks f = ReaderT \r -> pure $ f r

reader :: (Monad m) => (r -> a) -> ReaderT r m a
reader = asks

local
  :: (r -> r)
  -> ReaderT r m a
  -> ReaderT r m a
local f action = ReaderT \r -> runReaderT action $ f r

ReaderT: Monad

instance (Monad m) => Monad (ReaderT r m) where
  return :: a -> ReaderT r m a
  return = pure

  (>>=)
    :: ReaderT r m a
    -> (a -> ReaderT r m b)
    -> ReaderT r m b
  action >>= f =
    ReaderT \r -> do
      x <- runReaderT action r
      runReaderT (f x) r

ReaderT: Applicative

instance (Applicative m) => Applicative (ReaderT r m) where
  pure :: a -> ReaderT r m a
  pure x = ReaderT \_r -> pure x

  liftA2 :: (a -> b -> c) -> ReaderT r m a -> ReaderT r m b -> ReaderT r m c
  liftA2 f x y =
    ReaderT \r ->
      liftA2 f (runReaderT x r) (runReaderT y r)

ReaderT: Functor

mapReaderT
  :: (m a -> n b)
  -> ReaderT r m a
  -> ReaderT r n b
mapReaderT f action = ReaderT \r -> f $ runReaderT action r

instance (Functor m) => Functor (ReaderT r m) where
  fmap :: (a -> b) -> ReaderT r m a -> ReaderT r m b
  fmap f = mapReaderT (fmap f)

ReaderT: Monad transformer

instance MonadTrans (ReaderT r) where
  lift :: m a -> ReaderT r m a
  lift action = ReaderT \_r -> action

instance (MonadIO m) => MonadIO (ReaderT r m) where
  liftIO :: IO a -> ReaderT r m a
  liftIO action = lift $ liftIO action

ReaderT: Usage

import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Reader (ReaderT, asks)
import Network.HTTP.Client (Manager, httpLbs, parseRequest, responseStatus)
import Network.HTTP.Types.Status (statusCode)

data Env = Env
  { envHTTPManager :: Manager
    -- ... and whatever else ...
  }

doStuff :: ReaderT Env IO Int
doStuff = do
  manager <- asks envHTTPManager
  req <- parseRequest "http://httpbin.org/get"
  resp <- liftIO $ httpLbs req manager
  pure $ statusCode $ responseStatus resp

Running the stack: ReaderT edition

runTheStack :: IO Int
runTheStack = runReaderT doStuff myEnv

myEnv :: Env
myEnv = -- ...

-- Recall:
doStuff :: ReaderT Env IO Int

StateT

newtype StateT s m a = StateT
  { runStateT :: s -> m (a, s)
  }

get :: (Monad m) => StateT s m s
get = state \s -> (s, s)

put :: (Monad m) => s -> StateT s m ()
put s = state \_s -> ((), s)

state :: (Monad m) => (s -> (a, s)) -> StateT s m a
state f = StateT \s -> pure $ f s

-- Recall:
newtype ReaderT r m a = ReaderT
  { runReaderT :: r -> m a
  }

StateT: Instances

mapStateT
  :: (m (a, s) -> n (b, s))
  -> StateT s m a
  -> StateT s n b
mapStateT f action = StateT \s -> f $ runStateT action s

instance (Functor m) => Functor (StateT s m) where -- blah...
instance (Monad m) => Applicative (StateT s m) where -- blah...
instance (MonadPlus m) => Alternative (StateT s m) where -- blah...
instance (Monad m) => Monad (StateT s m) where -- blah...
instance MonadTrans (StateT s) where -- blah...
instance (MonadIO m) => MonadIO (StateT s m) where -- blah...

StateT: Usage

-- ...
import Control.Monad (unless)
import Control.Monad.Trans.State (StateT, get, put)

data Env = -- ...

type ErrorCount = Int  -- Pretty contrived... Don't @ me.

doStuff :: StateT ErrorCount (ReaderT Env IO) Int
doStuff = do
  manager <- lift $ asks envHTTPManager -- :(
  req <- parseRequest "http://httpbin.org/get"
  resp <- liftIO $ httpLbs req manager
  let code = statusCode $ responseStatus resp
  unless (200 <= code && code < 300) do
    prevErrorCount <- get
    put $ 1 + prevErrorCount
  pure code

Running the stack: ReaderT + StateT edition

runTheStack :: IO (Int, ErrorCount)
runTheStack = runReaderT (runStateT doStuff 0) myEnv

myEnv :: Env
myEnv = -- ...

-- Recall:
doStuff :: StateT ErrorCount (ReaderT Env IO) Int

Enter MTL

class (Monad m) => MonadReader r m | m -> r where
  ask :: m r
  local :: (r -> r) -> m a -> m a
  reader :: (r -> a) -> m a

class (Monad m) => MonadState s m | m -> s where
  get :: m s
  put :: s -> m ()
  state :: (s -> (a, s)) -> m a

Instances

import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.Trans.State (StateT)
import qualified Control.Monad.Trans.Reader as ReaderT
import qualified Control.Monad.Trans.State as StateT

instance (Monad m) => MonadReader r (ReaderT r m) where
  ask = ReaderT.ask
  local = ReaderT.local
  reader = ReaderT.reader

instance (Monad m) => MonadState r (StateT r m) where
  get = StateT.get
  put = StateT.put
  state = StateT.state

MTL: Usage

doStuff
  :: (MonadState ErrorCount m, MonadReader Env m, MonadIO m, MonadThrow m)
  => m Int
doStuff = do
  manager <- asks envHTTPManager -- :)
  req <- parseRequest "http://httpbin.org/get"
  resp <- liftIO $ httpLbs req manager
  let code = statusCode $ responseStatus resp
  unless (200 <= code && code < 300) do
    prevErrorCount <- get
    put $ 1 + prevErrorCount
  pure code

Running the stack: MTL edition

run :: IO (Int, ErrorCount)
run = runReaderT (runStateT doStuff 0) myEnv

-- Recall:
doStuff
  :: (MonadState ErrorCount m, MonadReader Env m, MonadIO m, MonadThrow m)
  => m Int

. . .

• No instance for (MonadReader
                     Env (StateT ErrorCount (ReaderT Env IO)))
    arising from a use of ‘doStuff’
• In the first argument of ‘runStateT’, namely ‘doStuff’
  In the first argument of ‘runReaderT’, namely
    ‘(runStateT doStuff 0)’
  In the expression: runReaderT (runStateT doStuff 0) myEnv

Enter MTL's giant hammer

instance (MonadReader r m) => MonadReader r (StateT s m) where
  ask = lift ask
  local = mapStateT . local
  reader = lift . reader

instance (MonadState s m) => MonadState s (ReaderT r m) where
  get = lift get
  put = lift . put
  state = lift . state

. . .

... and many, many, many more instances ...

. . .

... i'm not playing around. there's way more instances ...

. . .

... please, make it stop ...

The logging lesson 🍎

Logging in MTL style

What's a "decoupled logging system"?

. . .

class (Monad m) => MonadLogger m where
  logMsg :: Text -> m ()

-- ... plus all the instances for all the things ...

. . .

logStuff :: (MonadLogger m) => m ()
logStuff = do
  logMsg "Log some stuff"

Logging in MTL style (cont'd)

newtype LoggingT m a = LoggingT
  { runLoggingT :: (Text -> IO ()) -> m a
  }

instance (MonadIO m) => MonadLogger (LoggingT m) where
  logMsg text = LoggingT \logger -> liftIO $ logger text

-- ... plus all the other instances for all the things ...

runStdoutLoggingT :: LoggingT m a -> m a
runStdoutLoggingT action = runLoggingT action $ hPutStrLn stdout

runStderrLoggingT :: LoggingT m a -> m a
runStderrLoggingT action = runLoggingT action $ hPutStrLn stderr

-- ... and any other runners. the world is our oyster! ...

Zooming in on LoggingT: Monad

newtype LoggingT m a = LoggingT
  { runLoggingT :: (Text -> IO ()) -> m a
  }

instance (Monad m) => Monad (LoggingT m) where
  return :: a -> LoggingT m a
  return = pure

  (>>=)
    :: LoggingT m a
    -> (a -> LoggingT m b)
    -> LoggingT m b
  action >>= f =
    LoggingT \logger -> do
      x <- runLoggingT action logger
      runLoggingT (f x) logger

Zooming in on LoggingT: Applicative

instance (Applicative m) => Applicative (LoggingT m) where
  pure :: a -> LoggingT m a
  pure x = LoggingT \_logger -> pure x

  liftA2
    :: (a -> b -> c)
    -> LoggingT m a
    -> LoggingT m b
    -> LoggingT m c
  liftA2 f x y =
    LoggingT \logger ->
      liftA2 f (runLoggingT x logger) (runLoggingT y logger)

Zooming in on LoggingT: Functor

mapLoggingT
  :: (m a -> n b)
  -> LoggingT m a
  -> LoggingT n b
mapLoggingT f action = LoggingT \logger -> f $ runLoggingT action logger

instance (Functor m) => Functor (LoggingT m) where
  fmap :: (a -> b) -> LoggingT m a -> LoggingT m b
  fmap f = mapLoggingT (fmap f)

Zooming in on LoggingT: Monad transformer

instance MonadTrans (LoggingT) where
  lift :: m a -> LoggingT m a
  lift action = LoggingT \_logger -> action

instance (MonadIO m) => MonadIO (LoggingT m) where
  liftIO :: IO a -> LoggingT m a
  liftIO action = lift $ liftIO action

Zooming in on LoggingT: Compat w/ MTL and more

-- mtl
instance (MonadReader r m) => MonadReader r (LoggingT m) where -- ...
instance (MonadWriter w m) => MonadWriter w (LoggingT m) where -- ...
instance (MonadState s m) => MonadState s (LoggingT m) where -- ...
instance (MonadRWS r w s m) => MonadRWS r w s (LoggingT m) where -- ...
instance (MonadError e m) => MonadError e (LoggingT m) where -- ...
instance (MonadCont m) => MonadCont (LoggingT m) where -- ...
-- exceptions
instance (MonadThrow m) => MonadThrow (LoggingT m) where -- ...
instance (MonadCatch m) => MonadCatch (LoggingT m) where -- ...
instance (MonadMask m) => MonadMask (LoggingT m) where -- ...
-- resourcet
instance (MonadResource m) => MonadResource (LoggingT m) where -- ...
-- unliftio-core
instance (MonadUnliftIO m) => MonadUnliftIO (LoggingT m) where -- ...
-- transformers-base & monad-control
instance (MonadBase b m) => MonadBase b (LoggingT m) where -- ...
instance (MonadBaseControl b m) => MonadBaseControl b (LoggingT m) where -- ...

Zooming in on LoggingT: ENHANCE! 2x!

newtype LoggingT m a = LoggingT
  { runLoggingT :: (Text -> IO ()) -> m a
  }

. . .

newtype ReaderT r m a = ReaderT
  { runReaderT :: r -> m a
  }

. . .

toLoggingT :: ReaderT (Text -> IO ()) m a -> LoggingT m a
toLoggingT = coerce

fromLoggingT :: LoggingT m a -> ReaderT (Text -> IO ()) m a
fromLoggingT = coerce

Derive the pain away

newtype LoggingT m a = LoggingT
  { runLoggingT :: (Text -> IO ()) -> m a
  } deriving
      ( Functor, Applicative, Monad, MonadIO -- base
      , MonadState s, MonadError e, MonadWriter w, MonadCont, MonadRWS r w s -- mtl
      , MonadThrow, MonadCatch, MonadMask -- exceptions
      , MonadResource -- resourcet
      , MonadUnliftIO -- unliftio
      , MonadBase b -- transformers-base
      , MonadBaseControl b -- monad-control
      ) via (ReaderT (Text -> IO ()) m)

Handling MonadReader

What happens if we try to add MonadReader to the deriving-via list?

newtype LoggingT m a = LoggingT
  { runLoggingT :: (Text -> IO ()) -> m a
  } deriving
      ( -- ...
      , MonadReader r
      ) via (ReaderT (Text -> IO ()) m)

. . .

• Couldn't match type ‘r’ with ‘Text -> IO ()’
    arising from a functional dependency between:
      constraint ‘MonadReader r (ReaderT (Text -> IO ()) m)’
        arising from the 'deriving' clause of a data type declaration

Handling MonadReader (cont'd)

instance (MonadReader r m) => MonadReader r (LoggingT m) where
  ask = lift ask
  reader = lift . reader
  local = mapLoggingT . local

. . .

• Could not deduce (MonadTrans LoggingT)
    arising from a use of ‘lift’
  from the context: MonadReader r m
    bound by the instance declaration
    at /home/jship/git/mtliens/mtliens/library/MTLiens.hs:108:10-56
• In the expression: lift ask
  In an equation for ‘ask’: ask = lift ask
  In the instance declaration for ‘MonadReader r (LoggingT m)’

Derivers gon' derive

newtype LoggingT m a = LoggingT
  { runLoggingT :: (Text -> IO ()) -> m a
  } deriving
      ( Functor, Applicative, Monad, MonadIO -- base
      , MonadState s, MonadError e, MonadWriter w, MonadCont, MonadRWS r w s -- mtl
      , MonadThrow, MonadCatch, MonadMask -- exceptions
      , MonadResource -- resourcet
      , MonadUnliftIO -- unliftio-core
      , MonadBase b -- transformers-base
      , MonadBaseControl b -- monad-control
      ) via (ReaderT (Text -> IO ()) m)
    -- New stuff below:
    deriving
      ( MonadTrans -- transformers
      , MonadTransControl -- monad-control
      ) via (ReaderT (Text -> IO ()))

While we're at it...

newtype LoggingT m a = LoggingT
  { runLoggingT :: (Text -> IO ()) -> m a
  } deriving
      ( Functor, Applicative, Monad, MonadIO -- base
      , MonadState s, MonadError e, MonadWriter w, MonadCont, MonadRWS r w s -- mtl
      , MonadThrow, MonadCatch, MonadMask -- exceptions
      , MonadResource -- resourcet
      , MonadUnliftIO -- unliftio-core
      , MonadBase b -- transformers-base
      , MonadBaseControl b -- monad-control
      ) via (ReaderT (Text -> IO ()) m)
    deriving
      ( MonadTrans -- transformers
      , MonadTransControl -- monad-control
      ) via (ReaderT (Text -> IO ()))
    deriving
      ( Semigroup, Monoid -- base
      ) via (Ap (ReaderT (Text -> IO ()) m) a)

How about mapLoggingT?

mapLoggingT
  :: forall m a n b
   . (m a -> n b)
  -> LoggingT m a
  -> LoggingT n b
mapLoggingT f =
  coerce @(ReaderT (Text -> IO ()) n b)
    . mapReaderT f
    . coerce

What about the oodles of MonadLogger instances?

class (Monad m) => MonadLogger m where
  logMsg :: Text -> m ()

. . .

instance {-# OVERLAPPABLE #-}
  ( MonadLogger m
  , MonadTrans t
  , Monad (t m)
  ) => MonadLogger (t m) where
    logMsg = lift . logMsg

. . .

No more `n^2 instances!

. . .

This is not quite as friendly from a documentation angle though.

Reading between the lines 📑

A new pattern emerges?

Let's examine this potential design pattern across a couple case studies:

  • Case Study #1: Getting the current time
  • Case Study #2: Timing an action

The ReaderT Backend Pattern: Case Study #1

class (Monad m) => MonadClock m where
  now :: m Integer -- in nanoseconds

. . .

instance {-# OVERLAPPABLE #-}
  ( MonadClock m
  , MonadTrans t
  , Monad (t m)
  ) => MonadClock (t m) where
    now = lift now

The ReaderT Backend Pattern: Case Study #1 (cont'd)

newtype ClockT m a = ClockT
  { runClockT :: ClockBackend -> m a
  } deriving
      ( Functor, Applicative, Monad, MonadIO
      , MonadState s, MonadError e, MonadWriter w, MonadCont, MonadRWS r w s
      , MonadThrow, MonadCatch, MonadMask
      , MonadResource
      , MonadUnliftIO
      , MonadBase b
      , MonadBaseControl b
      , MonadLogger
      , MonadTimer -- Neat! (this class is introduced in Case Study #2)
      ) via (ReaderT ClockBackend m)
    deriving (MonadTrans, MonadTransControl) via (ReaderT ClockBackend)
    deriving (Semigroup, Monoid) via (Ap (ReaderT ClockBackend m) a)

mapClockT :: forall m a n b. (m a -> n b) -> ClockT m a -> ClockT n b
mapClockT f = coerce @(ReaderT ClockBackend n b) . mapReaderT f . coerce

The ReaderT Backend Pattern: Case Study #1 (cont'd)

instance (MonadReader r m) => MonadReader r (ClockT m) where
  ask = lift ask
  reader = lift . reader
  local = mapClockT . local

The ReaderT Backend Pattern: Case Study #1 (cont'd)

instance (MonadIO m) => MonadClock (ClockT m) where
  now = ClockT \clockBackend -> liftIO $ clockBackendNow clockBackend

newtype ClockBackend = ClockBackend
  { clockBackendNow :: IO Integer
  }

-- | A production backend that uses the @clock@ package.
fastClockBackend :: ClockBackend
fastClockBackend =
  ClockBackend { clockBackendNow = fmap toNanoSecs $ getTime Realtime }

-- | A test backend that always returns the given amount of nanoseconds.
constClockBackend :: Integer -> ClockBackend
constClockBackend x =
  ClockBackend { clockBackendNow = pure x }

The ReaderT Backend Pattern: Case Study #2

We can build a higher-level utility to time actions via a MonadClock constraint alone:

timed :: (MonadClock m) => m a -> m (Timed a)
timed action = do
  start <- now
  timedResult <- action
  end <- now
  pure $ Timed { timedResult, timedNanos = end - start }

data Timed a = Timed
  { timedResult :: a
  , timedNanos :: Integer
  }

. . .

But in this case study, we'll implement timing as a separate effect.

The ReaderT Backend Pattern: Case Study #2 (cont'd)

class (Monad m) => MonadTimer m where
  timed :: m a -> m (Timed a)
  --       ⮩  N E G A T I V E  P O S I T I O N 👻

data Timed a = Timed
  { timedResult :: a
  , timedNanos :: Integer
  }

The ReaderT Backend Pattern: Case Study #2 (cont'd)

instance {-# OVERLAPPABLE #-}
  ( MonadTimer m
  , MonadTransControl t
  , Monad (t m)
  ) => MonadTimer (t m) where
    timed action = do
      Timed { timedResult, timedNanos } <- liftWith \run -> timed $ run action
      timedResult' <- restoreT $ pure timedResult
      pure $ Timed { timedResult = timedResult', timedNanos }

Dropped ContT, CPS RWST/WriterT, and ResourceT due to MonadTransControl.

The ReaderT Backend Pattern: Case Study #2 (cont'd)

newtype TimerT m a = TimerT
  { runTimerT :: ClockBackend -> m a
  } deriving
      ( Functor, Applicative, Monad, MonadIO
      , MonadState s, MonadError e, MonadWriter w, MonadCont, MonadRWS r w s
      , MonadThrow, MonadCatch, MonadMask
      , MonadResource
      , MonadUnliftIO
      , MonadBase b
      , MonadBaseControl b
      , MonadLogger
      , MonadClock, MonadReader r -- Also neat!
      ) via (ClockT m)
    deriving (MonadTrans, MonadTransControl) via (ClockT)
    deriving (Semigroup, Monoid) via (Ap (ClockT m) a)

mapTimerT :: forall m a n b. (m a -> n b) -> TimerT m a -> TimerT n b
mapTimerT f = coerce @(ClockT n b) . mapClockT f . coerce

The ReaderT Backend Pattern: Case Study #2 (cont'd)

instance (MonadIO m) => MonadTimer (TimerT m) where
  timed action = do
    start <- now
    timedResult <- action
    end <- now
    pure $ Timed { timedResult, timedNanos = end - start }

The ReaderT Backend Pattern: Anatomy - Typeclass

class (Monad m) => MonadFoo m where
  getStuff :: Things -> m Stuff

instance {-# OVERLAPPABLE #-}
  ( MonadFoo m
  , MonadTrans t
  , Monad (t m)
  ) => MonadFoo (t m) where
    getStuff = lift . getStuff

The ReaderT Backend Pattern: Anatomy - Transformer

newtype FooT m a = FooT
  { runFooT :: FooBackend -> m a
  } -- ... deriving-via goes here ...

instance (MonadIO m) => MonadFoo (FooT m) where -- ...

instance (MonadReader r m) => MonadReader r (FooT m) where
  ask = lift ask
  reader = lift . reader
  local = mapFooT . local

mapFooT :: forall m a n b . (m a -> n b) -> FooT m a -> FooT n b
mapFooT f = coerce @(ReaderT FooBackend n b) . mapReaderT f . coerce

data FooBackend = FooBackend
  { fooBackendFromThings :: Things -> IO EnrichedThings
  , fooBackendGetStuff :: EnrichedThings -> IO Stuff
  }

Recap

Let's review the ground we covered:

  • The logging lesson
  • Boilerplate, begone!
  • Use brainpower on the effect, not effect machinery

End

🎃



          __   __
         |  |_|  |______ _,___ _,___ _   _         \--/
         |   _   |__    |  __ |  __ | |_| |     /`-'  '-`\
         |__| |__|__-_,_| ,___| ,___|___, |    /          \
                        |_|   |_|       |_|   /.'|/\  /\|'.\
       __   __        _ _                           \/
      |  |_|  |______| | |______ __ _ __ ______ ______ _,____
      |   _   |__    | | |  __  |  | |  |  --__|  --__|  __  \
      |__| |__|__-_,_|_|_|______|_______|______|______|_|  |_|  jgs98

Appendix

Links

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment