    {-# 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)