To Dream of Magick

Dreamer Shaper Seeker Maker

Abstracting the Monad Stack, Part 1

Posted on Thu Sep 21 04:00:00 UTC 2017

As a sidenote, my previous articles were all in terms of a fictitious image processing program. I am actually very interested in image processing, but that is not the code I have on hand, so for my examples, I am switching over to a health-tracking application that I've been working on for a while. I'll probably change the previous articles to reflect it. I am making this change, though, primarily because there are so many real examples for me to draw from.

Here is the application in question, and it is under active development. I have some layer refactoring to do, but the code is stable and I am mostly focusing my efforts on additional features.

Building a library monad

Code for this section

I previously talked about application monads, but today I will talk about a library monad.

Fortunately for everyone, they are almost identical to application monads, but with one twist that I want to lead you to.

In my health application, I have a library that forms the "application" and that library is meant to be wrapped around interface layers, such as the web API or a GUI. The application library is basically a set of functions that make a complete API that I can execute in the REPL.

So, assume a monad like this one:

data AppContext = App { weightSeries       :: TimeSeries Weight
                      , timeDistanceSeries :: TimeSeries TimeDistance
                      , stepSeries         :: TimeSeries Steps
                      }

-- TODO: handle time series exceptions. Make this less absurd.
data HealthException = TimeSeriesExc SeriesExc
                     | UnknownException String
                     deriving (Eq, Show)

newtype HealthM a = HealthM (ReaderT AppContext (ExceptT HealthException IO) a)
    deriving (Functor, Applicative, Monad, MonadIO, MonadError HealthException, MonadReader AppContext)

runHealthM :: AppContext -> HealthM a -> IO (Either HealthException a)
runHealthM ctx (HealthM act) = runExceptT (runReaderT act ctx)

(yes, that is a real TODO item in the code)

On it's own, this isn't bad. But the pain lies in that this is a library, and thus will likely end up in a different monad stack. As it is written, I would need to unroll this stack into IO and then re-roll it into my web stack. This is not horrible, but it is annoying. In the health application, I would do the re-rolling to glue these functions into my Web application monad, and it would look like this:

data Config = Config
data WebContext = WebContext { config :: Config, app :: AppContext }

newtype WebM a = WebM (ReaderT WebContext (ExceptT WebExc IO) a)
    deriving (Functor, Applicative, Monad, MonadIO, MonadError WebExc, MonadReader WebContext)

handleSaveTimeDistance :: Maybe SampleID -> SetTimeDistanceParameters -> WebM (Sample TimeDistance)
handleSaveTimeDistance sampleId params =
    let workoutFromParams = undefined
        workout = workoutFromParams params
    in do
    WebContext{..} <- ask
    res <- liftIO $ runHealthM app $ saveTimeDistance sampleId workout
    case res of
        Left err -> throwError $ AppExc err
        Right val -> return val

saveTimeDistance :: Maybe SampleID -> TimeDistance -> HealthM (Sample TimeDistance)

Again, this is not awful, but it is tedious. It can also become awful if I want to perform multiple operations from the library interleaved with operations from my webapp. For example, what if I want to query every series that I am storing?

handleGetHistory :: Interval UTCTime -> WebM ([Sample Weight], [Sample TimeDistance], [Sample Steps])
handleGetHistory interval = do
    WebContext{..} <- ask
    weightRes <- liftIO $ runHealthM app $ getWeights interval
    timeDistanceRes <- liftIO $ runHealthM app $ getTimeDistance interval
    stepRes <- liftIO $ runHealthM app $ getSteps interval

    case (weightRes, timeDistanceRes, stepRes) of
        (Left err, _, _) -> throwError $ AppExc err
        (_, Left err, _) -> throwError $ AppExc err
        (_, _, Left err) -> throwError $ AppExc err
        (Right weights, Right timeDistances, Right steps) -> pure (weights, timeDistances, steps)

getWeights :: Interval UTCTime -> HealthM [Sample Weight]
getTimeDistance :: Interval UTCTime -> HealthM [Sample TimeDistance]
getSteps :: Interval UTCTime -> HealthM [Sample Steps]

handleGetHistory already becomes tedious.

Rewrapping the context

Code for this section

The first, most obvious solution, is a helper function to re-wrap:

wrapEitherIO :: (exc -> WebExc) -> IO (Either exc a) -> WebM a
wrapEitherIO excTr act =
    liftIO act >>= either (throwError . excTr) pure

handleGetHistory :: Interval UTCTime -> WebM ([Sample Weight], [Sample TimeDistance], [Sample Steps])
handleGetHistory interval = do
    WebContext{..} <- ask
    weights <- wrapEitherIO AppExc $ runHealthM app $ getWeights interval
    timeDistances <- wrapEitherIO AppExc $ runHealthM app $ getTimeDistance interval
    steps <- wrapEitherIO AppExc $ runHealthM app $ getSteps interval
    pure (weights, timeDistances, steps)

And then, probably even one step further with a utility function to do the re-wrapping.

wrapEitherIO :: (exc -> WebExc) -> IO (Either exc a) -> WebM a
wrapEitherIO excTr act =
    liftIO act >>= either (throwError . excTr) pure

runHealthMInWebM :: (HealthException -> WebExc) -> AppContext -> HealthM a -> WebM a
runHealthMInWebM handler app = wrapEitherIO handler . runHealthM app

handleGetHistory :: Interval UTCTime -> WebM ([Sample Weight], [Sample TimeDistance], [Sample Steps])
handleGetHistory interval = do
    WebContext{..} <- ask
    weights <- runHealthMInWebM AppExc app $ getWeights interval
    timeDistances <- runHealthMInWebM AppExc app $ getTimeDistance interval
    steps <- runHealthMInWebM AppExc app $ getSteps interval
    pure (weights, timeDistances, steps)

This alone makes life much nicer. All of the exception checking boilerplate gets encapsulated into wrapEitherIO, and so every step of handleGetHistory gets to exist on the happy path. In many instances, I could just call this done.

Servant actually provides a typeclass for natural transformations which abstracts this away. It has a challenging type signature, but it is pretty nice and I recommend taking a look at it.

Type Constraints

Code for this section

I use type constraints as my preferred method for solving this problem. The idea behind it is that I try to have only one concrete monad stack anywhere in the application.

A "type constraint" is a mechanism by which I declare that a context must implement a particular typeclass, but that the context could be any context that implements that typeclass. A trivial example would be like this:

printSomeStuff :: (Show a, MonadIO m) => a -> m ()
printSomeStuff a = do
    liftIO $ putStrLn $ show a

This function will print out any value, so long as the value implements Show and so long as the function is called in any monad that implements MonadIO. For instance, all three of these calls to printSomeStuff are valid:

run1 :: IO ()
run1 = printSomeStuff "abcd"

run2 :: ExceptT String IO ()
run2 = printSomeStuff "abcd"

run3 :: MonadIO m => m ()
run3 = printSomeStuff "abcd"

Now, we build up on this concept, and to do so I'm going to repack all three of my get functions, this time starting from the simplest possible implementation.

saveTimeDistance :: Maybe SampleID -> TimeDistance -> AppContext -> IO (Either HealthException a)

handleSaveTimeDistance :: Maybe SampleID -> SetTimeDistanceParameters -> WebM (Sample TimeDistance)
handleSaveTimeDistance sampleId params =
    let workoutFromParams = undefined
        workout = workoutFromParams params
    in do
    WebContext{..} <- ask
    res <- liftIO $ saveTimeDistance sampleId workout app
    case res of
        Left err -> throwError $ AppExc err
        Right val -> pure val

saveTimeDistance can function in any monad that implements MonadIO, so the first thing I will do is to abstract that away:

saveTimeDistance :: (MonadIO m) => Maybe SampleId -> TimeDistance -> AppContext -> m (Either HealthException a)

handleSaveTimeDistance :: Maybe SampleID -> SetTimeDistanceParameters -> WebM (Sample TimeDistance)
handleSaveTimeDistance sampleId params =
    let workoutFromParams = undefined
        workout = workoutFromParams params
    in do
    WebContext{..} <- ask
    res <- saveTimeDistance sampleId workout app
    case res of
        Left err -> throwError $ AppExc err
        Right val -> pure val

This detaches me from a particular monad stack. This function can now be called as-is from any context that implements, hence in the above code, I no longer need to apply liftIO to saveTimeDistance. For bookkeeping, and because I am going to build upon this abstraction, I will give that type constraint a name:

type HealthM m = MonadIO m

saveTimeDistance :: HealthM m => Maybe SampleID -> TimeDistance -> AppContext -> m (Either HealthException a)

The next step requires a fairly large jump. I want to eliminate that AppContext parameter. It is required for every function in the health application, so it would be nice if I could pass it as part of a MonadReader. The naive solution would be to just do this:

type HealthM m = (MonadIO m, MonadReader AppContext m)

saveTimeDistance :: HealthM m => Maybe SampleID -> TimeDistance -> m (Either HealthException a)

Unfortunately, this actually is of detriment in the caller. If the caller has its own context in a MonadReader, that context is not likely to be the same as this one. The result is code that looks like this:

handleSaveTimeDistance :: Maybe SampleID -> SetTimeDistanceParameters -> WebM (Sample TimeDistance)
handleSaveTimeDistance sampleId params =
    let workoutFromParams = undefined
        workout = workoutFromParams params
    in do
    WebContext{..} <- ask
    res <- runReaderT (saveTimeDistance sampleId workout) app
    case res of
        Left err -> throwError $ AppExc err
        Right val -> pure val

I definitely do not want to be going in the direction of having to re-add a run function stack, but that is how this goes. The caller has to explicitely pull out the context for this call.

In order to get around this, I have to think a bit differently. I still want an implicit context of AppContext. But, really, the context could be larger so long as AppContext is present in it. So an alternate solution looks like this:

type HealthM r m = (MonadIO m, MonadReader WebContext m)

saveTimeDistance :: Health r m => Maybe SampleID -> TimeDistance -> m (Either HealthException a)
saveTimeDistance = undefined

handleSaveTimeDistance :: Maybe SampleID -> SetTimeDistanceParameters -> WebM (Sample TimeDistance)
handleSaveTimeDistance sampleId params =
    let workoutFromParams = undefined
        workout = workoutFromParams params
    in do
    res <- saveTimeDistance sampleId workout
    case res of
        Left err -> throwError $ AppExc err
        Right val -> pure val

In some ways, this looks better. The caller now can simply treat saveTimeDistance as part of WebM. But now saveTimeDistance becomes aware of WebContext, and so is beholden to a single caller. This is better, but not good enough.

What I want is a way to specify that saveTimeDistance can take any context, so long as that context provides me with a way to extract the AppContext. So, this is a constraint upon a constraint, and it ends up looking like this:

type HealthM = (MonadIO m, MonadReader r m, HasHealthContext r)

Basically, a HealthM function can take any MonadReader that provides r, so long as r "has a health context".

My library gets to declare the HasHealthContext interface. The caller needs to implement that interface for its own context.

type Health r m = (MonadIO m, MonadReader r m, HasHealthContext r)
class HasHealthContext ctx where
    hasAppContext :: ctx -> AppContext

WebContext = WebContext { config :: Config, app :: AppContext }
instance HasHealthContext WebContext where
    hasAppContext WebContext{..} = app

saveTimeDistance :: Health r m => Maybe SampleID -> TimeDistance -> m (Either HealthException a)
saveTimeDistance _ _ = do
    appCtx <- hasAppContext <$> ask
    ...

With similar improvements made to getWeights, getTimeDistance, and getSteps, handleGetHistory also gets much nicer, and that demonstrates exactly what we wanted to begin with:

handleGetHistory :: Interval UTCTime -> WebM ([Sample Weight], [Sample TimeDistance], [Sample Steps])
handleGetHistory interval = do
    WebContext{..} <- ask
    weightRes <- getWeights interval
    timeDistanceRes <- getTimeDistance interval
    stepRes <- getSteps interval

    case (weightRes, timeDistanceRes, stepRes) of
        (Left err, _, _) -> throwError $ AppExc err
        (_, Left err, _) -> throwError $ AppExc err
        (_, _, Left err) -> throwError $ AppExc err
        (Right weights, Right timeDistances, Right steps) -> pure (weights, timeDistances, steps)

getWeights :: Health r m => Interval UTCTime -> m (Either HealthException a)
getWeights = undefined

getTimeDistance :: Health r m => Interval UTCTime -> m (Either HealthException a)
getTimeDistance = undefined

getSteps :: Health r m => Interval UTCTime -> m (Either HealthException a)
getSteps = undefined

Looking forward

Not quite there yet. We still have some tedium with exception handling to do. In this system, any thrown SeriesExc must be caught and then re-wrapped in the HealthException in order for the application to typecheck and for the exception to propogate upwards. This sort of tedium likely drove the creation of extensible IO exceptions, which I view as unchecked and undocumented parts of the type signature.

So, the next step will be to abstract the exception throwing mechanism.