{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}

-- | Double datatype with saner instances
module GHC.Types.SaneDouble
  ( SaneDouble (..)
  )
where

import GHC.Prelude
import GHC.Utils.Binary
import GHC.Float (castDoubleToWord64, castWord64ToDouble)

-- | A newtype wrapper around 'Double' to ensure we never generate a 'Double'
-- that becomes a 'NaN', see instances for details on sanity.
newtype SaneDouble = SaneDouble
  { SaneDouble -> Double
unSaneDouble :: Double
  }
  deriving (Num SaneDouble
Num SaneDouble =>
(SaneDouble -> SaneDouble -> SaneDouble)
-> (SaneDouble -> SaneDouble)
-> (Rational -> SaneDouble)
-> Fractional SaneDouble
Rational -> SaneDouble
SaneDouble -> SaneDouble
SaneDouble -> SaneDouble -> SaneDouble
forall a.
Num a =>
(a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
$c/ :: SaneDouble -> SaneDouble -> SaneDouble
/ :: SaneDouble -> SaneDouble -> SaneDouble
$crecip :: SaneDouble -> SaneDouble
recip :: SaneDouble -> SaneDouble
$cfromRational :: Rational -> SaneDouble
fromRational :: Rational -> SaneDouble
Fractional, Integer -> SaneDouble
SaneDouble -> SaneDouble
SaneDouble -> SaneDouble -> SaneDouble
(SaneDouble -> SaneDouble -> SaneDouble)
-> (SaneDouble -> SaneDouble -> SaneDouble)
-> (SaneDouble -> SaneDouble -> SaneDouble)
-> (SaneDouble -> SaneDouble)
-> (SaneDouble -> SaneDouble)
-> (SaneDouble -> SaneDouble)
-> (Integer -> SaneDouble)
-> Num SaneDouble
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: SaneDouble -> SaneDouble -> SaneDouble
+ :: SaneDouble -> SaneDouble -> SaneDouble
$c- :: SaneDouble -> SaneDouble -> SaneDouble
- :: SaneDouble -> SaneDouble -> SaneDouble
$c* :: SaneDouble -> SaneDouble -> SaneDouble
* :: SaneDouble -> SaneDouble -> SaneDouble
$cnegate :: SaneDouble -> SaneDouble
negate :: SaneDouble -> SaneDouble
$cabs :: SaneDouble -> SaneDouble
abs :: SaneDouble -> SaneDouble
$csignum :: SaneDouble -> SaneDouble
signum :: SaneDouble -> SaneDouble
$cfromInteger :: Integer -> SaneDouble
fromInteger :: Integer -> SaneDouble
Num)

instance Eq SaneDouble where
    (SaneDouble Double
x) == :: SaneDouble -> SaneDouble -> Bool
== (SaneDouble Double
y) = Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
y Bool -> Bool -> Bool
|| (Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
x Bool -> Bool -> Bool
&& Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
y)

instance Ord SaneDouble where
    compare :: SaneDouble -> SaneDouble -> Ordering
compare (SaneDouble Double
x) (SaneDouble Double
y) = Maybe Double -> Maybe Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Double -> Maybe Double
forall {a}. RealFloat a => a -> Maybe a
fromNaN Double
x) (Double -> Maybe Double
forall {a}. RealFloat a => a -> Maybe a
fromNaN Double
y)
        where fromNaN :: a -> Maybe a
fromNaN a
z | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
z = Maybe a
forall a. Maybe a
Nothing
                        | Bool
otherwise = a -> Maybe a
forall a. a -> Maybe a
Just a
z

instance Show SaneDouble where
    show :: SaneDouble -> String
show (SaneDouble Double
x) = Double -> String
forall a. Show a => a -> String
show Double
x

-- we need to preserve NaN and infinities, unfortunately the Binary instance for
-- Double does not do this
instance Binary SaneDouble where
  put_ :: WriteBinHandle -> SaneDouble -> IO ()
put_ WriteBinHandle
bh (SaneDouble Double
d)
    | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d               = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1
    | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d Bool -> Bool -> Bool
&& Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
2
    | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d Bool -> Bool -> Bool
&& Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
3
    | Double -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero Double
d      = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
4
    | Bool
otherwise             = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
5 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriteBinHandle -> Word64 -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Double -> Word64
castDoubleToWord64 Double
d)
  get :: ReadBinHandle -> IO SaneDouble
get ReadBinHandle
bh = ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh IO Word8 -> (Word8 -> IO SaneDouble) -> IO SaneDouble
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Word8
1 -> SaneDouble -> IO SaneDouble
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SaneDouble -> IO SaneDouble) -> SaneDouble -> IO SaneDouble
forall a b. (a -> b) -> a -> b
$ Double -> SaneDouble
SaneDouble (Double
0    Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0)
    Word8
2 -> SaneDouble -> IO SaneDouble
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SaneDouble -> IO SaneDouble) -> SaneDouble -> IO SaneDouble
forall a b. (a -> b) -> a -> b
$ Double -> SaneDouble
SaneDouble (Double
1    Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0)
    Word8
3 -> SaneDouble -> IO SaneDouble
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SaneDouble -> IO SaneDouble) -> SaneDouble -> IO SaneDouble
forall a b. (a -> b) -> a -> b
$ Double -> SaneDouble
SaneDouble ((-Double
1) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0)
    Word8
4 -> SaneDouble -> IO SaneDouble
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SaneDouble -> IO SaneDouble) -> SaneDouble -> IO SaneDouble
forall a b. (a -> b) -> a -> b
$ Double -> SaneDouble
SaneDouble (-Double
0)
    Word8
5 -> Double -> SaneDouble
SaneDouble (Double -> SaneDouble)
-> (Word64 -> Double) -> Word64 -> SaneDouble
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Double
castWord64ToDouble (Word64 -> SaneDouble) -> IO Word64 -> IO SaneDouble
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO Word64
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
    Word8
n -> String -> IO SaneDouble
forall a. HasCallStack => String -> a
error (String
"Binary get bh SaneDouble: invalid tag: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
n)