content: -- Copyright 2024,2025 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,
    AsyncException(..),
    ArithException(..),
    SomeAsyncException(..),
    asyncExceptionToException,
    asyncExceptionFromException,
    BlockedIndefinitelyOnMVar(..),
    BlockedIndefinitelyOnSTM(..),
    ErrorCall(..),
  
    uninterruptibleMask,
    uninterruptibleMask_,
    MaskingState(..),
    getMaskingState,
    interruptible,
  
    unsafeUnmask,
    ) where
  import qualified Prelude()
  import Primitives
  import Data.Bool
  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 (rtsExn e) of
                         Just e' -> handler e'
                         Nothing -> primRaise e
  
  -- The runtime system sometimes needs to generate exceptions.
  -- It is quite difficult to create SomeException value since
  -- it involves an existential data type with several dictionaries.
  -- So, instead, the runtime uses an INT value to convey that
  -- RTS exception has happened.  So the incoming SomeException
  -- is sometimes just a regular Int.  Here is where we translate that
  -- back to a real SomeException.
  -- The translation here has to be kept in sync with the enum rts_exn
  -- in eval.c.
  -- The magic primIsInt primitive returns the Int if it is one, otherwise -1.
  rtsExn :: SomeException -> SomeException
  rtsExn e =
    let n = primIsInt e
    in       if primIntEQ n (0::Int) then SomeException StackOverflow
        else if primIntEQ n (1::Int) then SomeException HeapOverflow
        else if primIntEQ n (2::Int) then SomeException ThreadKilled
        else if primIntEQ n (3::Int) then SomeException UserInterrupt
        else if primIntEQ n (4::Int) then SomeException DivideByZero
        else if primIntEQ n (5::Int) then SomeException BlockedIndefinitelyOnMVar
        else if primIntEQ n (6::Int) then SomeException BlockedIndefinitelyOnSTM
        else 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
      )))
  
  ------------------
  
  data SomeException = forall e . Exception e => SomeException e
  
  -- 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)
  
  -------------------
  
  data ArithException
    = Overflow
    | Underflow
    | LossOfPrecision
    | DivideByZero
    | Denormal
    | RatioZeroDenominator
    deriving ({-Eq, Ord,-} Typeable)  -- Eq, Ord in Exception module
  
  instance Show ArithException where
    show Overflow             = "arithmetic overflow"
    show Underflow            = "arithmetic underflow"
    show LossOfPrecision      = "loss of precision"
    show DivideByZero         = "divide by zero"
    show Denormal             = "denormal"
    show RatioZeroDenominator = "Ratio has zero denominator"
  
  instance Exception ArithException
  
  -------------------
  
  data AsyncException
    = StackOverflow
    | HeapOverflow
    | ThreadKilled
    | UserInterrupt
    deriving ({-Eq, Ord,-} Typeable)  -- Eq, Ord in Exception module
  
  instance Show AsyncException where
    showsPrec _ StackOverflow   = showString "stack overflow"
    showsPrec _ HeapOverflow    = showString "heap overflow"
    showsPrec _ ThreadKilled    = showString "thread killed"
    showsPrec _ UserInterrupt   = showString "user interrupt"
  
  instance Exception AsyncException where
    toException = asyncExceptionToException
    fromException = asyncExceptionFromException
  
  data SomeAsyncException = forall e . Exception e => SomeAsyncException e
  
  instance Show SomeAsyncException where
      showsPrec p (SomeAsyncException e) = showsPrec p e
  
  instance Exception SomeAsyncException
  
  asyncExceptionToException :: Exception e => e -> SomeException
  asyncExceptionToException e = toException (SomeAsyncException e)
  
  asyncExceptionFromException :: Exception e => SomeException -> Maybe e
  asyncExceptionFromException x =
    case fromException x of
      Just (SomeAsyncException a) -> cast a
      Nothing -> Nothing
  
  ---------
  
  -- Must be in the same order as enum mask_state in eval.c.
  data MaskingState
    = Unmasked
    | MaskedInterruptible
    | MaskedUninterruptible
  --  deriving (Enum) causes circular import
  --  deriving (Eq, Show)  in Control.Exception
  
  fromEnum :: MaskingState -> Int
  fromEnum Unmasked = 0
  fromEnum MaskedInterruptible = 1
  fromEnum _ = 2
  
  toEnum :: Int -> MaskingState
  toEnum i | i `primIntEQ` 0 = Unmasked
           | i `primIntEQ` 1 = MaskedInterruptible
           | otherwise       = MaskedUninterruptible
  
  getMaskingState :: IO MaskingState
  getMaskingState = primGetMaskingState `primBind` \ s -> primReturn (toEnum s)
  
  withMaskingState :: MaskingState -> IO a -> IO a
  withMaskingState s io =
    primGetMaskingState `primBind` \ os ->
    primSetMaskingState (fromEnum s) `primThen`
    io `primBind` \ a ->
    primSetMaskingState os `primThen`
    primReturn a
  
  mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
  mask io =
    getMaskingState `primBind` \ b ->
    case b of
      Unmasked              -> block (io unblock)
      MaskedInterruptible   -> io block
      MaskedUninterruptible -> io blockUninterruptible
  
  uninterruptibleMask :: forall a . IO a -> IO a
  uninterruptibleMask_ io = uninterruptibleMask (\ _ -> io)
  
  uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
  uninterruptibleMask io =
    getMaskingState `primBind` \ b ->
    case b of
      Unmasked              -> blockUninterruptible (io unblock)
      MaskedInterruptible   -> blockUninterruptible (io block)
      MaskedUninterruptible -> io blockUninterruptible
  
  unsafeUnmask :: IO a -> IO a
  unsafeUnmask = withMaskingState Unmasked
  
  block :: IO a -> IO a
  block = withMaskingState MaskedInterruptible
  
  blockUninterruptible :: IO a -> IO a
  blockUninterruptible = withMaskingState MaskedUninterruptible
  
  unblock :: IO a -> IO a
  unblock = unsafeUnmask
  
  interruptible :: IO a -> IO a
  interruptible :: forall a. IO a -> IO a
  interruptible act =
    getMaskingState `primBind` \ b ->
    case b of
      Unmasked              -> act
      MaskedInterruptible   -> unsafeUnmask act
      MaskedUninterruptible -> act
  
  
  --------------------
  
  data BlockedIndefinitelyOnMVar = BlockedIndefinitelyOnMVar
  
  instance Exception BlockedIndefinitelyOnMVar
  
  instance Show BlockedIndefinitelyOnMVar where
    showsPrec _ BlockedIndefinitelyOnMVar = showString "thread blocked indefinitely in an MVar operation"
  
  data BlockedIndefinitelyOnSTM = BlockedIndefinitelyOnSTM
  
  instance Exception BlockedIndefinitelyOnSTM
  
  instance Show BlockedIndefinitelyOnSTM where
    showsPrec _ BlockedIndefinitelyOnSTM = showString "thread blocked indefinitely in an STM transaction"
  
  --------------------
  
  newtype ErrorCall = ErrorCall String
  
  instance Exception ErrorCall
  
  instance Show ErrorCall where
    showsPrec _ (ErrorCall s) r = showString "error: " (showString s r)
  