title: MTLiens author: Jason Shipman | jship patat: wrap: true margins: left: 10 right: 10 incrementalLists: true ...
What all's a'comin':
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
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
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)
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)
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
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
runTheStack :: IO Int
runTheStack = runReaderT doStuff myEnv
myEnv :: Env
myEnv = -- ...
-- Recall:
doStuff :: ReaderT Env IO Int
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
}
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...
-- ...
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
runTheStack :: IO (Int, ErrorCount)
runTheStack = runReaderT (runStateT doStuff 0) myEnv
myEnv :: Env
myEnv = -- ...
-- Recall:
doStuff :: StateT ErrorCount (ReaderT Env IO) Int
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
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
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
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
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 ...
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"
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! ...
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
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)
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)
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
-- 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 -- ...
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
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)
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
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)’
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 ()))
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)
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
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.
Let's examine this potential design pattern across a couple case studies:
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
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
instance (MonadReader r m) => MonadReader r (ClockT m) where
ask = lift ask
reader = lift . reader
local = mapClockT . local
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 }
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.
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
}
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
.
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
instance (MonadIO m) => MonadTimer (TimerT m) where
timed action = do
start <- now
timedResult <- action
end <- now
pure $ Timed { timedResult, timedNanos = end - start }
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
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
}
Let's review the ground we covered:
__ __
| |_| |______ _,___ _,___ _ _ \--/
| _ |__ | __ | __ | |_| | /`-' '-`\
|__| |__|__-_,_| ,___| ,___|___, | / \
|_| |_| |_| /.'|/\ /\|'.\
__ __ _ _ \/
| |_| |______| | |______ __ _ __ ______ ______ _,____
| _ |__ | | | __ | | | | --__| --__| __ \
|__| |__|__-_,_|_|_|______|_______|______|______|_| |_| jgs98