Extracting multiple IO exceptions into polysemy

Question

Let's say I have some very complex set of computations of the form computation :: IO a that I cannot modify, due to it being from some library code or other reasons. Let's also say I want to provide some type-level guarantees that we aren't able to launch nuclear missiles in the midst of using these computations, so we use polysemy and wrap all these up into its own DSL Library. We can naively interpret this with

runLibraryIO :: Member (Embed IO) r => Sem (Library ': r) a -> Sem r a
runLibraryIO = interpret $ \case
  Computation -> embed computation
  -- ...

This is all well and good, but computation can throw exceptions! We quickly throw up some code and are able to lift a single type of exception into polysemy. We write the helper

withIOError :: forall e r a . (Exception e, Members '[Embed IO, Error e] r) => IO a -> Sem r a
withIOError action = do
  res <- embed $ try action
  case res of
       Left e  -> throw @e e
       Right x -> pure x

and then our interpreter becomes

runLibraryIO :: Members '[Embed IO, Error MyException] r => Sem (Library ': r) a -> Sem r a
runLibraryIO = interpret $ withIOError @MyException . \case
  Computation -> computation
  -- ...

but we quickly notice this is not extensible. In particular, we are only able to lift a single type of exception, and it's limited to computations in IO. We cannot dive arbitrarily deep into a monad that contains exceptions and transfer it out in a nice and pure manner. If for whatever reason we discover a corner case where computation may throw MyException', we have no way of inserting support for this and catching it elsewhere in our code!

Is there something I am missing in the library that allows me to do this? Am I stuck with dealing with exceptions in IO? Some guidance on where to go forward from here and make this sufficiently polymorphic would be greatly appreciated.

Answer 1

We can solve this with a lower interpreter. Thanks @KingoftheHomeless.

withException :: forall e r a . (E.Exception e, Member IOError r, Member (Error e) r) => Sem r a -> Sem r a
withException action = catchIO @r @e action throw

lowerIOError :: Member (Embed IO) r => (forall x. Sem r x -> IO x) -> Sem (IOError ': r) a -> Sem r a
lowerIOError lower = interpretH $ \case
  ThrowIO e -> embed $ E.throwIO e
  CatchIO m h -> do
    m' <- lowerIOError lower <$> runT m
    h' <- (lowerIOError lower .) <$> bindT h
    s  <- getInitialStateT
    embed $ lower m' `E.catch` \e -> lower (h' (e <$ s))

See this gist for it in action.