{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Spork
-- Copyright   :  © 2009 Matt Morrow & Dan Peebles, © 2013 Liyang HU, © 2020 Kiara Grouwstra
-- License     :  see LICENSE
-- 
-- Maintainer  :  tycho01@pm.me
-- Stability   :  experimental
-- Portability :  non-portable (Scoped Type Variables)
--
-- Two functions for catching pureish exceptions in pure values. This library
-- considers pureish to be any error call or undefined, failed pattern matches,
-- arithmetic exceptions, and array bounds exceptions.
--
-----------------------------------------------------------------------------


module Control.Spork
    ( Handles
    , spork
    , sporkDefaultHandles
    , sporkWithHandles
    , teaspork
    , teasporkWithHandles
    ) where

import Control.Exception
import Control.DeepSeq
import System.IO.Unsafe

type Handles a = [Handler (Either String a)]

{-# INLINEABLE sporkDefaultHandles #-}
sporkDefaultHandles :: Handles a
sporkDefaultHandles :: Handles a
sporkDefaultHandles =
    [ (ArithException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ArithException -> IO (Either String a))
 -> Handler (Either String a))
-> (ArithException -> IO (Either String a))
-> Handler (Either String a)
forall a b. (a -> b) -> a -> b
$ \(ArithException
x :: ArithException)   -> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ ArithException -> String
forall a. Show a => a -> String
show ArithException
x)
    , (ArrayException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ArrayException -> IO (Either String a))
 -> Handler (Either String a))
-> (ArrayException -> IO (Either String a))
-> Handler (Either String a)
forall a b. (a -> b) -> a -> b
$ \(ArrayException
x :: ArrayException)   -> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ ArrayException -> String
forall a. Show a => a -> String
show ArrayException
x)
    , (ErrorCall -> IO (Either String a)) -> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ErrorCall -> IO (Either String a)) -> Handler (Either String a))
-> (ErrorCall -> IO (Either String a)) -> Handler (Either String a)
forall a b. (a -> b) -> a -> b
$ \(ErrorCall
x :: ErrorCall)        -> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ ErrorCall -> String
forall a. Show a => a -> String
show ErrorCall
x)
    , (PatternMatchFail -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((PatternMatchFail -> IO (Either String a))
 -> Handler (Either String a))
-> (PatternMatchFail -> IO (Either String a))
-> Handler (Either String a)
forall a b. (a -> b) -> a -> b
$ \(PatternMatchFail
x :: PatternMatchFail) -> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ PatternMatchFail -> String
forall a. Show a => a -> String
show PatternMatchFail
x)
    , (SomeException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO (Either String a))
 -> Handler (Either String a))
-> (SomeException -> IO (Either String a))
-> Handler (Either String a)
forall a b. (a -> b) -> a -> b
$ \(SomeException
x :: SomeException)    -> SomeException -> IO (Either String a)
forall e a. Exception e => e -> IO a
throwIO SomeException
x ]

-- | Evaluate a value to normal form and return Left if any exceptions are thrown during evaluation. For any error-free value, @spork = Right@.
{-# INLINEABLE sporkWithHandles #-}
sporkWithHandles :: NFData a => Handles a -> a -> Either String a
sporkWithHandles :: Handles a -> a -> Either String a
sporkWithHandles Handles a
handles a
a = IO (Either String a) -> Either String a
forall a. IO a -> a
unsafePerformIO (IO (Either String a) -> Either String a)
-> IO (Either String a) -> Either String a
forall a b. (a -> b) -> a -> b
$
    a -> IO (Either String a) -> IO (Either String a)
forall a b. NFData a => a -> b -> b
deepseq a
a (a -> Either String a
forall a b. b -> Either a b
Right (a -> Either String a) -> IO a -> IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a) IO (Either String a) -> Handles a -> IO (Either String a)
forall a. IO a -> [Handler a] -> IO a
`catches` Handles a
handles

-- | Evaluate a value to normal form and return Left if any exceptions are thrown during evaluation. For any error-free value, @spork = Right@.
{-# INLINE spork #-}
spork :: NFData a => a -> Either String a
spork :: a -> Either String a
spork = Handles a -> a -> Either String a
forall a. NFData a => Handles a -> a -> Either String a
sporkWithHandles Handles a
forall a. Handles a
sporkDefaultHandles

{-# INLINEABLE teasporkWithHandles #-}
teasporkWithHandles :: Handles a -> a -> Either String a
teasporkWithHandles :: Handles a -> a -> Either String a
teasporkWithHandles Handles a
handles a
a = IO (Either String a) -> Either String a
forall a. IO a -> a
unsafePerformIO (IO (Either String a) -> Either String a)
-> IO (Either String a) -> Either String a
forall a b. (a -> b) -> a -> b
$
    (a -> Either String a
forall a b. b -> Either a b
Right (a -> Either String a) -> IO a -> IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` a -> IO a
forall a. a -> IO a
evaluate a
a) IO (Either String a) -> Handles a -> IO (Either String a)
forall a. IO a -> [Handler a] -> IO a
`catches` Handles a
handles

-- | Like 'spork', but only evaluates to WHNF.
{-# INLINE teaspork #-}
teaspork :: a -> Either String a
teaspork :: a -> Either String a
teaspork = Handles a -> a -> Either String a
forall a. Handles a -> a -> Either String a
teasporkWithHandles Handles a
forall a. Handles a
sporkDefaultHandles