Musings about errors

Errors.hs

{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE ConstraintKinds #-}
module Errors where

import           Control.Lens              (makeClassyPrisms, ( # ))

import           Control.Monad.Except      (ExceptT (..), MonadError (..),
                                            mapExceptT, runExceptT)
import           Control.Monad.IO.Class    (MonadIO, liftIO)

import           Data.Bifunctor            (first)

import           Control.Monad.Error.Hoist

import qualified Control.Monad.Morph       as M

-- Pretend this is out of our control
data LibraryError
  = NotOutType
  deriving (Eq, Show)

newtype LibM a = LibM
  { unLibM :: ExceptT LibraryError IO a }
  deriving ( Functor
           , Applicative
           , Monad
           , MonadIO
           , MonadError LibraryError
           )

-- The following is what is in our control
data OurError
  = ParseError String
  | ReadError IOError
  | LibErr LibraryError
  deriving (Eq, Show)
makeClassyPrisms ''OurError

-- orphan instance!!
-- Not much help anyway unless we can bring the LibraryError into our `m`
instance AsOurError LibraryError where
  _OurError = _LibErr . _OurError

newtype OurAppM m a = OurAppM
  { unOurAppM :: ExceptT OurError m a }
  deriving ( Functor
           , Applicative
           , Monad
           , MonadIO
           )

runOurAppM
  :: Monad m
  => OurAppM m a
  -> m (Either OurError a)
runOurAppM =
  runExceptT . unOurAppM

instance (MonadError LibraryError m) => MonadError OurError (OurAppM m) where
  throwError = OurAppM . ExceptT . return . Left
  catchError om handleErr = OurAppM . ExceptT $ do
    catchError
      (runOurAppM om)
      (pure . Left . LibErr)
    >>= either
      (runOurAppM . handleErr)
      (pure . pure)

data Something
  = Something
  deriving (Show, Eq)

type MyErrs m =
    ( MonadError LibraryError m
    , MonadError OurError m
    )

type MyM m =
  ( MonadIO m
  , MyErrs m
  )

libraryFunction :: (MonadError LibraryError m) => m Something
libraryFunction = undefined

lessThanAwesome :: (MonadError LibraryError m, MonadError OurError m) => m Something
lessThanAwesome = libraryFunction

-- assumption of the inner @m@ being an ExceptT.
usingConcreteTypes :: Monad m => OurAppM m Something
usingConcreteTypes = OurAppM $ mapExceptT (first LibErr <$>) libraryFunction
-- or
-- usingConcreteTypes = OurAppM . ExceptT . fmap (first LibErr) . runExceptT $ libraryFunction

foo :: (MonadError LibraryError m, Monad m) => OurAppM m Something
foo = OurAppM . ExceptT $ catchError (Right <$> libraryFunction) (return . Left . LibErr)

-- No real gain for this.
-- nurg :: (MonadError LibraryError m, MonadError OurError m) => m Something
nurg :: MyM m => m Something
nurg = libraryFunction