fp-ieee-0.1.0.7: test/Float128Spec.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE HexFloatLiterals #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Float128Spec where
import           AugmentedArithSpec (augmentedAddition_viaRational,
                                     augmentedMultiplication_viaRational)
import qualified AugmentedArithSpec
import qualified ClassificationSpec
import qualified ConversionSpec
import           Control.Monad
import           Data.Function (on)
import           Data.Functor.Identity
import           Data.Int
import           Data.Proxy
import           Data.Ratio
import           FMASpec (fusedMultiplyAdd_generic,
                          fusedMultiplyAdd_viaRational)
import qualified FMASpec
import qualified NaNSpec
import qualified NextFloatSpec
import           Numeric.Float128
import           Numeric.Floating.IEEE
import           Numeric.Floating.IEEE.Internal
import           Numeric.Floating.IEEE.NaN (setPayloadSignaling)
import qualified RemainderSpec
import qualified RoundingSpec
import qualified RoundToIntegralSpec
import           System.Random
import           Test.Hspec
import           Test.Hspec.QuickCheck
import           Test.QuickCheck hiding (classify)
import           TwoSumSpec (twoProduct_generic)
import qualified TwoSumSpec
import           Util

-- orphan instances
instance Arbitrary Float128 where
  arbitrary = arbitrarySizedFractional
  shrink = shrinkDecimal

instance Random Float128 where
  -- Float128:
  --   emin = -14, emax = 15
  --   precision = 11 bits
  --   maxFinite = 0xffe0 (65504)
  randomR (lo,hi) g = let (x,g') = random g
                      in (lo + x * (hi - lo), g') -- TODO: avoid overflow
  random g = let x :: Int64
                 (x,g') = random g
             in (fromRational (toInteger x % 2^(16 :: Int)), g') -- TODO

fromRationalIsBuggy :: Spec -> Spec
fromRationalIsBuggy = mapSpecItem_ (allowFailure "Float128's fromRational may be incorrect")

roundIsBuggy :: Spec -> Spec
roundIsBuggy = mapSpecItem_ (allowFailure "Float128's round may be incorrect")

spec :: Spec
spec = do
  let proxy :: Proxy Float128
      proxy = Proxy
  prop "classify" $ forAllFloats $ ClassificationSpec.prop_classify proxy
  prop "classify (generic)" $ forAllFloats $ ClassificationSpec.prop_classify (Proxy :: Proxy (Identity Float128)) . Identity
  prop "totalOrder" $ forAllFloats2 $ ClassificationSpec.prop_totalOrder proxy
  prop "totalOrder (generic)" $ forAllFloats2 (ClassificationSpec.prop_totalOrder (Proxy :: Proxy (Identity Float128)) `on` Identity)
  prop "twoSum" $ forAllFloats2 $ TwoSumSpec.prop_twoSum proxy
  fromRationalIsBuggy $ prop "twoProduct" $ forAllFloats2 $ TwoSumSpec.prop_twoProduct proxy twoProduct
  fromRationalIsBuggy $ prop "twoProduct_generic" $ forAllFloats2 $ TwoSumSpec.prop_twoProduct proxy twoProduct_generic
  let casesForFloat128 :: [(Float128, Float128, Float128, Float128)]
      casesForFloat128 = [ (-0, 0, -0, -0)
                         , (-0, -0, -0, 0)
                         , (0x1.ffff_ffff_ffff_ffff_ffff_ffff_fffdp-8191, 0x1.0000_0000_0000_0000_0000_0000_0001p-8192, 0.0, 0x1.ffff_ffff_ffff_ffff_ffff_ffff_ffffp-16383)
                         -- TODO: Add more
                         ]
  fromRationalIsBuggy $ FMASpec.checkFMA "fusedMultiplyAdd (default)"      fusedMultiplyAdd             casesForFloat128
  fromRationalIsBuggy $ FMASpec.checkFMA "fusedMultiplyAdd (generic)"      fusedMultiplyAdd_generic     casesForFloat128
  fromRationalIsBuggy $ FMASpec.checkFMA "fusedMultiplyAdd (via Rational)" fusedMultiplyAdd_viaRational casesForFloat128
  prop "nextUp . nextDown == id (unless -inf)" $ forAllFloats $ NextFloatSpec.prop_nextUp_nextDown proxy
  prop "nextDown . nextUp == id (unless inf)" $ forAllFloats $ NextFloatSpec.prop_nextDown_nextUp proxy
  prop "nextTowardZero == (nextUp or nextDown, unless 0.0)" $ forAllFloats $ NextFloatSpec.prop_nextTowardZero proxy
  fromRationalIsBuggy $ prop "augmentedAddition/equality" $ forAllFloats2 $ \(x :: Float128) y ->
    isFinite x && isFinite y ==>
    let (s,t) = augmentedAddition x y
    in isFinite s ==> isFinite t .&&. toRational s + toRational t === toRational x + toRational y
  prop "augmentedAddition" $ forAllFloats2 $ \(x :: Float128) y ->
    augmentedAddition x y `sameFloatPairP` augmentedAddition_viaRational x y
  prop "augmentedMultiplication" $ forAllFloats2 $ \(x :: Float128) y ->
    augmentedMultiplication x y `sameFloatPairP` augmentedMultiplication_viaRational x y
  fromRationalIsBuggy $ prop "remainder" $ forAllFloats2 $ RemainderSpec.prop_remainder proxy

  prop "fromIntegerR vs fromRationalR" $ RoundingSpec.eachStrategy (RoundingSpec.prop_fromIntegerR_vs_fromRationalR proxy)
  prop "fromIntegerR vs encodeFloatR" $ RoundingSpec.eachStrategy (RoundingSpec.prop_fromIntegerR_vs_encodeFloatR proxy)
  prop "fromRationalR vs encodeFloatR" $ RoundingSpec.eachStrategy (RoundingSpec.prop_fromRationalR_vs_encodeFloatR proxy)
  fromRationalIsBuggy $ prop "fromRationalR vs fromRational" $ RoundingSpec.prop_fromRationalR_vs_fromRational proxy
  prop "scaleFloatR vs fromRationalR" $ RoundingSpec.eachStrategy (RoundingSpec.prop_scaleFloatR_vs_fromRationalR proxy)
  prop "scaleFloatR vs encodeFloatR" $ RoundingSpec.eachStrategy (RoundingSpec.prop_scaleFloatR_vs_encodeFloatR proxy)
  prop "result of fromIntegerR" $ \x -> RoundingSpec.prop_order proxy (fromIntegerR x)
  prop "result of fromRationalR" $ \x -> RoundingSpec.prop_order proxy (fromRationalR x)
  prop "result of encodeFloatR" $ \m k -> RoundingSpec.prop_order proxy (encodeFloatR m k)
  prop "addToOdd" $ forAllFloats2 $ RoundingSpec.prop_addToOdd proxy

  roundIsBuggy $ prop "roundToIntegral" $ RoundToIntegralSpec.prop_roundToIntegral proxy
  roundIsBuggy $ RoundToIntegralSpec.checkCases proxy

  modifyMaxSuccess (* 1000) $ do
    prop "Float->Float128" $ forAllFloats $ ConversionSpec.prop_conversion (Proxy :: Proxy Float) proxy
    prop "Double->Float128" $ forAllFloats $ ConversionSpec.prop_conversion (Proxy :: Proxy Double) proxy
    prop "Float128->Float" $ forAllFloats $ ConversionSpec.prop_conversion proxy (Proxy :: Proxy Float)
    prop "Float128->Double" $ forAllFloats $ ConversionSpec.prop_conversion proxy (Proxy :: Proxy Double)

  prop "copySign" $ forAllFloats2 $ NaNSpec.prop_copySign proxy
  prop "isSignMinus" $ forAllFloats $ NaNSpec.prop_isSignMinus proxy
  prop "isSignaling" $ NaNSpec.prop_isSignaling proxy
  prop "setPayload/getPayload" $ NaNSpec.prop_setPayload_getPayload proxy
  prop "setPayload/0" $ NaNSpec.prop_setPayload proxy 0
  prop "setPayload/0x1p9" $ NaNSpec.prop_setPayload proxy 0x1p9
  prop "setPayload/Int" $ NaNSpec.prop_setPayload proxy . (fromIntegral :: Int -> Float128)
  prop "setPayloadSignaling/0" $ NaNSpec.prop_setPayloadSignaling proxy 0
  prop "setPayloadSignaling/0x1p9" $ NaNSpec.prop_setPayloadSignaling proxy 0x1p9
  prop "setPayloadSignaling/Int" $ NaNSpec.prop_setPayloadSignaling proxy . (fromIntegral :: Int -> Float128)
  prop "classify" $ forAllFloats $ NaNSpec.prop_classify proxy
  prop "classify (signaling NaN)" $ NaNSpec.prop_classify proxy (setPayloadSignaling 123)
  prop "signaling NaN propagation" $ NaNSpec.prop_signalingNaN proxy
  prop "totalOrder" $ forAllFloats2 $ NaNSpec.prop_totalOrder proxy