Internal.hs

-- Copyright 2024 Lennart Augustsson
-- See LICENSE file for full license.
module Control.Exception.Internal(
  throw, catch,
  mask,
  onException, throwIO, bracket,
  Exception(..),
  SomeException(..),
  PatternMatchFail, NoMethodError, RecSelError, RecConError(..),
  patternMatchFail, noMethodError, recSelError, recConError,
  ) where
import qualified Prelude()
import Primitives(IO, primThen, primBind, primReturn)
import Data.Char_Type
import Data.List_Type
import Data.Maybe_Type
import {-# SOURCE #-} Data.Typeable
import Text.Show

primRaise :: forall a . SomeException -> a
primRaise = _primitive "raise"

primCatch :: forall a . IO a -> (SomeException -> IO a) -> IO a
primCatch = _primitive "catch"

throw :: forall e a. Exception e => e -> a
throw e = primRaise (toException e)

catch   :: forall e a .
           Exception e
        => IO a
        -> (e -> IO a)
        -> IO a
catch io handler = primCatch io handler'
    where handler' e = case fromException e of
                       Just e' -> handler e'
                       Nothing -> primRaise e

-- Throw an exception when executed, not when evaluated
throwIO :: forall a e . Exception e => e -> IO a
throwIO e = bad `primThen` bad   -- we never reach the second 'bad'
  where bad = throw e

onException :: IO a -> IO b -> IO a
onException io what =
  io `catch` \ e -> what `primThen` throwIO (e :: SomeException)

bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket before after thing =
  mask (\ restore ->
    before `primBind` (\ a ->
    (restore (thing a) `onException` after a) `primBind` (\ r ->
    after a `primThen`
    primReturn r
    )))

-- XXX we don't have masks yet
mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
mask io = io (\ x -> x)

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

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

-- NOTE: The runtime system knows about this class.
-- It uses displayException to show an uncaught exception.
-- Any changes here must be reflected in eval.c
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 Show SomeException where
  showsPrec p (SomeException e) = showsPrec p e

-- NOTE: The runtime system knows about this instance.
-- It uses displayException to show an uncaught exception.
-- Any changes here must be reflected in eval.c
instance Exception SomeException where
  toException se = se
  fromException = Just
  displayException (SomeException e) = displayException e

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

-- Errors generated by the compiler
-- NOTE: Do not change the names or locations of these definitions.
-- The compiler knows about them.

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

instance Show PatternMatchFail where showsPrec _ (PatternMatchFail s) r = showString "no match at "     (showString s r)
instance Show NoMethodError    where showsPrec _ (NoMethodError    s) r = showString "no default for "  (showString s r)
instance Show RecSelError      where showsPrec _ (RecSelError      s) r = showString "no field "        (showString s r)
instance Show RecConError      where showsPrec _ (RecConError      s) r = showString "uninit field "    (showString s r)

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

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

noMethodError    s = throw (NoMethodError    s)
patternMatchFail s = throw (PatternMatchFail s)
recSelError      s = throw (RecSelError      s)
recConError      s = throw (RecConError      s)