-- | Support for checked exceptions.
module Effectful.Error
 ( Error
 , runError
 , throwError
 , catchError
 , tryError
 ) where

import Control.Exception
import Data.Typeable
import GHC.Stack

import Effectful.Internal.Env
import Effectful.Internal.Has
import Effectful.Internal.Monad
import Effectful.Internal.Utils

type role Error nominal
data Error e = Error

runError
  :: forall e es a. Exception e
  => Eff (Error e : es) a
  -> Eff es (Either ([String], e) a)
runError :: Eff (Error e : es) a -> Eff es (Either ([String], e) a)
runError (Eff Env (Error e : es) -> IO a
m) = (Env es -> IO (Either ([String], e) a))
-> Eff es (Either ([String], e) a)
forall (es :: [*]) a. (Env es -> IO a) -> Eff es a
impureEff ((Env es -> IO (Either ([String], e) a))
 -> Eff es (Either ([String], e) a))
-> (Env es -> IO (Either ([String], e) a))
-> Eff es (Either ([String], e) a)
forall a b. (a -> b) -> a -> b
$ \Env es
es0 -> ((forall a. IO a -> IO a) -> IO (Either ([String], e) a))
-> IO (Either ([String], e) a)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO (Either ([String], e) a))
 -> IO (Either ([String], e) a))
-> ((forall a. IO a -> IO a) -> IO (Either ([String], e) a))
-> IO (Either ([String], e) a)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
release -> do
  Int
size <- Env es -> IO Int
forall (es :: [*]). Env es -> IO Int
sizeEnv Env es
es0
  Env (Error e : es)
es <- Error e -> Env es -> IO (Env (Error e : es))
forall e (es :: [*]).
HasCallStack =>
e -> Env es -> IO (Env (e : es))
unsafeConsEnv (Error e
forall k (e :: k). Error e
Error @e) Env es
es0
  IO a -> IO (Either (WrapE e) a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO a
forall a. IO a -> IO a
release (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Env (Error e : es) -> IO a
m Env (Error e : es)
es) IO (Either (WrapE e) a)
-> (Either (WrapE e) a -> IO (Either ([String], e) a))
-> IO (Either ([String], e) a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right a
a           -> a -> Either ([String], e) a
forall a b. b -> Either a b
Right a
a      Either ([String], e) a
-> IO (Env Any) -> IO (Either ([String], e) a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int -> Env (Error e : es) -> IO (Env Any)
forall (es :: [*]) (es0 :: [*]).
HasCallStack =>
Int -> Env es -> IO (Env es0)
unsafeTrimEnv Int
size Env (Error e : es)
es
    Left (WrapE [String]
cs e
e) -> ([String], e) -> Either ([String], e) a
forall a b. a -> Either a b
Left ([String]
cs, e
e) Either ([String], e) a
-> IO (Env Any) -> IO (Either ([String], e) a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int -> Env (Error e : es) -> IO (Env Any)
forall (es :: [*]) (es0 :: [*]).
HasCallStack =>
Int -> Env es -> IO (Env es0)
unsafeTrimEnv Int
size Env (Error e : es)
es

throwError
  :: (HasCallStack, Exception e, Error e :> es)
  => e
  -> Eff es a
throwError :: e -> Eff es a
throwError e
e = IO a -> Eff es a
forall a (es :: [*]). IO a -> Eff es a
impureEff_ (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ do
  WrapE e -> IO a
forall e a. Exception e => e -> IO a
throwIO (WrapE e -> IO a) -> WrapE e -> IO a
forall a b. (a -> b) -> a -> b
$ [String] -> e -> WrapE e
forall e. [String] -> e -> WrapE e
WrapE ((String, SrcLoc) -> String
ppCallStack ((String, SrcLoc) -> String) -> [(String, SrcLoc)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack) e
e

catchError
  :: (Exception e, Error e :> es)
  => Eff es a
  -> ([String] -> e -> Eff es a)
  -> Eff es a
catchError :: Eff es a -> ([String] -> e -> Eff es a) -> Eff es a
catchError (Eff Env es -> IO a
m) [String] -> e -> Eff es a
handler = (Env es -> IO a) -> Eff es a
forall (es :: [*]) a. (Env es -> IO a) -> Eff es a
impureEff ((Env es -> IO a) -> Eff es a) -> (Env es -> IO a) -> Eff es a
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
  Int
size <- Env es -> IO Int
forall (es :: [*]). Env es -> IO Int
sizeEnv Env es
es
  Env es -> IO a
m Env es
es IO a -> (WrapE e -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(WrapE [String]
e e
cs) -> do
    Int -> Env es -> IO ()
forall (es :: [*]). HasCallStack => Int -> Env es -> IO ()
checkSizeEnv Int
size Env es
es
    Eff es a -> Env es -> IO a
forall (es :: [*]) a. Eff es a -> Env es -> IO a
unEff ([String] -> e -> Eff es a
handler [String]
e e
cs) Env es
es

tryError
  :: (Exception e, Error e :> es)
  => Eff es a
  -> Eff es (Either ([String], e) a)
tryError :: Eff es a -> Eff es (Either ([String], e) a)
tryError Eff es a
m = (a -> Either ([String], e) a
forall a b. b -> Either a b
Right (a -> Either ([String], e) a)
-> Eff es a -> Eff es (Either ([String], e) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es a
m) Eff es (Either ([String], e) a)
-> ([String] -> e -> Eff es (Either ([String], e) a))
-> Eff es (Either ([String], e) a)
forall e (es :: [*]) a.
(Exception e, Error e :> es) =>
Eff es a -> ([String] -> e -> Eff es a) -> Eff es a
`catchError` \[String]
es e
e -> Either ([String], e) a -> Eff es (Either ([String], e) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([String], e) -> Either ([String], e) a
forall a b. a -> Either a b
Left ([String]
es, e
e))

----------------------------------------
-- WrapE

data WrapE e = WrapE [String] e
  deriving Int -> WrapE e -> ShowS
[WrapE e] -> ShowS
WrapE e -> String
(Int -> WrapE e -> ShowS)
-> (WrapE e -> String) -> ([WrapE e] -> ShowS) -> Show (WrapE e)
forall e. Show e => Int -> WrapE e -> ShowS
forall e. Show e => [WrapE e] -> ShowS
forall e. Show e => WrapE e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WrapE e] -> ShowS
$cshowList :: forall e. Show e => [WrapE e] -> ShowS
show :: WrapE e -> String
$cshow :: forall e. Show e => WrapE e -> String
showsPrec :: Int -> WrapE e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> WrapE e -> ShowS
Show
instance (Show e, Typeable e) => Exception (WrapE e)