exceptions.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

import Control.Exception qualified as X
import Data.Kind (Constraint)
import Unsafe.Coerce (unsafeCoerce)

class Throws e

newtype a ==> b = C (a => b)

hide :: forall e a. (Throws e => a) -> a
hide x = unsafeCoerce (C x :: Throws e ==> a) ()

class Throw m where
  type Throwable m e :: Constraint
  throwChecked :: Throwable m e => Throws e => e -> m a

class Catch m where
  type Catchable m e :: Constraint
  catch :: Catchable m e => (Throws e => m a) -> (e -> m a) -> m a

instance Throw IO where
  type Throwable IO e = X.Exception e
  throwChecked = X.throwIO

instance Catch IO where
  type Catchable IO e = X.Exception e
  catch value (handle :: e -> _) = X.catch (hide @e value) handle

data A = A
  deriving stock (Show)
  deriving anyclass (X.Exception)

data B = B
  deriving stock (Show)
  deriving anyclass (X.Exception)

f :: (Throws A, Throws B) => IO Int
f = throwChecked A

g :: Throws B => IO Int
g = f `catch` \A -> pure 42

h :: (Throws A, Throws B) => IO Int
h = f `catch` \A -> pure 42

main = do
  print =<< g `catch` \B -> pure 43
  print =<< (h `catch` \B -> pure 43) `catch` \A -> pure 44