module Control.ExceptionX(
  module Control.ExceptionX
  ) where
import Prelude
import Data.Typeable

------------------

primRaiseX :: forall a . SomeException -> a
primRaiseX = primitive "raiseX"
primCatchX :: forall a . IO a -> (SomeException -> IO a) -> IO a
primCatchX = primitive "catchX"

throwX :: forall e a. Exception e => e -> a
throwX e = primRaiseX (toException e)

throwXIO :: forall e a. Exception e => e -> IO a
throwXIO e = primRaiseX (toException e)

catchX   :: forall e a .
           Exception e
        => IO a
        -> (e -> IO a)
        -> IO a
catchX io handler = primCatchX io handler'
    where handler' e = case fromException e of
                       Just e' -> handler e'
                       Nothing -> throwXIO e

tryX :: forall e a . Exception e => IO a -> IO (Either e a)
tryX ioa = catchX (fmap Right ioa) (return . Left)

------------------

data SomeException = forall e . Exception e => SomeException e
  deriving (Typeable)

instance Show SomeException where
    showsPrec p (SomeException e) = showsPrec p e

class (Typeable e, Show e) => Exception e where
    toException      :: e -> SomeException
    fromException    :: SomeException -> Maybe e
    displayException :: e -> String

    toException = SomeException
    fromException (SomeException e) = cast e
    displayException = show

instance Exception SomeException where
    toException se = se
    fromException = Just
    displayException (SomeException e) = displayException e

------------------

-- Call to 'error'
data ErrorCall = ErrorCall String
  deriving (Typeable)

instance Show ErrorCall where
  showsPrec _ (ErrorCall err) = showString err

instance Exception ErrorCall

--errorCallException :: String -> SomeException
--errorCallException s = toException (ErrorCall s)

------------------

-- Errors generated by the compiler

newtype PatternMatchFail = PatternMatchFail String deriving (Typeable)
newtype RecSelError      = RecSelError      String deriving (Typeable)
newtype RecConError      = RecConError      String deriving (Typeable)
newtype RecUpdError      = RecUpdError      String deriving (Typeable)
newtype NoMethodError    = NoMethodError    String deriving (Typeable)

instance Show PatternMatchFail where showsPrec _ (PatternMatchFail s) = showString s
instance Show RecSelError      where showsPrec _ (RecSelError      s) = showString s
instance Show RecConError      where showsPrec _ (RecConError      s) = showString s
instance Show RecUpdError      where showsPrec _ (RecUpdError      s) = showString s
instance Show NoMethodError    where showsPrec _ (NoMethodError    s) = showString s

instance Exception PatternMatchFail
instance Exception RecSelError
instance Exception RecConError
instance Exception RecUpdError
instance Exception NoMethodError

patternMatchFail :: forall a . String -> a
recSelError      :: forall a . String -> a
recConError      :: forall a . String -> a
recUpdError      :: forall a . String -> a
noMethodError    :: forall a . String -> a

patternMatchFail s = throwX (PatternMatchFail s)
recSelError      s = throwX (RecSelError      s)
recConError      s = throwX (RecConError      s)
recUpdError      s = throwX (RecUpdError      s)
noMethodError    s = throwX (NoMethodError    s)

------------------