module Numeric.IEEE.Monad where
import Numeric.IEEE.RoundMode (RoundMode(..))
import qualified Numeric.IEEE.RoundMode as RM
import qualified Numeric.IEEE.FloatExceptions as FE
import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad
withIeeeDo :: ((?ieeeMutex :: MVar ()) => IO a) -> IO a
withIeeeDo f = newMVar () >>= \x -> let ?ieeeMutex = x in f
newtype IEEE a = IEEE {unIEEE :: IO a} deriving (Monad, Functor, Applicative)
runIEEE :: (?ieeeMutex :: MVar()) => IEEE a -> IO a
runIEEE f = do
takeMVar ?ieeeMutex
ret <- unIEEE f
putMVar ?ieeeMutex ()
return ret
getRound :: IEEE RoundMode
getRound = IEEE RM.getRound
setRound :: RoundMode -> IEEE Bool
setRound m = IEEE $ RM.setRound m
clearFloatExcepts :: [ArithException] -> IEEE Bool
clearFloatExcepts xs = IEEE $ FE.clearFloatExcepts xs
getFloatExcepts :: IEEE [ArithException]
getFloatExcepts = IEEE FE.getFloatExcepts
calculate :: a -> IEEE a
calculate = IEEE . evaluate
calculate' :: a -> IEEE (a,[FE.ArithException])
calculate' f = do
getFloatExcepts >>= clearFloatExcepts
ret <- IEEE . evaluate $ f
exs <- getFloatExcepts
return (ret,exs)
withRoundMode :: RoundMode -> IEEE a -> IEEE a
withRoundMode r f = do
x <- getRound
if x == r then f else setRound r >> (f >>= calculate) >>= \ret -> setRound x >> return ret
perturb' :: (?ieeeMutex :: MVar (), Floating b) => (forall a. Floating a => IEEE a) -> IO (b, b, b, b)
perturb' f = runIEEE $ do
x <- getRound
setRound Upward
u <- calculate =<< foo f
setRound Downward
d <- calculate =<< foo f
setRound ToNearest
tn <- calculate =<< foo f
setRound TowardZero
tz <- calculate =<< foo f
setRound x
return (u,d,tn,tz)
where foo :: Floating b => (forall c. Floating c => IEEE c) -> IEEE b
foo = id
perturb :: (?ieeeMutex :: MVar (), Floating b) => (forall a. Floating a => IEEE a) -> IO b
perturb f = do
(u,d,_,_) <- perturb' f
return $ abs (u d)
perturbedMag :: (?ieeeMutex :: MVar (), Floating b) => (forall a. Floating a => IEEE a) -> IO b
perturbedMag f = do
(u,d,_,_) <- perturb' f
return $ abs ((u d) / (u + d))