{-# LANGUAGE ForeignFunctionInterface #-}

{- |
  Module      :  Numeric.IEEE.FloatExceptions
  Copyright   :  (c) Sterling Clover 2008 <s.clover@gmail.com>
  License     :  BSD3
  Maintainer  :  Matt Morrow <mjm2002@gmail.com>
  Stability   :  provisional
  Portability :  portable (FFI)
-}

module Numeric.IEEE.FloatExceptions (
    getFloatExcepts
  , clearFloatExcepts
  , ArithException (..)
) where

import Foreign.C(CInt(..))
import Foreign.Ptr(Ptr)
import Foreign.Storable(peek)
import System.IO.Unsafe(unsafePerformIO)
import Control.Exception(ArithException(..))
import Data.Bits((.&.),(.|.))

foreign import ccall unsafe "fenv.h fetestexcept" c_fetestexcept :: CInt -> IO CInt
foreign import ccall unsafe "fenv.h feclearexcept" c_feclearexcept :: CInt -> IO CInt

-- | Clears the specified exceptions from the fpu's exception register.
clearFloatExcepts :: [ArithException] -> IO Bool
clearFloatExcepts xs = (==0) `fmap` (c_feclearexcept . foldr (.|.) 0 . map (fromIntegral . fromEnum) $ xs)

-- | Returns all exceptions set in the fpu's exception register.
getFloatExcepts :: IO [ArithException]
getFloatExcepts = do
  exs <- fromIntegral `fmap` c_fetestexcept (fromIntegral feAllExcept)
  return . map toEnum . filter (/=0) . map (.&. exs) $
             [feDivByZero, feInexact, feInvalid, feOverflow, feUnderflow]

instance Enum ArithException where
  toEnum n
    | n==feDivByZero  = DivideByZero
    | n==feInexact    = LossOfPrecision
    | n==feInvalid    = Denormal
    | n==feOverflow   = Overflow
    | n==feUnderflow  = Underflow
  fromEnum DivideByZero    = feDivByZero
  fromEnum LossOfPrecision = feInexact
  fromEnum Denormal        = feInvalid
  fromEnum Overflow        = feOverflow
  fromEnum Underflow       = feUnderflow

feDivByZero, feInexact, feInvalid, feOverflow, feUnderflow, feAllExcept :: Int
feDivByZero   = fromIntegral . unsafePerformIO . peek $ fe_divbyzero
feInexact     = fromIntegral . unsafePerformIO . peek $ fe_inexact
feInvalid     = fromIntegral . unsafePerformIO . peek $ fe_invalid
feOverflow    = fromIntegral . unsafePerformIO . peek $ fe_overflow
feUnderflow   = fromIntegral . unsafePerformIO . peek $ fe_underflow
feAllExcept   = fromIntegral . unsafePerformIO . peek $ fe_all_except

foreign import ccall unsafe "&" fe_divbyzero  :: Ptr CInt
foreign import ccall unsafe "&" fe_inexact    :: Ptr CInt
foreign import ccall unsafe "&" fe_invalid    :: Ptr CInt
foreign import ccall unsafe "&" fe_overflow   :: Ptr CInt
foreign import ccall unsafe "&" fe_underflow  :: Ptr CInt
foreign import ccall unsafe "&" fe_all_except :: Ptr CInt