-- 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(ErrorCallWithLocation, 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 "Non-exhaustive patterns "
                                       (showString s r)
instance Show NoMethodError where
  showsPrec _ (NoMethodError    s) r = showString "No instance nor default method for class operation "
                                       (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 "Missing field in record construction "
                                       (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"

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

data ErrorCall = ErrorCallWithLocation String String  -- message and location

instance Exception ErrorCall

instance Show ErrorCall where
  showsPrec _ (ErrorCallWithLocation s l) r = showString "error: " (showString l (showString s r))

pattern ErrorCall :: String -> ErrorCall
pattern ErrorCall s <- ErrorCallWithLocation s _
  where ErrorCall s = ErrorCallWithLocation s ""