A snapshot of thoughts on error handling

Checker.hs

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}


module Checker
    ( Checked(..)
    , CheckedIO
    , Throws
    , S.MonadCatch
    , S.MonadThrow
    , S.MonadMask(..)
    , runChecked
    , throw
    , try
    , catch
    , handle
    , handler
    , catches
    , handles
    , finally
    , onException
    , withException
    , bracket
    , bracketOnError
    , withHandler
    ) where


import qualified Control.Exception.Safe as S


newtype Checked (l :: [*]) m a
    = Checked { unChecked :: m a }
    deriving (Functor, Applicative, Monad)

type CheckedIO l a = Checked l IO a

newtype Handler m a e = Handler [S.Handler m a]

class Throws e l

type family Append as bs where
    Append (h : t) l = h : Append t l
    Append '[] l = l

instance {-# OVERLAPS #-} Throws e (e : l)
instance {-# OVERLAPPABLE #-} Throws e l => Throws e (e' : l)
instance {-# OVERLAPPING #-} Throws e (S.SomeException : l)


runChecked
    :: Checked '[] m a
    -> m a
runChecked = unChecked

throw
    :: (Throws e l, S.Exception e, S.MonadThrow m)
    => e
    -> Checked l m a
throw = Checked . S.throw

try
    :: (S.Exception e, S.MonadCatch m)
    => Checked (e : l) m a
    -> Checked l m (Either e a)
try = Checked . S.try . unChecked

catch
    :: (S.Exception e, S.MonadCatch m)
    => Checked (e : l) m a
    -> (e -> Checked l m a)
    -> Checked l m a
catch f g =
    Checked $ S.catch (unChecked f) (unChecked . g)

handle
    :: (S.Exception e, S.MonadCatch m)
    => (e -> Checked l m a)
    -> Checked (e : l) m a
    -> Checked l m a
handle = flip catch

catches
    :: (S.MonadCatch m, S.MonadThrow m)
    => Checked (Append es l) m a
    -> Handler m a es
    -> Checked l m a
catches f (Handler handlers) =
    Checked $ S.catches (unChecked f) handlers

handler
    :: S.Exception e
    => (e -> Checked l m a)
    -> Handler m a '[e]
handler h = Handler [S.Handler $ unChecked . h]

withHandler
    :: S.Exception e
    => Handler m a es
    -> (e -> Checked l m a)
    -> Handler m a (e:es)
withHandler (Handler hs) h = Handler $ (S.Handler $ unChecked . h) : hs

handles
    :: (S.MonadCatch m, S.MonadThrow m)
    => Handler m a es
    -> Checked (Append es l) m a
    -> Checked l m a
handles = flip catches

finally
    :: S.MonadMask m
    => Checked l m a
    -> Checked l m b
    -> Checked l m a
finally thing after =
    Checked $ S.finally (unChecked thing) (unChecked after)

onException
    :: S.MonadMask m
    => Checked l m a
    -> Checked l m b
    -> Checked l m a
onException thing after =
    Checked $ S.onException (unChecked thing) (unChecked after)

withException
    :: (S.Exception e, S.MonadMask m)
    => Checked l m a
    -> (e -> Checked l m b)
    -> Checked l m a
withException thing after =
    Checked $ S.withException (unChecked thing) (unChecked . after)

bracket
    :: S.MonadMask m
    => Checked l m a
    -> (a -> Checked l m b)
    -> (a -> Checked l m c)
    -> Checked l m c
bracket before after thing =
    Checked $ S.bracket (unChecked before) (unChecked . after) (unChecked . thing)

bracketOnError
    :: S.MonadMask m
    => Checked l m a
    -> (a -> Checked l m b)
    -> (a -> Checked l m c)
    -> Checked l m c
bracketOnError before after thing =
    Checked $ S.bracketOnError (unChecked before) (unChecked . after) (unChecked . thing)

Play.hs

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE ScopedTypeVariables #-}


module Play where


import           Protolude

import qualified Checker   as C


data FooE = FooE deriving (Show, Typeable)
data BarE = BarE deriving (Show, Typeable)
data BazE = BazE deriving (Show, Typeable)

instance Exception FooE
instance Exception BarE
instance Exception BazE

throwsFoo :: C.Throws FooE e => C.CheckedIO e ()
throwsFoo = C.throw FooE

throwsBar :: C.Throws BarE e => C.CheckedIO e ()
throwsBar = C.throw BarE

throwsBaz :: C.Throws BazE e => C.CheckedIO e ()
throwsBaz = C.throw BazE

throwsFooBaz :: (C.Throws FooE e, C.Throws BazE e) => C.CheckedIO e ()
throwsFooBaz = throwsFoo *> throwsBaz

test1 :: IO ()
test1 =
    C.runChecked $ throwsFooBaz
        `C.catches` (C.handler handleFoo `C.withHandler` handleBaz)
    where
    handleFoo (_::FooE) = pure ()
    handleBaz (_::BazE) = pure ()

test2 :: IO ()
test2 = C.runChecked $ throwsFooBaz `C.catch` handleBaz `C.catch` handleFoo
    where
    handleFoo (_::FooE) = pure ()
    handleBaz (_::BazE) = pure ()

test3 :: IO ()
test3 = C.runChecked $ throwsFooBaz `C.catch` handleFoo `C.catch` handleBaz
    where
    handleFoo (_::FooE) = pure ()
    handleBaz (_::BazE) = pure ()