Error handling with the continuation monad

EH.hs

import Control.Applicative
import Control.Monad

-- Examples

example1 :: M r String ()
example1 = do
  newError "expected True"
  True <- bad
  pure ()
 where bad = pure False

example2 :: M r String ()
example2 = do
  bad `onNothing` "tried to unwrap Nothing"
 where bad = Nothing

example3 :: M r String ()
example3 = do
  updateError ("in example3: " ++)
  example2

-- Implementation

-- Error-handling monad
newtype M r e a = M ((a -> Either (Maybe e) r) -> Either (Maybe e) r)

runM :: M a e a -> Either (Maybe e) a
runM (M f) = f Right

throw :: e -> M r e a
throw e = M (\_ -> Left (Just e))

instance Functor (M r e) where
  fmap = liftA

instance Applicative (M r e) where
  pure x = M (\k -> k x)
  (<*>) = ap

instance Monad (M r e) where
  M f >>= t = M (\k ->
    f (\x -> let M g = t x in g k))

instance MonadFail (M r e) where
  fail _ = M (\_ -> Left Nothing)

newError :: e -> M r e ()
newError e = M (\k -> case k () of
  Left Nothing -> Left (Just e)
  r -> r)

updateError :: (e -> e) -> M r e ()
updateError f = M (\k -> case k () of
  Left (Just e) -> Left (Just (f e))
  r -> r)

onNothing :: Maybe a -> e -> M r e a
onNothing (Just a) _ = pure a
onNothing Nothing e = throw e

main :: IO ()
main = do
  print $ map runM [example1, example2, example3]