diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 1fef16a0b..c80ec8d7b 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} -- | -- Module : Data.ByteString.Builder.RealFloat -- Copyright : (c) Lawrence Wu 2021 @@ -68,16 +78,22 @@ module Data.ByteString.Builder.RealFloat , standardDefaultPrecision , scientific , generic + , shortest ) where import Data.ByteString.Builder.Internal (Builder) import qualified Data.ByteString.Builder.RealFloat.Internal as R +import Data.ByteString.Builder.RealFloat.Internal (FloatFormat(..), fScientific, fGeneric, fShortest, SpecialStrings(SpecialStrings)) +import Data.ByteString.Builder.RealFloat.Internal (positiveZero, negativeZero) import qualified Data.ByteString.Builder.RealFloat.F2S as RF import qualified Data.ByteString.Builder.RealFloat.D2S as RD import qualified Data.ByteString.Builder.Prim as BP import GHC.Float (roundTo) -import GHC.Word (Word64) +import GHC.Word (Word32, Word64) import GHC.Show (intToDigit) +import Data.Bits (Bits) +import Data.Proxy (Proxy(Proxy)) +import Data.Maybe (fromMaybe) -- | Returns a rendered Float. Matches `show` in displaying in standard or -- scientific notation @@ -87,7 +103,7 @@ import GHC.Show (intToDigit) -- @ {-# INLINABLE floatDec #-} floatDec :: Float -> Builder -floatDec = formatFloat generic +floatDec = formatFloating generic -- | Returns a rendered Double. Matches `show` in displaying in standard or -- scientific notation @@ -97,43 +113,67 @@ floatDec = formatFloat generic -- @ {-# INLINABLE doubleDec #-} doubleDec :: Double -> Builder -doubleDec = formatDouble generic - --- | Format type for use with `formatFloat` and `formatDouble`. --- --- @since 0.11.2.0 -data FloatFormat = MkFloatFormat FormatMode (Maybe Int) +doubleDec = formatFloating generic -- | Standard notation with `n` decimal places -- -- @since 0.11.2.0 standard :: Int -> FloatFormat -standard n = MkFloatFormat FStandard (Just n) +standard n = FStandard + { precision = Just n + , specials = standardSpecialStrings {positiveZero, negativeZero} + } + where + positiveZero = if n == 0 + then "0" + else "0." <> replicate n '0' + negativeZero = "-" <> positiveZero -- | Standard notation with the \'default precision\' (decimal places matching `show`) -- -- @since 0.11.2.0 standardDefaultPrecision :: FloatFormat -standardDefaultPrecision = MkFloatFormat FStandard Nothing +standardDefaultPrecision = FStandard + { precision = Nothing + , specials = standardSpecialStrings + } -- | Scientific notation with \'default precision\' (decimal places matching `show`) -- -- @since 0.11.2.0 scientific :: FloatFormat -scientific = MkFloatFormat FScientific Nothing +scientific = fScientific 'e' scientificSpecialStrings + +scientificSpecialStrings, standardSpecialStrings :: R.SpecialStrings +scientificSpecialStrings = R.SpecialStrings + { R.nan = "NaN" + , R.positiveInfinity = "Infinity" + , R.negativeInfinity = "-Infinity" + , R.positiveZero = "0.0e0" + , R.negativeZero = "-0.0e0" + } +standardSpecialStrings = scientificSpecialStrings + { R.positiveZero = "0.0" + , R.negativeZero = "-0.0" + } -- | Standard or scientific notation depending on the exponent. Matches `show` -- -- @since 0.11.2.0 generic :: FloatFormat -generic = MkFloatFormat FGeneric Nothing +generic = fGeneric 'e' Nothing (0,7) standardSpecialStrings --- | ByteString float-to-string format -data FormatMode - = FScientific -- ^ scientific notation - | FStandard -- ^ standard notation with `Maybe Int` digits after the decimal - | FGeneric -- ^ dispatches to scientific or standard notation based on the exponent - deriving Show +-- | Standard or scientific notation depending on which uses the least number of charabers. +-- +-- @since ???? +shortest :: FloatFormat +shortest = fShortest 'e' SpecialStrings + { nan = "NaN" + , positiveInfinity = "Inf" + , negativeInfinity = "-Inf" + , positiveZero = "0" + , negativeZero = "-0" + } -- TODO: support precision argument for FGeneric and FScientific -- | Returns a rendered Float. Returns the \'shortest\' representation in @@ -161,22 +201,7 @@ data FormatMode -- @since 0.11.2.0 {-# INLINABLE formatFloat #-} formatFloat :: FloatFormat -> Float -> Builder -formatFloat (MkFloatFormat fmt prec) = \f -> - let (RF.FloatingDecimal m e) = RF.f2Intermediate f - e' = R.int32ToInt e + R.decimalLength9 m in - case fmt of - FGeneric -> - case specialStr f of - Just b -> b - Nothing -> - if e' >= 0 && e' <= 7 - then sign f `mappend` showStandard (R.word32ToWord64 m) e' prec - else BP.primBounded (R.toCharsScientific (f < 0) m e) () - FScientific -> RF.f2s f - FStandard -> - case specialStr f of - Just b -> b - Nothing -> sign f `mappend` showStandard (R.word32ToWord64 m) e' prec +formatFloat = formatFloating -- TODO: support precision argument for FGeneric and FScientific -- | Returns a rendered Double. Returns the \'shortest\' representation in @@ -204,46 +229,76 @@ formatFloat (MkFloatFormat fmt prec) = \f -> -- @since 0.11.2.0 {-# INLINABLE formatDouble #-} formatDouble :: FloatFormat -> Double -> Builder -formatDouble (MkFloatFormat fmt prec) = \f -> - let (RD.FloatingDecimal m e) = RD.d2Intermediate f - e' = R.int32ToInt e + R.decimalLength17 m in - case fmt of - FGeneric -> - case specialStr f of - Just b -> b - Nothing -> - if e' >= 0 && e' <= 7 - then sign f `mappend` showStandard m e' prec - else BP.primBounded (R.toCharsScientific (f < 0) m e) () - FScientific -> RD.d2s f - FStandard -> - case specialStr f of - Just b -> b - Nothing -> sign f `mappend` showStandard m e' prec +formatDouble = formatFloating + +{-# INLINABLE formatFloating #-} +{-# SPECIALIZE formatFloating :: FloatFormat -> Float -> Builder #-} +{-# SPECIALIZE formatFloating :: FloatFormat -> Double -> Builder #-} +formatFloating :: forall a mw ew ei. + -- a + --( ToS a + ( ToD a + , RealFloat a + , R.ExponentBits a + , R.MantissaBits a + , R.CastToWord a + , R.MaxEncodedLength a + -- mantissa + , mw ~ R.MantissaWord a + , R.Mantissa mw + , ToWord64 mw + , R.DecimalLength mw + , BuildDigits mw + -- exponent + , ew ~ R.ExponentWord a + , Integral ew + , Bits ew + , ei ~ R.ExponentInt a + , R.ToInt ei + , Integral ei + , R.FromInt ei + ) => FloatFormat -> a -> Builder +formatFloating fmt f = case fmt of + FGeneric {stdExpoRange = (minExpo,maxExpo), ..} -> specialsOr specials + if e' >= minExpo && e' <= maxExpo + then std precision + else sci eE + FScientific {..} -> specialsOr specials $ sci eE + FStandard {..} -> specialsOr specials $ std precision + FShortest {..} -> specialsOr specials + if e'' >= 0 && (olength + 2 >= e'' || olength == 1 && e'' <= 2) + || e'' < 0 && (olength + e'' >= (-3) || olength == 1 && e'' >= (-2)) + then if e'' >= 0 + then printSign f <> buildDigits (truncate $ abs f :: mw) + else std Nothing + else sci eE + where + e'' = R.toInt e + olength = R.decimalLength m + where + sci eE = BP.primBounded (R.toCharsScientific @a Proxy eE sign m e) () + std precision = printSign f <> showStandard (toWord64 m) e' precision + e' = R.toInt e + R.decimalLength m + R.FloatingDecimal m e = toD @a mantissa expo + (sign, mantissa, expo) = R.breakdown f + specialsOr specials = flip fromMaybe $ R.toCharsNonNumbersAndZero specials f + +class ToWord64 a where toWord64 :: a -> Word64 +instance ToWord64 Word32 where toWord64 = R.word32ToWord64 +instance ToWord64 Word64 where toWord64 = id + +class ToD a where toD :: R.MantissaWord a -> R.ExponentWord a -> R.FloatingDecimal a +instance ToD Float where toD = RF.f2d +instance ToD Double where toD = RD.d2d -- | Char7 encode a 'Char'. {-# INLINE char7 #-} char7 :: Char -> Builder char7 = BP.primFixed BP.char7 --- | Char7 encode a 'String'. -{-# INLINE string7 #-} -string7 :: String -> Builder -string7 = BP.primMapListFixed BP.char7 - -- | Encodes a `-` if input is negative -sign :: RealFloat a => a -> Builder -sign f = if f < 0 then char7 '-' else mempty - --- | Special rendering for Nan, Infinity, and 0. See --- RealFloat.Internal.NonNumbersAndZero -specialStr :: RealFloat a => a -> Maybe Builder -specialStr f - | isNaN f = Just $ string7 "NaN" - | isInfinite f = Just $ sign f `mappend` string7 "Infinity" - | isNegativeZero f = Just $ string7 "-0.0" - | f == 0 = Just $ string7 "0.0" - | otherwise = Nothing +printSign :: RealFloat a => a -> Builder +printSign f = if f < 0 then char7 '-' else mempty -- | Returns a list of decimal digits in a Word64 digits :: Word64 -> [Int] @@ -259,7 +314,7 @@ showStandard m e prec = Nothing | e <= 0 -> char7 '0' `mappend` char7 '.' - `mappend` string7 (replicate (-e) '0') + `mappend` R.string7 (replicate (-e) '0') `mappend` mconcat (digitsToBuilder ds) | otherwise -> let f 0 s rs = mk0 (reverse s) `mappend` char7 '.' `mappend` mk0 rs @@ -285,3 +340,7 @@ showStandard m e prec = ds = digits m digitsToBuilder = fmap (char7 . intToDigit) +class BuildDigits a where buildDigits :: a -> Builder +instance BuildDigits Word32 where buildDigits = BP.primBounded BP.word32Dec +instance BuildDigits Word64 where buildDigits = BP.primBounded BP.word64Dec + diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs index fb5e8c008..8f6fe069d 100644 --- a/Data/ByteString/Builder/RealFloat/D2S.hs +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -1,6 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NamedFieldPuns #-} -- | -- Module : Data.ByteString.Builder.RealFloat.D2S -- Copyright : (c) Lawrence Wu 2021 @@ -10,15 +12,11 @@ -- Implementation of double-to-string conversion module Data.ByteString.Builder.RealFloat.D2S - ( FloatingDecimal(..) - , d2s - , d2Intermediate + ( d2d ) where import Control.Arrow (first) import Data.Bits ((.|.), (.&.), unsafeShiftL, unsafeShiftR) -import Data.ByteString.Builder.Internal (Builder) -import Data.ByteString.Builder.Prim (primBounded) import Data.ByteString.Builder.RealFloat.Internal import Data.Maybe (fromMaybe) import GHC.Int (Int32(..)) @@ -40,27 +38,17 @@ foreign import ccall "&hs_bytestring_double_pow5_inv_split" foreign import ccall "&hs_bytestring_double_pow5_split" double_pow5_split :: Ptr Word64 --- | Number of mantissa bits of a 64-bit float. The number of significant bits --- (floatDigits (undefined :: Double)) is 53 since we have a leading 1 for --- normal floats and 0 for subnormal floats double_mantissa_bits :: Int -double_mantissa_bits = 52 - --- | Number of exponent bits of a 64-bit float -double_exponent_bits :: Int -double_exponent_bits = 11 +double_mantissa_bits = mantissaBits @Double -- | Bias in encoded 64-bit float representation (2^10 - 1) double_bias :: Int double_bias = 1023 -data FloatingDecimal = FloatingDecimal - { dmantissa :: !Word64 - , dexponent :: !Int32 - } deriving (Show, Eq) +type FD = FloatingDecimal Double -- | Quick check for small integers -d2dSmallInt :: Word64 -> Word64 -> Maybe FloatingDecimal +d2dSmallInt :: Word64 -> Word64 -> Maybe FD d2dSmallInt m e = let m2 = (1 `unsafeShiftL` double_mantissa_bits) .|. m e2 = word64ToInt e - (double_bias + double_mantissa_bits) @@ -83,7 +71,7 @@ d2dSmallInt m e = -- | Removes trailing (decimal) zeros for small integers in the range [1, 2^53) -unifySmallTrailing :: FloatingDecimal -> FloatingDecimal +unifySmallTrailing :: FD -> FD unifySmallTrailing fd@(FloatingDecimal m e) = let !(q, r) = dquotRem10 m in if r == 0 @@ -170,8 +158,8 @@ d2dLT e2' u v w = -- | Returns the decimal representation of the given mantissa and exponent of a -- 64-bit Double using the ryu algorithm. -d2d :: Word64 -> Word64 -> FloatingDecimal -d2d m e = +d2dGeneral :: Word64 -> Word64 -> FD +d2dGeneral m e = let !mf = if e == 0 then m else (1 `unsafeShiftL` double_mantissa_bits) .|. m @@ -184,7 +172,7 @@ d2d m e = !v = 4 * mf !w = 4 * mf + 2 -- Step 3. convert to decimal power base - !(state, e10) = + !(state@BoundsState{vvIsTrailingZeros, vuIsTrailingZeros}, e10) = if e2 >= 0 then d2dGT e2 u v w else d2dLT e2 u v w @@ -192,40 +180,12 @@ d2d m e = -- valid representations. !(output, removed) = let rounded = closestCorrectlyRounded (acceptBounds v) - in first rounded $ if vvIsTrailingZeros state || vuIsTrailingZeros state + in first rounded $ if vvIsTrailingZeros || vuIsTrailingZeros then trimTrailing state else trimNoTrailing state !e' = e10 + removed in FloatingDecimal output e' --- | Split a Double into (sign, mantissa, exponent) -breakdown :: Double -> (Bool, Word64, Word64) -breakdown f = - let bits = castDoubleToWord64 f - sign = ((bits `unsafeShiftR` (double_mantissa_bits + double_exponent_bits)) .&. 1) /= 0 - mantissa = bits .&. mask double_mantissa_bits - expo = (bits `unsafeShiftR` double_mantissa_bits) .&. mask double_exponent_bits - in (sign, mantissa, expo) - --- | Dispatches to `d2d` or `d2dSmallInt` and applies the given formatters -{-# INLINE d2s' #-} -d2s' :: (Bool -> Word64 -> Int32 -> a) -> (NonNumbersAndZero -> a) -> Double -> a -d2s' formatter specialFormatter d = - let (sign, mantissa, expo) = breakdown d - in if (expo == mask double_exponent_bits) || (expo == 0 && mantissa == 0) - then specialFormatter NonNumbersAndZero - { negative=sign - , exponent_all_one=expo > 0 - , mantissa_non_zero=mantissa > 0 } - else let v = unifySmallTrailing <$> d2dSmallInt mantissa expo - FloatingDecimal m e = fromMaybe (d2d mantissa expo) v - in formatter sign m e - --- | Render a Double in scientific notation -d2s :: Double -> Builder -d2s d = primBounded (d2s' toCharsScientific toCharsNonNumbersAndZero d) () - --- | Returns the decimal representation of a Double. NaN and Infinity will --- return `FloatingDecimal 0 0` -d2Intermediate :: Double -> FloatingDecimal -d2Intermediate = d2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0) +-- TODO: Determine if this actually speeds things up. The benchmarks may not run many numbers in this range. +d2d :: Word64 -> Word64 -> FD +d2d mantissa expo = fromMaybe (d2dGeneral mantissa expo) $ unifySmallTrailing <$> d2dSmallInt mantissa expo diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs index 1e64e83ff..6d253f310 100644 --- a/Data/ByteString/Builder/RealFloat/F2S.hs +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns, MagicHash #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NamedFieldPuns #-} -- | -- Module : Data.ByteString.Builder.RealFloat.F2S -- Copyright : (c) Lawrence Wu 2021 @@ -9,15 +11,11 @@ -- Implementation of float-to-string conversion module Data.ByteString.Builder.RealFloat.F2S - ( FloatingDecimal(..) - , f2s - , f2Intermediate + ( f2d ) where import Control.Arrow (first) import Data.Bits ((.|.), (.&.), unsafeShiftL, unsafeShiftR) -import Data.ByteString.Builder.Internal (Builder) -import Data.ByteString.Builder.Prim (primBounded) import Data.ByteString.Builder.RealFloat.Internal import GHC.Int (Int32(..)) import GHC.Ptr (Ptr(..)) @@ -38,24 +36,11 @@ foreign import ccall "&hs_bytestring_float_pow5_inv_split" foreign import ccall "&hs_bytestring_float_pow5_split" float_pow5_split :: Ptr Word64 --- | Number of mantissa bits of a 32-bit float. The number of significant bits --- (floatDigits (undefined :: Float)) is 24 since we have a leading 1 for --- normal floats and 0 for subnormal floats -float_mantissa_bits :: Int -float_mantissa_bits = 23 - --- | Number of exponent bits of a 32-bit float -float_exponent_bits :: Int -float_exponent_bits = 8 - -- | Bias in encoded 32-bit float representation (2^7 - 1) float_bias :: Int float_bias = 127 -data FloatingDecimal = FloatingDecimal - { fmantissa :: !Word32 - , fexponent :: !Int32 - } deriving (Show, Eq) +type FD = FloatingDecimal Float -- | Multiply a 32-bit number with a 64-bit number while keeping the upper 64 -- bits. Then shift by specified amount minus 32 @@ -151,9 +136,10 @@ f2dLT e2' u v w = -- | Returns the decimal representation of the given mantissa and exponent of a -- 32-bit Float using the ryu algorithm. -f2d :: Word32 -> Word32 -> FloatingDecimal +f2d :: Word32 -> Word32 -> FD f2d m e = - let !mf = if e == 0 + let float_mantissa_bits = mantissaBits @Float + !mf = if e == 0 then m else (1 `unsafeShiftL` float_mantissa_bits) .|. m !ef = intToInt32 $ if e == 0 @@ -165,7 +151,7 @@ f2d m e = !v = 4 * mf !w = 4 * mf + 2 -- Step 3. convert to decimal power base - !(state, e10) = + !(state@BoundsState{vvIsTrailingZeros, vuIsTrailingZeros}, e10) = if e2 >= 0 then f2dGT e2 u v w else f2dLT e2 u v w @@ -173,39 +159,8 @@ f2d m e = -- valid representations. !(output, removed) = let rounded = closestCorrectlyRounded (acceptBounds v) - in first rounded $ if vvIsTrailingZeros state || vuIsTrailingZeros state + in first rounded $ if vvIsTrailingZeros || vuIsTrailingZeros then trimTrailing state else trimNoTrailing state !e' = e10 + removed in FloatingDecimal output e' - --- | Split a Float into (sign, mantissa, exponent) -breakdown :: Float -> (Bool, Word32, Word32) -breakdown f = - let bits = castFloatToWord32 f - sign = ((bits `unsafeShiftR` (float_mantissa_bits + float_exponent_bits)) .&. 1) /= 0 - mantissa = bits .&. mask float_mantissa_bits - expo = (bits `unsafeShiftR` float_mantissa_bits) .&. mask float_exponent_bits - in (sign, mantissa, expo) - --- | Dispatches to `f2d` and applies the given formatters -{-# INLINE f2s' #-} -f2s' :: (Bool -> Word32 -> Int32 -> a) -> (NonNumbersAndZero -> a) -> Float -> a -f2s' formatter specialFormatter f = - let (sign, mantissa, expo) = breakdown f - in if (expo == mask float_exponent_bits) || (expo == 0 && mantissa == 0) - then specialFormatter NonNumbersAndZero - { negative=sign - , exponent_all_one=expo > 0 - , mantissa_non_zero=mantissa > 0 } - else let FloatingDecimal m e = f2d mantissa expo - in formatter sign m e - --- | Render a Float in scientific notation -f2s :: Float -> Builder -f2s f = primBounded (f2s' toCharsScientific toCharsNonNumbersAndZero f) () - --- | Returns the decimal representation of a Float. NaN and Infinity will --- return `FloatingDecimal 0 0` -f2Intermediate :: Float -> FloatingDecimal -f2Intermediate = f2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0) diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index ccfdc5cc0..3e9fa4d9c 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -2,6 +2,16 @@ {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE DuplicateRecordFields #-} -- | -- Module : Data.ByteString.Builder.RealFloat.Internal -- Copyright : (c) Lawrence Wu 2021 @@ -21,10 +31,10 @@ module Data.ByteString.Builder.RealFloat.Internal ( mask - , NonNumbersAndZero(..) + , string7 , toCharsNonNumbersAndZero - , decimalLength9 - , decimalLength17 + , SpecialStrings(..) + , DecimalLength(..) , Mantissa , pow5bits , log10pow2 @@ -37,7 +47,9 @@ module Data.ByteString.Builder.RealFloat.Internal , trimTrailing , trimNoTrailing , closestCorrectlyRounded + , MaxEncodedLength(..) , toCharsScientific + , asciiRaw -- hand-rolled division and remainder for f2s and d2s , fquot10 , frem10 @@ -63,25 +75,40 @@ module Data.ByteString.Builder.RealFloat.Internal , word64ToInt , word32ToWord64 , word64ToWord32 + -- joining Float and Double logic + , FloatingDecimal(..) + , MantissaWord + , ExponentWord + , ExponentInt + , breakdown + , MantissaBits(..) + , ExponentBits(..) + , CastToWord(..) + , ToInt(..) + , FromInt(..) + , FloatFormat(..) + , fScientific + , fGeneric + , fShortest , module Data.ByteString.Builder.RealFloat.TableGenerator ) where -import Control.Monad (foldM) import Data.Bits (Bits(..), FiniteBits(..)) -import Data.ByteString.Internal (c2w) +import Data.ByteString.Builder.Internal (Builder) import Data.ByteString.Builder.Prim.Internal (BoundedPrim, boundedPrim) import Data.ByteString.Builder.RealFloat.TableGenerator import Data.ByteString.Utils.UnalignedWrite +import qualified Data.ByteString.Builder.Prim as BP import Data.Char (ord) +import Data.Proxy (Proxy) import Foreign.C.Types import GHC.Int (Int(..), Int32(..)) import GHC.IO (IO(..), unIO) import GHC.Prim -import GHC.Ptr (Ptr(..), plusPtr, castPtr) +import GHC.Ptr (Ptr(..), castPtr) import GHC.Types (isTrue#) -import GHC.Word (Word8, Word16(..), Word32(..), Word64(..)) -import qualified Foreign.Storable as S (poke) +import GHC.Word (Word16(..), Word32(..), Word64(..)) #include #include "MachDeps.h" @@ -177,6 +204,10 @@ decimalLength17 v | v >= 10 = 2 | otherwise = 1 +class DecimalLength a where decimalLength :: a -> Int +instance DecimalLength Word32 where decimalLength = decimalLength9 +instance DecimalLength Word64 where decimalLength = decimalLength17 + -- From 'In-and-Out Conversions' https://dl.acm.org/citation.cfm?id=362887, we -- have that a conversion from a base-b n-digit number to a base-v m-digit -- number such that the round-trip conversion is identity requires @@ -205,19 +236,14 @@ decimalLength17 v -- -- floats: 1 (sign) + 9 (mantissa) + 1 (.) + 1 (e) + 3 (exponent) = 15 -- doubles: 1 (sign) + 17 (mantissa) + 1 (.) + 1 (e) + 4 (exponent) = 24 --- -maxEncodedLength :: Int -maxEncodedLength = 32 - --- | Storable.poke a String into a Ptr Word8, converting through c2w -pokeAll :: String -> Ptr Word8 -> IO (Ptr Word8) -pokeAll s ptr = foldM pokeOne ptr s - where pokeOne p c = S.poke p (c2w c) >> return (p `plusPtr` 1) +class MaxEncodedLength a where maxEncodedLength :: Int +instance MaxEncodedLength Float where maxEncodedLength = 15 +instance MaxEncodedLength Double where maxEncodedLength = 24 --- | Unsafe creation of a bounded primitive of String at most length --- `maxEncodedLength` -boundString :: String -> BoundedPrim () -boundString s = boundedPrim maxEncodedLength $ const (pokeAll s) +-- | Char7 encode a 'String'. +{-# INLINE string7 #-} +string7 :: String -> Builder +string7 = BP.primMapListFixed BP.char7 -- | Special rendering for NaN, positive\/negative 0, and positive\/negative -- infinity. These are based on the IEEE representation of non-numbers. @@ -240,19 +266,47 @@ boundString s = boundedPrim maxEncodedLength $ const (pokeAll s) -- * sign = either 0 or 1. -- * biased exponent = all 0 bits. -- * fraction = all 0 bits. -data NonNumbersAndZero = NonNumbersAndZero - { negative :: Bool - , exponent_all_one :: Bool - , mantissa_non_zero :: Bool - } - --- | Renders NonNumbersAndZero into bounded primitive -toCharsNonNumbersAndZero :: NonNumbersAndZero -> BoundedPrim () -toCharsNonNumbersAndZero NonNumbersAndZero{..} - | mantissa_non_zero = boundString "NaN" - | exponent_all_one = boundString $ signStr ++ "Infinity" - | otherwise = boundString $ signStr ++ "0.0e0" - where signStr = if negative then "-" else "" +{-# INLINABLE toCharsNonNumbersAndZero #-} +{-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Float -> Maybe Builder #-} +{-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Double -> Maybe Builder #-} +toCharsNonNumbersAndZero :: forall a mw ew. + ( Bits ew + , Bits mw + , CastToWord a + , Eq mw + , ExponentBits a + , Integral ew + , Integral mw + , MantissaBits a + , Num ew + , Num mw + , Ord ew + , Ord mw + , ew ~ ExponentWord a + , mw ~ MantissaWord a + ) => SpecialStrings -> a -> Maybe Builder +toCharsNonNumbersAndZero SpecialStrings{..} f = string7 <$> + if w .&. expoMantissaBits == 0 + then Just if w == signBit then negativeZero else positiveZero + else if w .&. expoMask == expoMask + then Just if w .&. mantissaMask == 0 + then if w .&. signBit /= 0 then negativeInfinity else positiveInfinity + else nan + else Nothing + where + w = castToWord f + expoMask = mask (exponentBits @a) `shiftL` mantissaBits @a + mantissaMask = mask (mantissaBits @a) + expoMantissaBits = complement signBit + signBit = 1 `rotateR` 1 + +data SpecialStrings = SpecialStrings + { nan :: String + , positiveInfinity :: String + , negativeInfinity :: String + , positiveZero :: String + , negativeZero :: String + } deriving Show -- | Part of the calculation on whether to round up the decimal representation. -- This is currently a constant function to match behavior in Base `show` and @@ -267,7 +321,7 @@ toCharsNonNumbersAndZero NonNumbersAndZero{..} -- @ -- acceptBounds v = ((v \`quot\` 4) .&. 1) == 0 -- @ -acceptBounds :: Mantissa a => a -> Bool +acceptBounds :: a -> Bool acceptBounds _ = False ------------------------------------------------------------------------------- @@ -506,10 +560,12 @@ pow5_factor w count = _ -> pow5_factor q (count +# 1#) -- | Returns @True@ if value is divisible by @5^p@ +{-# INLINABLE multipleOfPowerOf5 #-} multipleOfPowerOf5 :: Mantissa a => a -> Int -> Bool multipleOfPowerOf5 value (I# p) = isTrue# (pow5_factor (raw value) 0# >=# p) -- | Returns @True@ if value is divisible by @2^p@ +{-# INLINABLE multipleOfPowerOf2 #-} multipleOfPowerOf2 :: Mantissa a => a -> Int -> Bool multipleOfPowerOf2 value p = (value .&. mask p) == 0 @@ -520,7 +576,6 @@ class (FiniteBits a, Integral a) => Mantissa a where unsafeRaw :: a -> Word# raw :: a -> WORD64 - decimalLength :: a -> Int boolToWord :: Bool -> a quotRem10 :: a -> (a, a) quot10 :: a -> a @@ -540,7 +595,6 @@ instance Mantissa Word32 where raw w = wordToWord64# (unsafeRaw w) #endif - decimalLength = decimalLength9 boolToWord = boolToWord32 {-# INLINE quotRem10 #-} @@ -566,7 +620,6 @@ instance Mantissa Word64 where #endif raw (W64# w) = w - decimalLength = decimalLength17 boolToWord = boolToWord64 {-# INLINE quotRem10 #-} @@ -606,50 +659,53 @@ data BoundsState a = BoundsState -- places where vuTrailing can possible be True, we must have acceptBounds be -- True (accept_smaller) -- - The final result doesn't change the lastRemovedDigit for rounding anyway -trimTrailing :: (Show a, Mantissa a) => BoundsState a -> (BoundsState a, Int32) +{-# INLINABLE trimTrailing #-} +trimTrailing :: Mantissa a => BoundsState a -> (BoundsState a, Int32) trimTrailing !initial = (res, r + r') where - !(d', r) = trimTrailing' initial - !(d'', r') = if vuIsTrailingZeros d' then trimTrailing'' d' else (d', 0) - res = if vvIsTrailingZeros d'' && lastRemovedDigit d'' == 5 && vv d'' `rem` 2 == 0 + !(d'@BoundsState{vuIsTrailingZeros = vuIsTrailingZeros'}, r) = trimTrailing' initial + !(d''@BoundsState{vvIsTrailingZeros = vvIsTrailingZeros'', lastRemovedDigit = lastRemovedDigit'', vv = vv''}, r') = + if vuIsTrailingZeros' then trimTrailing'' d' else (d', 0) + res = if vvIsTrailingZeros'' && lastRemovedDigit'' == 5 && vv'' `rem` 2 == 0 -- set `{ lastRemovedDigit = 4 }` to round-even then d'' else d'' - trimTrailing' !d + trimTrailing' !d@BoundsState{..} | vw' > vu' = fmap ((+) 1) . trimTrailing' $ d { vu = vu' , vv = vv' , vw = vw' , lastRemovedDigit = vvRem - , vuIsTrailingZeros = vuIsTrailingZeros d && vuRem == 0 - , vvIsTrailingZeros = vvIsTrailingZeros d && lastRemovedDigit d == 0 + , vuIsTrailingZeros = vuIsTrailingZeros && vuRem == 0 + , vvIsTrailingZeros = vvIsTrailingZeros && lastRemovedDigit == 0 } | otherwise = (d, 0) where - !(vv', vvRem) = quotRem10 $ vv d - !(vu', vuRem) = quotRem10 $ vu d - !(vw', _ ) = quotRem10 $ vw d + !(vv', vvRem) = quotRem10 vv + !(vu', vuRem) = quotRem10 vu + !(vw', _ ) = quotRem10 vw - trimTrailing'' !d + trimTrailing'' !d@BoundsState{..} | vuRem == 0 = fmap ((+) 1) . trimTrailing'' $ d { vu = vu' , vv = vv' , vw = vw' , lastRemovedDigit = vvRem - , vvIsTrailingZeros = vvIsTrailingZeros d && lastRemovedDigit d == 0 + , vvIsTrailingZeros = vvIsTrailingZeros && lastRemovedDigit == 0 } | otherwise = (d, 0) where - !(vu', vuRem) = quotRem10 $ vu d - !(vv', vvRem) = quotRem10 $ vv d - !(vw', _ ) = quotRem10 $ vw d + !(vu', vuRem) = quotRem10 vu + !(vv', vvRem) = quotRem10 vv + !(vw', _ ) = quotRem10 vw -- | Trim digits and update bookkeeping state when the table-computed -- step results has no trailing zeros (common case) +{-# INLINABLE trimNoTrailing #-} trimNoTrailing :: Mantissa a => BoundsState a -> (BoundsState a, Int32) trimNoTrailing !(BoundsState u v w ld _ _) = (BoundsState ru' rv' 0 ld' False False, c) @@ -683,14 +739,14 @@ trimNoTrailing !(BoundsState u v w ld _ _) = -- bounds {-# INLINE closestCorrectlyRounded #-} closestCorrectlyRounded :: Mantissa a => Bool -> BoundsState a -> a -closestCorrectlyRounded acceptBound s = vv s + boolToWord roundUp +closestCorrectlyRounded acceptBound BoundsState{..} = vv + boolToWord roundUp where - outsideBounds = not (vuIsTrailingZeros s) || not acceptBound - roundUp = (vv s == vu s && outsideBounds) || lastRemovedDigit s >= 5 + outsideBounds = not vuIsTrailingZeros || not acceptBound + roundUp = (vv == vu && outsideBounds) || lastRemovedDigit >= 5 -- Wrappe around int2Word# -asciiRaw :: Int -> Word# -asciiRaw (I# i) = int2Word# i +asciiRaw :: Int -> Word8# +asciiRaw (I# i) = wordToWord8# (int2Word# i) asciiZero :: Int asciiZero = ord '0' @@ -701,12 +757,9 @@ asciiDot = ord '.' asciiMinus :: Int asciiMinus = ord '-' -ascii_e :: Int -ascii_e = ord 'e' - -- | Convert a single-digit number to the ascii ordinal e.g '1' -> 0x31 toAscii :: Word# -> Word# -toAscii a = a `plusWord#` asciiRaw asciiZero +toAscii a = a `plusWord#` word8ToWord# (asciiRaw asciiZero) -- | Index into the 64-bit word lookup table provided {-# INLINE getWord64At #-} @@ -735,12 +788,12 @@ packWord16 l h = #endif -- | Unpacks a 16-bit word into 2 bytes [lsb, msb] -unpackWord16 :: Word# -> (# Word#, Word# #) +unpackWord16 :: Word# -> (# Word8#, Word8# #) unpackWord16 w = #if defined(WORDS_BIGENDIAN) - (# w `and#` 0xff##, w `uncheckedShiftRL#` 8# #) + (# wordToWord8# (w `and#` 0xff##), wordToWord8# (w `uncheckedShiftRL#` 8#) #) #else - (# w `uncheckedShiftRL#` 8#, w `and#` 0xff## #) + (# wordToWord8# (w `uncheckedShiftRL#` 8#), wordToWord8# (w `and#` 0xff##) #) #endif @@ -772,12 +825,12 @@ copyWord16 w a s = let (# s', _ #) -> s' -- | Write an 8-bit word into the given address -poke :: Addr# -> Word# -> State# d -> State# d +poke :: Addr# -> Word8# -> State# d -> State# d poke a w s = #if __GLASGOW_HASKELL__ >= 902 - writeWord8OffAddr# a 0# (wordToWord8# w) s -#else writeWord8OffAddr# a 0# w s +#else + writeWord8OffAddr# a 0# (word8ToWord# w) s #endif -- | Write the mantissa into the given address. This function attempts to @@ -809,29 +862,32 @@ writeMantissa ptr olength = go (ptr `plusAddr#` olength) s4 = poke ptr msb s3 in (# ptr `plusAddr#` (olength +# 1#), s4 #) | (I# olength) > 1 = - let s2 = copyWord16 (packWord16 (asciiRaw asciiDot) (toAscii (unsafeRaw mantissa))) ptr s1 + let s2 = copyWord16 (packWord16 (word8ToWord# (asciiRaw asciiDot)) (toAscii (unsafeRaw mantissa))) ptr s1 in (# ptr `plusAddr#` (olength +# 1#), s2 #) | otherwise = let s2 = poke (ptr `plusAddr#` 2#) (asciiRaw asciiZero) s1 s3 = poke (ptr `plusAddr#` 1#) (asciiRaw asciiDot) s2 - s4 = poke ptr (toAscii (unsafeRaw mantissa)) s3 + s4 = poke ptr (wordToWord8# (toAscii (unsafeRaw mantissa))) s3 in (# ptr `plusAddr#` 3#, s4 #) -- | Write the exponent into the given address. -writeExponent :: Addr# -> Int32 -> State# RealWorld -> (# Addr#, State# RealWorld #) +writeExponent :: forall ei. + ( Integral ei + , ToInt ei + ) => Addr# -> ei -> State# RealWorld -> (# Addr#, State# RealWorld #) writeExponent ptr !expo s1 | expo >= 100 = let !(e1, e0) = fquotRem10 (fromIntegral expo) -- TODO s2 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw e1)) ptr s1 - s3 = poke (ptr `plusAddr#` 2#) (toAscii (unsafeRaw e0)) s2 + s3 = poke (ptr `plusAddr#` 2#) (wordToWord8# (toAscii (unsafeRaw e0))) s2 in (# ptr `plusAddr#` 3#, s3 #) | expo >= 10 = let s2 = copyWord16 (digit_table `unsafeAt` e) ptr s1 in (# ptr `plusAddr#` 2#, s2 #) | otherwise = - let s2 = poke ptr (toAscii (int2Word# e)) s1 + let s2 = poke ptr (wordToWord8# (toAscii (int2Word# e))) s1 in (# ptr `plusAddr#` 1#, s2 #) - where !(I# e) = int32ToInt expo + where !(I# e) = toInt expo -- | Write the sign into the given address. writeSign :: Addr# -> Bool -> State# d -> (# Addr#, State# d #) @@ -843,16 +899,126 @@ writeSign ptr False s = (# ptr, s #) -- | Returns the decimal representation of a floating point number in -- scientific (exponential) notation {-# INLINABLE toCharsScientific #-} -{-# SPECIALIZE toCharsScientific :: Bool -> Word32 -> Int32 -> BoundedPrim () #-} -{-# SPECIALIZE toCharsScientific :: Bool -> Word64 -> Int32 -> BoundedPrim () #-} -toCharsScientific :: (Mantissa a) => Bool -> a -> Int32 -> BoundedPrim () -toCharsScientific !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(Ptr p0)-> do +{-# SPECIALIZE toCharsScientific :: Proxy Float -> Word8# -> Bool -> Word32 -> Int32 -> BoundedPrim () #-} +{-# SPECIALIZE toCharsScientific :: Proxy Double -> Word8# -> Bool -> Word64 -> Int32 -> BoundedPrim () #-} +toCharsScientific :: forall a mw ei. + ( MaxEncodedLength a + , Mantissa mw + , DecimalLength mw + , Integral ei + , ToInt ei + , FromInt ei + ) => Proxy a -> Word8# -> Bool -> mw -> ei -> BoundedPrim () +toCharsScientific _ eE !sign !mantissa !expo = boundedPrim (maxEncodedLength @a) $ \_ !(Ptr p0)-> do let !olength@(I# ol) = decimalLength mantissa - !expo' = expo + intToInt32 olength - 1 + !expo' = expo + fromInt olength - 1 IO $ \s1 -> let !(# p1, s2 #) = writeSign p0 sign s1 !(# p2, s3 #) = writeMantissa p1 ol mantissa s2 - s4 = poke p2 (asciiRaw ascii_e) s3 + s4 = poke p2 eE s3 !(# p3, s5 #) = writeSign (p2 `plusAddr#` 1#) (expo' < 0) s4 !(# p4, s6 #) = writeExponent p3 (abs expo') s5 in (# s6, (Ptr p4) #) + +data FloatingDecimal a = FloatingDecimal + { fmantissa :: !(MantissaWord a) + , fexponent :: !(ExponentInt a) + } +deriving instance (Show (MantissaWord a), Show (ExponentInt a)) => Show (FloatingDecimal a) +deriving instance (Eq (MantissaWord a), Eq (ExponentInt a)) => Eq (FloatingDecimal a) + +type family MantissaWord a +type instance MantissaWord Float = Word32 +type instance MantissaWord Double = Word64 + +class ToInt a where toInt :: a -> Int +instance ToInt Int32 where toInt = int32ToInt + +class FromInt a where fromInt :: Int -> a +instance FromInt Int32 where fromInt = intToInt32 + +-- | Split a Double into (sign, mantissa, exponent) +{-# INLINABLE breakdown #-} +{-# SPECIALIZE breakdown :: Float -> (Bool, MantissaWord Float, ExponentWord Float) #-} +{-# SPECIALIZE breakdown :: Double -> (Bool, MantissaWord Double, ExponentWord Double) #-} +breakdown :: forall a mw ew. + ( ExponentBits a + , MantissaBits a + , CastToWord a + , mw ~ MantissaWord a + , Bits mw + , Integral mw + , Num ew + ) => a -> (Bool, mw, ew) +breakdown f = (sign, mantissa, expo) + where + bits = castToWord f + sign = (bits .&. 1 `rotateR` 1) /= 0 + mantissa = bits .&. mask (mantissaBits @a) + expo = fromIntegral $ (bits `unsafeShiftR` mantissaBits @a) .&. mask (exponentBits @a) + +type family ExponentWord a +type instance ExponentWord Float = Word32 +type instance ExponentWord Double = Word64 + +type family ExponentInt a +type instance ExponentInt Float = Int32 +type instance ExponentInt Double = Int32 + +class CastToWord a where castToWord :: a -> MantissaWord a +instance CastToWord Float where castToWord = castFloatToWord32 +instance CastToWord Double where castToWord = castDoubleToWord64 + +-- | Number of mantissa bits. The number of significant bits +-- is one more than defined since we have a leading 1 for +-- normal and 0 for subnormal. +class MantissaBits a where mantissaBits :: Int +instance MantissaBits Float where mantissaBits = 23 +instance MantissaBits Double where mantissaBits = 52 + +-- | Number of exponent bits. +class ExponentBits a where exponentBits :: Int +instance ExponentBits Float where exponentBits = 8 +instance ExponentBits Double where exponentBits = 11 + +-- | Format type for use with `formatFloat` and `formatDouble`. +-- +-- @since 0.11.2.0 +data FloatFormat + -- | scientific notation + = FScientific + { eE :: Word8# + , specials :: SpecialStrings + } + -- | standard notation with `Maybe Int` digits after the decimal + | FStandard + { precision :: Maybe Int + , specials :: SpecialStrings + } + -- | dispatches to scientific or standard notation based on the exponent + | FGeneric + { eE :: Word8# + , precision :: Maybe Int + , stdExpoRange :: (Int, Int) + , specials :: SpecialStrings + } + | FShortest + { eE :: Word8# + , specials :: SpecialStrings + } + deriving Show +fScientific :: Char -> SpecialStrings -> FloatFormat +fScientific eE specials = FScientific + { eE = asciiRaw $ ord eE + , specials + } +fGeneric :: Char -> Maybe Int -> (Int, Int) -> SpecialStrings -> FloatFormat +fGeneric eE precision stdExpoRange specials = FGeneric + { eE = asciiRaw $ ord eE + , .. + } +fShortest :: Char -> SpecialStrings -> FloatFormat +fShortest eE specials = FShortest + { eE = asciiRaw $ ord eE + , .. + } diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs index 3daa09463..c66dd9b54 100644 --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -11,15 +11,23 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE ViewPatterns #-} module Main (main) where +import Control.Exception (assert) import Data.Foldable (foldMap) import Data.Monoid import Data.Semigroup import Data.String import Test.Tasty.Bench import Prelude hiding (words) +import Numeric.IEEE +import GHC.Float (powerFloat, + castWord32ToFloat, + castWord64ToDouble, + castFloatToWord32, + castDoubleToWord64) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -65,7 +73,7 @@ countToZero n = Just (n, n - 1) -- | Few-enough repetitions to avoid making GC too expensive. nRepl :: Int -nRepl = 10000 +nRepl = 100000 {-# NOINLINE intData #-} intData :: [Int] @@ -79,14 +87,57 @@ smallIntegerData = map fromIntegral intData largeIntegerData :: [Integer] largeIntegerData = map (* (10 ^ (100 :: Integer))) smallIntegerData +{-# NOINLINE floatPosData #-} +floatPosData :: [Float] +floatPosData = map evenlyDistribute intData + where + evenlyDistribute :: Int -> Float + evenlyDistribute x = castWord32ToFloat $ increment * fromIntegral x + increment = castFloatToWord32 maxFinite `div` fromIntegral nRepl + +{-# NOINLINE floatNegData #-} +floatNegData :: [Float] +floatNegData = map negate floatPosData -{-# NOINLINE floatData #-} -floatData :: [Float] -floatData = map (\x -> (3.14159 * fromIntegral x) ^ (3 :: Int)) intData +{-# NOINLINE floatSpecials #-} +floatSpecials :: [Float] +floatSpecials = foldMap (const specials) [1..nRepl `div` length specials] + where + specials = [nan, infinity, negate infinity, 0 -0] -{-# NOINLINE doubleData #-} -doubleData :: [Double] -doubleData = map (\x -> (3.14159 * fromIntegral x) ^ (3 :: Int)) intData +{-# NOINLINE doublePosData #-} +doublePosData :: [Double] +doublePosData = map evenlyDistribute intData + where + evenlyDistribute :: Int -> Double + evenlyDistribute x = castWord64ToDouble $ increment * fromIntegral x + increment = (maximum - minimum) `div` fromIntegral nRepl + minimum = castDoubleToWord64 $ succIEEE $ 2 ^ 53 + maximum = castDoubleToWord64 maxFinite + +{-# NOINLINE doubleNegData #-} +doubleNegData :: [Double] +doubleNegData = map negate doublePosData + +-- f is an integer in the range [1, 2^53). +{-# NOINLINE doublePosSmallData #-} +doublePosSmallData :: [Double] +doublePosSmallData = map evenlyDistribute intData + where + evenlyDistribute = assert (increment > 0) $ \x -> castWord64ToDouble $ increment * fromIntegral x + minimum + increment = (maximum - minimum) `div` fromIntegral nRepl + minimum = castDoubleToWord64 1.0 + maximum = castDoubleToWord64 $ 2 ^ 53 + +{-# NOINLINE doubleNegSmallData #-} +doubleNegSmallData :: [Double] +doubleNegSmallData = map negate doublePosSmallData + +{-# NOINLINE doubleSpecials #-} +doubleSpecials :: [Double] +doubleSpecials = foldMap (const specials) [1..nRepl `div` length specials] + where + specials = [nan, infinity, negate infinity, 0 -0] {-# NOINLINE byteStringData #-} byteStringData :: S.ByteString @@ -285,12 +336,96 @@ main = do , bgroup "Non-bounded encodings" [ benchB "byteStringHex" byteStringData $ byteStringHex , benchB "lazyByteStringHex" lazyByteStringData $ lazyByteStringHex - , benchB "foldMap floatDec" floatData $ foldMap floatDec - , benchB "foldMap doubleDec" doubleData $ foldMap doubleDec -- Note that the small data corresponds to the intData pre-converted -- to Integer. , benchB "foldMap integerDec (small)" smallIntegerData $ foldMap integerDec , benchB "foldMap integerDec (large)" largeIntegerData $ foldMap integerDec + , bgroup "RealFloat" + [ bgroup "FGeneric" + [ bgroup "Positive" + [ benchB "Float" floatPosData $ foldMap (formatFloat generic) + , benchB "Double" doublePosData $ foldMap (formatDouble generic) + , benchB "DoubleSmall" doublePosSmallData $ foldMap (formatDouble generic) + ] + , bgroup "Negative" + [ benchB "Float" floatNegData $ foldMap (formatFloat generic) + , benchB "Double" doubleNegData $ foldMap (formatDouble generic) + , benchB "DoubleSmall" doubleNegData $ foldMap (formatDouble generic) + ] + , bgroup "Special" + [ benchB "Float Average" floatSpecials $ foldMap (formatFloat generic) + , benchB "Double Average" doubleSpecials $ foldMap (formatDouble generic) + ] + ] + , bgroup "FScientific" + [ bgroup "Positive" + [ benchB "Float" floatPosData $ foldMap (formatFloat scientific) + , benchB "Double" doublePosData $ foldMap (formatDouble scientific) + , benchB "DoubleSmall" doublePosSmallData $ foldMap (formatDouble scientific) + ] + , bgroup "Negative" + [ benchB "Float" floatNegData $ foldMap (formatFloat scientific) + , benchB "Double" doubleNegData $ foldMap (formatDouble scientific) + , benchB "DoubleSmall" doubleNegSmallData $ foldMap (formatDouble scientific) + ] + , bgroup "Special" + [ benchB "Float Average" floatSpecials $ foldMap (formatFloat scientific) + , benchB "Double Average" doubleSpecials $ foldMap (formatDouble scientific) + ] + ] + , bgroup "FStandard" + [ bgroup "Positive" + [ bgroup "without" + [ benchB "Float" floatPosData $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double" doublePosData $ foldMap (formatDouble standardDefaultPrecision) + , benchB "DoubleSmall" doublePosSmallData $ foldMap (formatDouble standardDefaultPrecision) + ] + , bgroup "precision" + [ benchB "Float-Preciaion-1" floatPosData $ foldMap (formatFloat (standard 1)) + , benchB "Double-Preciaion-1" doublePosData $ foldMap (formatDouble (standard 1)) + , benchB "DoubleSmall-Preciaion-1" doublePosSmallData $ foldMap (formatDouble (standard 1)) + , benchB "Float-Preciaion-6" floatPosData $ foldMap (formatFloat (standard 6)) + , benchB "Double-Preciaion-6" doublePosData $ foldMap (formatDouble (standard 6)) + , benchB "DoubleSmall-Preciaion-6" doublePosSmallData $ foldMap (formatDouble (standard 6)) + ] + ] + , bgroup "Negative" + [ bgroup "without" + [ benchB "Float" floatNegData $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double" doubleNegData $ foldMap (formatDouble standardDefaultPrecision) + , benchB "DoubleSmall" doubleNegSmallData $ foldMap (formatDouble standardDefaultPrecision) + ] + , bgroup "precision" + [ benchB "Float-Preciaion-1" floatNegData $ foldMap (formatFloat (standard 1)) + , benchB "Double-Preciaion-1" doubleNegData $ foldMap (formatDouble (standard 1)) + , benchB "DoubleSmall-Preciaion-1" doubleNegSmallData $ foldMap (formatDouble (standard 1)) + , benchB "Float-Preciaion-6" floatNegData $ foldMap (formatFloat (standard 6)) + , benchB "Double-Preciaion-6" doubleNegData $ foldMap (formatDouble (standard 6)) + , benchB "DoubleSmall-Preciaion-6" doubleNegSmallData $ foldMap (formatDouble (standard 6)) + ] + ] + , bgroup "Special" + [ benchB "Float Average" floatSpecials $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double Average" doubleSpecials $ foldMap (formatDouble standardDefaultPrecision) + ] + ] + , bgroup "FShortest" + [ bgroup "Positive" + [ benchB "Float" floatPosData $ foldMap (formatFloat shortest) + , benchB "Double" doublePosData $ foldMap (formatDouble shortest) + , benchB "DoubleSmall" doublePosSmallData $ foldMap (formatDouble shortest) + ] + , bgroup "Negative" + [ benchB "Float" floatNegData $ foldMap (formatFloat shortest) + , benchB "Double" doubleNegData $ foldMap (formatDouble shortest) + , benchB "DoubleSmall" doubleNegSmallData $ foldMap (formatDouble shortest) + ] + , bgroup "Special" + [ benchB "Float Average" floatSpecials $ foldMap (formatFloat shortest) + , benchB "Double Average" doubleSpecials $ foldMap (formatDouble shortest) + ] + ] + ] ] ] diff --git a/bytestring.cabal b/bytestring.cabal index eea29d17b..949a313ed 100644 --- a/bytestring.cabal +++ b/bytestring.cabal @@ -181,7 +181,9 @@ test-suite bytestring-tests deepseq, ghc-prim, QuickCheck, + quickcheck-assertions, tasty, + tasty-hunit, tasty-quickcheck >= 0.8.1, template-haskell, transformers >= 0.3, @@ -208,4 +210,5 @@ benchmark bytestring-bench bytestring, deepseq, tasty-bench, - random + random, + ieee754 diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs index a7ab9131a..0c2618fe3 100644 --- a/tests/builder/Data/ByteString/Builder/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -1,6 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | @@ -34,6 +36,7 @@ import Data.Word import qualified Data.ByteString as S import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Short as Sh import Data.ByteString.Builder @@ -51,12 +54,14 @@ import Numeric (showFFloat) import System.Posix.Internals (c_unlink) import Test.Tasty (TestTree, TestName, testGroup) +import Test.Tasty.HUnit (testCase, (@?=), Assertion) import Test.Tasty.QuickCheck ( Arbitrary(..), oneof, choose, listOf, elements, forAll , counterexample, ioProperty, Property, testProperty , (===), (.&&.), conjoin , UnicodeString(..), NonNegative(..) ) +import Test.QuickCheck.Assertions ((?<=)) import QuickCheckUtils @@ -73,7 +78,7 @@ tests = testsEncodingToBuilder ++ testsBinary ++ testsASCII ++ - testsFloating ++ + testsFloating : testsChar8 ++ testsUtf8 @@ -637,333 +642,385 @@ testsASCII = where enlarge (n, e) = n ^ (abs (e `mod` (50 :: Integer))) -testsFloating :: [TestTree] -testsFloating = - [ testMatches "f2sBasic" floatDec show - [ ( 0.0 , "0.0" ) - , ( (-0.0) , "-0.0" ) - , ( 1.0 , "1.0" ) - , ( (-1.0) , "-1.0" ) - , ( (0/0) , "NaN" ) - , ( (1/0) , "Infinity" ) - , ( (-1/0) , "-Infinity" ) - ] - , testMatches "f2sSubnormal" floatDec show - [ ( 1.1754944e-38 , "1.1754944e-38" ) - ] - , testMatches "f2sMinAndMax" floatDec show - [ ( coerceWord32ToFloat 0x7f7fffff , "3.4028235e38" ) - , ( coerceWord32ToFloat 0x00000001 , "1.0e-45" ) - ] - , testMatches "f2sBoundaryRound" floatDec show - [ ( 3.355445e7 , "3.3554448e7" ) - , ( 8.999999e9 , "8.999999e9" ) - , ( 3.4366717e10 , "3.4366718e10" ) - ] - , testMatches "f2sExactValueRound" floatDec show - [ ( 3.0540412e5 , "305404.13" ) - , ( 8.0990312e3 , "8099.0313" ) - ] - , testMatches "f2sTrailingZeros" floatDec show - -- Pattern for the first test: 00111001100000000000000000000000 - [ ( 2.4414062e-4 , "2.4414063e-4" ) - , ( 2.4414062e-3 , "2.4414063e-3" ) - , ( 4.3945312e-3 , "4.3945313e-3" ) - , ( 6.3476562e-3 , "6.3476563e-3" ) - ] - , testMatches "f2sRegression" floatDec show - [ ( 4.7223665e21 , "4.7223665e21" ) - , ( 8388608.0 , "8388608.0" ) - , ( 1.6777216e7 , "1.6777216e7" ) - , ( 3.3554436e7 , "3.3554436e7" ) - , ( 6.7131496e7 , "6.7131496e7" ) - , ( 1.9310392e-38 , "1.9310392e-38" ) - , ( (-2.47e-43) , "-2.47e-43" ) - , ( 1.993244e-38 , "1.993244e-38" ) - , ( 4103.9003 , "4103.9004" ) - , ( 5.3399997e9 , "5.3399997e9" ) - , ( 6.0898e-39 , "6.0898e-39" ) - , ( 0.0010310042 , "1.0310042e-3" ) - , ( 2.8823261e17 , "2.882326e17" ) - , ( 7.0385309e-26 , "7.038531e-26" ) - , ( 9.2234038e17 , "9.223404e17" ) - , ( 6.7108872e7 , "6.710887e7" ) - , ( 1.0e-44 , "1.0e-44" ) - , ( 2.816025e14 , "2.816025e14" ) - , ( 9.223372e18 , "9.223372e18" ) - , ( 1.5846085e29 , "1.5846086e29" ) - , ( 1.1811161e19 , "1.1811161e19" ) - , ( 5.368709e18 , "5.368709e18" ) - , ( 4.6143165e18 , "4.6143166e18" ) - , ( 0.007812537 , "7.812537e-3" ) - , ( 1.4e-45 , "1.0e-45" ) - , ( 1.18697724e20 , "1.18697725e20" ) - , ( 1.00014165e-36 , "1.00014165e-36" ) - , ( 200.0 , "200.0" ) - , ( 3.3554432e7 , "3.3554432e7" ) - , ( 2.0019531 , "2.0019531" ) - , ( 2.001953 , "2.001953" ) - ] - , testExpected "f2sScientific" (formatFloat scientific) - [ ( 0.0 , "0.0e0" ) - , ( 8388608.0 , "8.388608e6" ) - , ( 1.6777216e7 , "1.6777216e7" ) - , ( 3.3554436e7 , "3.3554436e7" ) - , ( 6.7131496e7 , "6.7131496e7" ) - , ( 1.9310392e-38 , "1.9310392e-38" ) - , ( (-2.47e-43) , "-2.47e-43" ) - , ( 1.993244e-38 , "1.993244e-38" ) - , ( 4103.9003 , "4.1039004e3" ) - , ( 0.0010310042 , "1.0310042e-3" ) - , ( 0.007812537 , "7.812537e-3" ) - , ( 200.0 , "2.0e2" ) - , ( 2.0019531 , "2.0019531e0" ) - , ( 2.001953 , "2.001953e0" ) - ] - , testMatches "f2sLooksLikePowerOf5" floatDec show - [ ( coerceWord32ToFloat 0x5D1502F9 , "6.7108864e17" ) - , ( coerceWord32ToFloat 0x5D9502F9 , "1.3421773e18" ) - , ( coerceWord32ToFloat 0x5e1502F9 , "2.6843546e18" ) - ] - , testMatches "f2sOutputLength" floatDec show - [ ( 1.0 , "1.0" ) - , ( 1.2 , "1.2" ) - , ( 1.23 , "1.23" ) - , ( 1.234 , "1.234" ) - , ( 1.2345 , "1.2345" ) - , ( 1.23456 , "1.23456" ) - , ( 1.234567 , "1.234567" ) - , ( 1.2345678 , "1.2345678" ) - , ( 1.23456735e-36 , "1.23456735e-36" ) - ] - , testMatches "d2sBasic" doubleDec show - [ ( 0.0 , "0.0" ) - , ( (-0.0) , "-0.0" ) - , ( 1.0 , "1.0" ) - , ( (-1.0) , "-1.0" ) - , ( (0/0) , "NaN" ) - , ( (1/0) , "Infinity" ) - , ( (-1/0) , "-Infinity" ) - ] - , testMatches "d2sSubnormal" doubleDec show - [ ( 2.2250738585072014e-308 , "2.2250738585072014e-308" ) - ] - , testMatches "d2sMinAndMax" doubleDec show - [ ( (coerceWord64ToDouble 0x7fefffffffffffff) , "1.7976931348623157e308" ) - , ( (coerceWord64ToDouble 0x0000000000000001) , "5.0e-324" ) - ] - , testMatches "d2sTrailingZeros" doubleDec show - [ ( 2.98023223876953125e-8 , "2.9802322387695313e-8" ) - ] - , testMatches "d2sRegression" doubleDec show - [ ( (-2.109808898695963e16) , "-2.1098088986959632e16" ) - , ( 4.940656e-318 , "4.940656e-318" ) - , ( 1.18575755e-316 , "1.18575755e-316" ) - , ( 2.989102097996e-312 , "2.989102097996e-312" ) - , ( 9.0608011534336e15 , "9.0608011534336e15" ) - , ( 4.708356024711512e18 , "4.708356024711512e18" ) - , ( 9.409340012568248e18 , "9.409340012568248e18" ) - , ( 1.2345678 , "1.2345678" ) - , ( 1.9430376160308388e16 , "1.9430376160308388e16" ) - , ( (-6.9741824662760956e19), "-6.9741824662760956e19" ) - , ( 4.3816050601147837e18 , "4.3816050601147837e18" ) - ] - , testExpected "d2sScientific" (formatDouble scientific) - [ ( 0.0 , "0.0e0" ) - , ( 1.2345678 , "1.2345678e0" ) - , ( 4.294967294 , "4.294967294e0" ) - , ( 4.294967295 , "4.294967295e0" ) - ] - , testProperty "d2sStandard" $ conjoin - [ singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.345 , "12.34" ) - , singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0050 , "0.00" ) - , singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0051 , "0.01" ) - , singleMatches (formatDouble (standard 5)) (flip (showFFloat (Just 5)) []) ( 12.345 , "12.34500" ) - ] - , testMatches "d2sLooksLikePowerOf5" doubleDec show - [ ( (coerceWord64ToDouble 0x4830F0CF064DD592) , "5.764607523034235e39" ) - , ( (coerceWord64ToDouble 0x4840F0CF064DD592) , "1.152921504606847e40" ) - , ( (coerceWord64ToDouble 0x4850F0CF064DD592) , "2.305843009213694e40" ) - , ( (coerceWord64ToDouble 0x4400000000000004) , "3.689348814741914e19" ) - - -- here v- is a power of 5 but since we don't accept bounds there is no - -- interesting trailing behavior - , ( (coerceWord64ToDouble 0x440000000000301d) , "3.6893488147520004e19" ) - ] - , testMatches "d2sOutputLength" doubleDec show - [ ( 1 , "1.0" ) - , ( 1.2 , "1.2" ) - , ( 1.23 , "1.23" ) - , ( 1.234 , "1.234" ) - , ( 1.2345 , "1.2345" ) - , ( 1.23456 , "1.23456" ) - , ( 1.234567 , "1.234567" ) - , ( 1.2345678 , "1.2345678" ) - , ( 1.23456789 , "1.23456789" ) - , ( 1.234567895 , "1.234567895" ) - , ( 1.2345678901 , "1.2345678901" ) - , ( 1.23456789012 , "1.23456789012" ) - , ( 1.234567890123 , "1.234567890123" ) - , ( 1.2345678901234 , "1.2345678901234" ) - , ( 1.23456789012345 , "1.23456789012345" ) - , ( 1.234567890123456 , "1.234567890123456" ) - , ( 1.2345678901234567 , "1.2345678901234567" ) - - -- Test 32-bit chunking - , ( 4.294967294 , "4.294967294" ) - , ( 4.294967295 , "4.294967295" ) - , ( 4.294967296 , "4.294967296" ) - , ( 4.294967297 , "4.294967297" ) - , ( 4.294967298 , "4.294967298" ) - ] - , testMatches "d2sMinMaxShift" doubleDec show - [ ( (ieeeParts2Double False 4 0) , "1.7800590868057611e-307" ) - -- 32-bit opt-size=0: 49 <= dist <= 49 - -- 32-bit opt-size=1: 28 <= dist <= 49 - -- 64-bit opt-size=0: 50 <= dist <= 50 - -- 64-bit opt-size=1: 28 <= dist <= 50 - , ( (ieeeParts2Double False 6 maxMantissa) , "2.8480945388892175e-306" ) - -- 32-bit opt-size=0: 52 <= dist <= 53 - -- 32-bit opt-size=1: 2 <= dist <= 53 - -- 64-bit opt-size=0: 53 <= dist <= 53 - -- 64-bit opt-size=1: 2 <= dist <= 53 - , ( (ieeeParts2Double False 41 0) , "2.446494580089078e-296" ) - -- 32-bit opt-size=0: 52 <= dist <= 52 - -- 32-bit opt-size=1: 2 <= dist <= 52 - -- 64-bit opt-size=0: 53 <= dist <= 53 - -- 64-bit opt-size=1: 2 <= dist <= 53 - , ( (ieeeParts2Double False 40 maxMantissa) , "4.8929891601781557e-296" ) - -- 32-bit opt-size=0: 57 <= dist <= 58 - -- 32-bit opt-size=1: 57 <= dist <= 58 - -- 64-bit opt-size=0: 58 <= dist <= 58 - -- 64-bit opt-size=1: 58 <= dist <= 58 - , ( (ieeeParts2Double False 1077 0) , "1.8014398509481984e16" ) - -- 32-bit opt-size=0: 57 <= dist <= 57 - -- 32-bit opt-size=1: 57 <= dist <= 57 - -- 64-bit opt-size=0: 58 <= dist <= 58 - -- 64-bit opt-size=1: 58 <= dist <= 58 - , ( (ieeeParts2Double False 1076 maxMantissa) , "3.6028797018963964e16" ) - -- 32-bit opt-size=0: 51 <= dist <= 52 - -- 32-bit opt-size=1: 51 <= dist <= 59 - -- 64-bit opt-size=0: 52 <= dist <= 52 - -- 64-bit opt-size=1: 52 <= dist <= 59 - , ( (ieeeParts2Double False 307 0) , "2.900835519859558e-216" ) - -- 32-bit opt-size=0: 51 <= dist <= 51 - -- 32-bit opt-size=1: 51 <= dist <= 59 - -- 64-bit opt-size=0: 52 <= dist <= 52 - -- 64-bit opt-size=1: 52 <= dist <= 59 - , ( (ieeeParts2Double False 306 maxMantissa) , "5.801671039719115e-216" ) - -- 32-bit opt-size=0: 49 <= dist <= 49 - -- 32-bit opt-size=1: 44 <= dist <= 49 - -- 64-bit opt-size=0: 50 <= dist <= 50 - -- 64-bit opt-size=1: 44 <= dist <= 50 - , ( (ieeeParts2Double False 934 0x000FA7161A4D6e0C) , "3.196104012172126e-27" ) +testsFloating :: TestTree +testsFloating = testGroup "RealFloat" + [ testGroup "Float" + [ testMatches "f2sNonNumbersAndZero" floatDec show + [ ( 0.0 , "0.0" ) + , ( (-0.0) , "-0.0" ) + , ( (0/0) , "NaN" ) + , ( (1/0) , "Infinity" ) + , ( (-1/0) , "-Infinity" ) + ] + , testMatches "f2sBasic" floatDec show + [ ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + ] + , testMatches "f2sSubnormal" floatDec show + [ ( 1.1754944e-38 , "1.1754944e-38" ) + ] + , testMatches "f2sMinAndMax" floatDec show + [ ( coerceWord32ToFloat 0x7f7fffff , "3.4028235e38" ) + , ( coerceWord32ToFloat 0x00000001 , "1.0e-45" ) + ] + , testMatches "f2sBoundaryRound" floatDec show + [ ( 3.355445e7 , "3.3554448e7" ) + , ( 8.999999e9 , "8.999999e9" ) + , ( 3.4366717e10 , "3.4366718e10" ) + ] + , testMatches "f2sExactValueRound" floatDec show + [ ( 3.0540412e5 , "305404.13" ) + , ( 8.0990312e3 , "8099.0313" ) + ] + , testMatches "f2sTrailingZeros" floatDec show + -- Pattern for the first test: 00111001100000000000000000000000 + [ ( 2.4414062e-4 , "2.4414063e-4" ) + , ( 2.4414062e-3 , "2.4414063e-3" ) + , ( 4.3945312e-3 , "4.3945313e-3" ) + , ( 6.3476562e-3 , "6.3476563e-3" ) + ] + , testMatches "f2sRegression" floatDec show + [ ( 4.7223665e21 , "4.7223665e21" ) + , ( 8388608.0 , "8388608.0" ) + , ( 1.6777216e7 , "1.6777216e7" ) + , ( 3.3554436e7 , "3.3554436e7" ) + , ( 6.7131496e7 , "6.7131496e7" ) + , ( 1.9310392e-38 , "1.9310392e-38" ) + , ( (-2.47e-43) , "-2.47e-43" ) + , ( 1.993244e-38 , "1.993244e-38" ) + , ( 4103.9003 , "4103.9004" ) + , ( 5.3399997e9 , "5.3399997e9" ) + , ( 6.0898e-39 , "6.0898e-39" ) + , ( 0.0010310042 , "1.0310042e-3" ) + , ( 2.8823261e17 , "2.882326e17" ) + , ( 7.0385309e-26 , "7.038531e-26" ) + , ( 9.2234038e17 , "9.223404e17" ) + , ( 6.7108872e7 , "6.710887e7" ) + , ( 1.0e-44 , "1.0e-44" ) + , ( 2.816025e14 , "2.816025e14" ) + , ( 9.223372e18 , "9.223372e18" ) + , ( 1.5846085e29 , "1.5846086e29" ) + , ( 1.1811161e19 , "1.1811161e19" ) + , ( 5.368709e18 , "5.368709e18" ) + , ( 4.6143165e18 , "4.6143166e18" ) + , ( 0.007812537 , "7.812537e-3" ) + , ( 1.4e-45 , "1.0e-45" ) + , ( 1.18697724e20 , "1.18697725e20" ) + , ( 1.00014165e-36 , "1.00014165e-36" ) + , ( 200.0 , "200.0" ) + , ( 3.3554432e7 , "3.3554432e7" ) + , ( 2.0019531 , "2.0019531" ) + , ( 2.001953 , "2.001953" ) + ] + , testExpected "f2sScientific" (formatFloat scientific) + [ ( 0.0 , "0.0e0" ) + , ( 8388608.0 , "8.388608e6" ) + , ( 1.6777216e7 , "1.6777216e7" ) + , ( 3.3554436e7 , "3.3554436e7" ) + , ( 6.7131496e7 , "6.7131496e7" ) + , ( 1.9310392e-38 , "1.9310392e-38" ) + , ( (-2.47e-43) , "-2.47e-43" ) + , ( 1.993244e-38 , "1.993244e-38" ) + , ( 4103.9003 , "4.1039004e3" ) + , ( 0.0010310042 , "1.0310042e-3" ) + , ( 0.007812537 , "7.812537e-3" ) + , ( 200.0 , "2.0e2" ) + , ( 2.0019531 , "2.0019531e0" ) + , ( 2.001953 , "2.001953e0" ) + ] + , testMatches "f2sLooksLikePowerOf5" floatDec show + [ ( coerceWord32ToFloat 0x5D1502F9 , "6.7108864e17" ) + , ( coerceWord32ToFloat 0x5D9502F9 , "1.3421773e18" ) + , ( coerceWord32ToFloat 0x5e1502F9 , "2.6843546e18" ) + ] + , testMatches "f2sOutputLength" floatDec show + [ ( 1.0 , "1.0" ) + , ( 1.2 , "1.2" ) + , ( 1.23 , "1.23" ) + , ( 1.234 , "1.234" ) + , ( 1.2345 , "1.2345" ) + , ( 1.23456 , "1.23456" ) + , ( 1.234567 , "1.234567" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.23456735e-36 , "1.23456735e-36" ) + ] + , testGroup "FShortest" + [ testProperty "prints equivalent value" \f -> read (LC.unpack $ toLazyByteString $ formatFloat shortest f) === f + , testProperty "shortest length always less than or equal to standard or scientific length outputs" \f -> let + sh = L.length $ toLazyByteString $ formatFloat shortest f + std = L.length $ toLazyByteString $ formatFloat standardDefaultPrecision f + sci = L.length $ toLazyByteString $ formatFloat scientific f + in sh ?<= min std sci + , testMatches "no .0 for whole numbers" (formatFloat shortest) (show . truncate) + [ (1, "1") + , (-1, "-1") + , (10, "10") + , (-10, "-10") + , (15, "15") + , (-15, "-15") ] - , testMatches "d2sSmallIntegers" doubleDec show - [ ( 9007199254740991.0 , "9.007199254740991e15" ) - , ( 9007199254740992.0 , "9.007199254740992e15" ) - - , ( 1.0e+0 , "1.0" ) - , ( 1.2e+1 , "12.0" ) - , ( 1.23e+2 , "123.0" ) - , ( 1.234e+3 , "1234.0" ) - , ( 1.2345e+4 , "12345.0" ) - , ( 1.23456e+5 , "123456.0" ) - , ( 1.234567e+6 , "1234567.0" ) - , ( 1.2345678e+7 , "1.2345678e7" ) - , ( 1.23456789e+8 , "1.23456789e8" ) - , ( 1.23456789e+9 , "1.23456789e9" ) - , ( 1.234567895e+9 , "1.234567895e9" ) - , ( 1.2345678901e+10 , "1.2345678901e10" ) - , ( 1.23456789012e+11 , "1.23456789012e11" ) - , ( 1.234567890123e+12 , "1.234567890123e12" ) - , ( 1.2345678901234e+13 , "1.2345678901234e13" ) - , ( 1.23456789012345e+14 , "1.23456789012345e14" ) - , ( 1.234567890123456e+15 , "1.234567890123456e15" ) - - -- 10^i - , ( 1.0e+0 , "1.0" ) - , ( 1.0e+1 , "10.0" ) - , ( 1.0e+2 , "100.0" ) - , ( 1.0e+3 , "1000.0" ) - , ( 1.0e+4 , "10000.0" ) - , ( 1.0e+5 , "100000.0" ) - , ( 1.0e+6 , "1000000.0" ) - , ( 1.0e+7 , "1.0e7" ) - , ( 1.0e+8 , "1.0e8" ) - , ( 1.0e+9 , "1.0e9" ) - , ( 1.0e+10 , "1.0e10" ) - , ( 1.0e+11 , "1.0e11" ) - , ( 1.0e+12 , "1.0e12" ) - , ( 1.0e+13 , "1.0e13" ) - , ( 1.0e+14 , "1.0e14" ) - , ( 1.0e+15 , "1.0e15" ) - - -- 10^15 + 10^i - , ( (1.0e+15 + 1.0e+0) , "1.000000000000001e15" ) - , ( (1.0e+15 + 1.0e+1) , "1.00000000000001e15" ) - , ( (1.0e+15 + 1.0e+2) , "1.0000000000001e15" ) - , ( (1.0e+15 + 1.0e+3) , "1.000000000001e15" ) - , ( (1.0e+15 + 1.0e+4) , "1.00000000001e15" ) - , ( (1.0e+15 + 1.0e+5) , "1.0000000001e15" ) - , ( (1.0e+15 + 1.0e+6) , "1.000000001e15" ) - , ( (1.0e+15 + 1.0e+7) , "1.00000001e15" ) - , ( (1.0e+15 + 1.0e+8) , "1.0000001e15" ) - , ( (1.0e+15 + 1.0e+9) , "1.000001e15" ) - , ( (1.0e+15 + 1.0e+10) , "1.00001e15" ) - , ( (1.0e+15 + 1.0e+11) , "1.0001e15" ) - , ( (1.0e+15 + 1.0e+12) , "1.001e15" ) - , ( (1.0e+15 + 1.0e+13) , "1.01e15" ) - , ( (1.0e+15 + 1.0e+14) , "1.1e15" ) - - -- Largest power of 2 <= 10^(i+1) - , ( 8.0 , "8.0" ) - , ( 64.0 , "64.0" ) - , ( 512.0 , "512.0" ) - , ( 8192.0 , "8192.0" ) - , ( 65536.0 , "65536.0" ) - , ( 524288.0 , "524288.0" ) - , ( 8388608.0 , "8388608.0" ) - , ( 67108864.0 , "6.7108864e7" ) - , ( 536870912.0 , "5.36870912e8" ) - , ( 8589934592.0 , "8.589934592e9" ) - , ( 68719476736.0 , "6.8719476736e10" ) - , ( 549755813888.0 , "5.49755813888e11" ) - , ( 8796093022208.0 , "8.796093022208e12" ) - , ( 70368744177664.0 , "7.0368744177664e13" ) - , ( 562949953421312.0 , "5.62949953421312e14" ) - , ( 9007199254740992.0 , "9.007199254740992e15" ) - - -- 1000 * (Largest power of 2 <= 10^(i+1)) - , ( 8.0e+3 , "8000.0" ) - , ( 64.0e+3 , "64000.0" ) - , ( 512.0e+3 , "512000.0" ) - , ( 8192.0e+3 , "8192000.0" ) - , ( 65536.0e+3 , "6.5536e7" ) - , ( 524288.0e+3 , "5.24288e8" ) - , ( 8388608.0e+3 , "8.388608e9" ) - , ( 67108864.0e+3 , "6.7108864e10" ) - , ( 536870912.0e+3 , "5.36870912e11" ) - , ( 8589934592.0e+3 , "8.589934592e12" ) - , ( 68719476736.0e+3 , "6.8719476736e13" ) - , ( 549755813888.0e+3 , "5.49755813888e14" ) - , ( 8796093022208.0e+3 , "8.796093022208e15" ) + ] + , testMatches "f2sPowersOf10" floatDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Float | x <- [-46..39 :: Int]] + ] + , testGroup "Double" + [ testMatches "d2sBasic" doubleDec show + [ ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + ] + , testMatches "f2sNonNumbersAndZero" doubleDec show + [ ( 0.0 , "0.0" ) + , ( (-0.0) , "-0.0" ) + , ( (0/0) , "NaN" ) + , ( (1/0) , "Infinity" ) + , ( (-1/0) , "-Infinity" ) + ] + , testMatches "d2sSubnormal" doubleDec show + [ ( 2.2250738585072014e-308 , "2.2250738585072014e-308" ) + ] + , testMatches "d2sMinAndMax" doubleDec show + [ ( (coerceWord64ToDouble 0x7fefffffffffffff) , "1.7976931348623157e308" ) + , ( (coerceWord64ToDouble 0x0000000000000001) , "5.0e-324" ) + ] + , testMatches "d2sTrailingZeros" doubleDec show + [ ( 2.98023223876953125e-8 , "2.9802322387695313e-8" ) + ] + , testMatches "d2sRegression" doubleDec show + [ ( (-2.109808898695963e16) , "-2.1098088986959632e16" ) + , ( 4.940656e-318 , "4.940656e-318" ) + , ( 1.18575755e-316 , "1.18575755e-316" ) + , ( 2.989102097996e-312 , "2.989102097996e-312" ) + , ( 9.0608011534336e15 , "9.0608011534336e15" ) + , ( 4.708356024711512e18 , "4.708356024711512e18" ) + , ( 9.409340012568248e18 , "9.409340012568248e18" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.9430376160308388e16 , "1.9430376160308388e16" ) + , ( (-6.9741824662760956e19), "-6.9741824662760956e19" ) + , ( 4.3816050601147837e18 , "4.3816050601147837e18" ) + ] + , testExpected "d2sScientific" (formatDouble scientific) + [ ( 0.0 , "0.0e0" ) + , ( 1.2345678 , "1.2345678e0" ) + , ( 4.294967294 , "4.294967294e0" ) + , ( 4.294967295 , "4.294967295e0" ) + ] + , testGroup "d2sStandard" + [ testCase "specific" do + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3 , "12.30" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.345 , "12.34" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3451 , "12.35" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0050 , "0.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.999 , "1000.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.199 , "999.20" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.999 , "1.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0051 , "0.01" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0056 , "0.006" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0096 , "0.010" ) + singleMatches (formatDouble (standard 5)) (flip (showFFloat (Just 5)) []) ( 12.345 , "12.34500" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0 , "0.000" ) + , testProperty "standard N" \(NonNegative p, d :: Double) -> (LC.unpack . toLazyByteString) + (formatDouble (standard p) d) === showFFloat (Just p) d "" + ] + , testMatches "d2sLooksLikePowerOf5" doubleDec show + [ ( (coerceWord64ToDouble 0x4830F0CF064DD592) , "5.764607523034235e39" ) + , ( (coerceWord64ToDouble 0x4840F0CF064DD592) , "1.152921504606847e40" ) + , ( (coerceWord64ToDouble 0x4850F0CF064DD592) , "2.305843009213694e40" ) + , ( (coerceWord64ToDouble 0x4400000000000004) , "3.689348814741914e19" ) + + -- here v- is a power of 5 but since we don't accept bounds there is no + -- interesting trailing behavior + , ( (coerceWord64ToDouble 0x440000000000301d) , "3.6893488147520004e19" ) + ] + , testMatches "d2sOutputLength" doubleDec show + [ ( 1 , "1.0" ) + , ( 1.2 , "1.2" ) + , ( 1.23 , "1.23" ) + , ( 1.234 , "1.234" ) + , ( 1.2345 , "1.2345" ) + , ( 1.23456 , "1.23456" ) + , ( 1.234567 , "1.234567" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.23456789 , "1.23456789" ) + , ( 1.234567895 , "1.234567895" ) + , ( 1.2345678901 , "1.2345678901" ) + , ( 1.23456789012 , "1.23456789012" ) + , ( 1.234567890123 , "1.234567890123" ) + , ( 1.2345678901234 , "1.2345678901234" ) + , ( 1.23456789012345 , "1.23456789012345" ) + , ( 1.234567890123456 , "1.234567890123456" ) + , ( 1.2345678901234567 , "1.2345678901234567" ) + + -- Test 32-bit chunking + , ( 4.294967294 , "4.294967294" ) + , ( 4.294967295 , "4.294967295" ) + , ( 4.294967296 , "4.294967296" ) + , ( 4.294967297 , "4.294967297" ) + , ( 4.294967298 , "4.294967298" ) + ] + , testMatches "d2sMinMaxShift" doubleDec show + [ ( (ieeeParts2Double False 4 0) , "1.7800590868057611e-307" ) + -- 32-bit opt-size=0: 49 <= dist <= 49 + -- 32-bit opt-size=1: 28 <= dist <= 49 + -- 64-bit opt-size=0: 50 <= dist <= 50 + -- 64-bit opt-size=1: 28 <= dist <= 50 + , ( (ieeeParts2Double False 6 maxMantissa) , "2.8480945388892175e-306" ) + -- 32-bit opt-size=0: 52 <= dist <= 53 + -- 32-bit opt-size=1: 2 <= dist <= 53 + -- 64-bit opt-size=0: 53 <= dist <= 53 + -- 64-bit opt-size=1: 2 <= dist <= 53 + , ( (ieeeParts2Double False 41 0) , "2.446494580089078e-296" ) + -- 32-bit opt-size=0: 52 <= dist <= 52 + -- 32-bit opt-size=1: 2 <= dist <= 52 + -- 64-bit opt-size=0: 53 <= dist <= 53 + -- 64-bit opt-size=1: 2 <= dist <= 53 + , ( (ieeeParts2Double False 40 maxMantissa) , "4.8929891601781557e-296" ) + -- 32-bit opt-size=0: 57 <= dist <= 58 + -- 32-bit opt-size=1: 57 <= dist <= 58 + -- 64-bit opt-size=0: 58 <= dist <= 58 + -- 64-bit opt-size=1: 58 <= dist <= 58 + , ( (ieeeParts2Double False 1077 0) , "1.8014398509481984e16" ) + -- 32-bit opt-size=0: 57 <= dist <= 57 + -- 32-bit opt-size=1: 57 <= dist <= 57 + -- 64-bit opt-size=0: 58 <= dist <= 58 + -- 64-bit opt-size=1: 58 <= dist <= 58 + , ( (ieeeParts2Double False 1076 maxMantissa) , "3.6028797018963964e16" ) + -- 32-bit opt-size=0: 51 <= dist <= 52 + -- 32-bit opt-size=1: 51 <= dist <= 59 + -- 64-bit opt-size=0: 52 <= dist <= 52 + -- 64-bit opt-size=1: 52 <= dist <= 59 + , ( (ieeeParts2Double False 307 0) , "2.900835519859558e-216" ) + -- 32-bit opt-size=0: 51 <= dist <= 51 + -- 32-bit opt-size=1: 51 <= dist <= 59 + -- 64-bit opt-size=0: 52 <= dist <= 52 + -- 64-bit opt-size=1: 52 <= dist <= 59 + , ( (ieeeParts2Double False 306 maxMantissa) , "5.801671039719115e-216" ) + -- 32-bit opt-size=0: 49 <= dist <= 49 + -- 32-bit opt-size=1: 44 <= dist <= 49 + -- 64-bit opt-size=0: 50 <= dist <= 50 + -- 64-bit opt-size=1: 44 <= dist <= 50 + , ( (ieeeParts2Double False 934 0x000FA7161A4D6e0C) , "3.196104012172126e-27" ) + ] + , testMatches "d2sSmallIntegers" doubleDec show + [ ( 9007199254740991.0 , "9.007199254740991e15" ) + , ( 9007199254740992.0 , "9.007199254740992e15" ) + + , ( 1.0e+0 , "1.0" ) + , ( 1.2e+1 , "12.0" ) + , ( 1.23e+2 , "123.0" ) + , ( 1.234e+3 , "1234.0" ) + , ( 1.2345e+4 , "12345.0" ) + , ( 1.23456e+5 , "123456.0" ) + , ( 1.234567e+6 , "1234567.0" ) + , ( 1.2345678e+7 , "1.2345678e7" ) + , ( 1.23456789e+8 , "1.23456789e8" ) + , ( 1.23456789e+9 , "1.23456789e9" ) + , ( 1.234567895e+9 , "1.234567895e9" ) + , ( 1.2345678901e+10 , "1.2345678901e10" ) + , ( 1.23456789012e+11 , "1.23456789012e11" ) + , ( 1.234567890123e+12 , "1.234567890123e12" ) + , ( 1.2345678901234e+13 , "1.2345678901234e13" ) + , ( 1.23456789012345e+14 , "1.23456789012345e14" ) + , ( 1.234567890123456e+15 , "1.234567890123456e15" ) + + -- 10^i + , ( 1.0e+0 , "1.0" ) + , ( 1.0e+1 , "10.0" ) + , ( 1.0e+2 , "100.0" ) + , ( 1.0e+3 , "1000.0" ) + , ( 1.0e+4 , "10000.0" ) + , ( 1.0e+5 , "100000.0" ) + , ( 1.0e+6 , "1000000.0" ) + , ( 1.0e+7 , "1.0e7" ) + , ( 1.0e+8 , "1.0e8" ) + , ( 1.0e+9 , "1.0e9" ) + , ( 1.0e+10 , "1.0e10" ) + , ( 1.0e+11 , "1.0e11" ) + , ( 1.0e+12 , "1.0e12" ) + , ( 1.0e+13 , "1.0e13" ) + , ( 1.0e+14 , "1.0e14" ) + , ( 1.0e+15 , "1.0e15" ) + + -- 10^15 + 10^i + , ( (1.0e+15 + 1.0e+0) , "1.000000000000001e15" ) + , ( (1.0e+15 + 1.0e+1) , "1.00000000000001e15" ) + , ( (1.0e+15 + 1.0e+2) , "1.0000000000001e15" ) + , ( (1.0e+15 + 1.0e+3) , "1.000000000001e15" ) + , ( (1.0e+15 + 1.0e+4) , "1.00000000001e15" ) + , ( (1.0e+15 + 1.0e+5) , "1.0000000001e15" ) + , ( (1.0e+15 + 1.0e+6) , "1.000000001e15" ) + , ( (1.0e+15 + 1.0e+7) , "1.00000001e15" ) + , ( (1.0e+15 + 1.0e+8) , "1.0000001e15" ) + , ( (1.0e+15 + 1.0e+9) , "1.000001e15" ) + , ( (1.0e+15 + 1.0e+10) , "1.00001e15" ) + , ( (1.0e+15 + 1.0e+11) , "1.0001e15" ) + , ( (1.0e+15 + 1.0e+12) , "1.001e15" ) + , ( (1.0e+15 + 1.0e+13) , "1.01e15" ) + , ( (1.0e+15 + 1.0e+14) , "1.1e15" ) + + -- Largest power of 2 <= 10^(i+1) + , ( 8.0 , "8.0" ) + , ( 64.0 , "64.0" ) + , ( 512.0 , "512.0" ) + , ( 8192.0 , "8192.0" ) + , ( 65536.0 , "65536.0" ) + , ( 524288.0 , "524288.0" ) + , ( 8388608.0 , "8388608.0" ) + , ( 67108864.0 , "6.7108864e7" ) + , ( 536870912.0 , "5.36870912e8" ) + , ( 8589934592.0 , "8.589934592e9" ) + , ( 68719476736.0 , "6.8719476736e10" ) + , ( 549755813888.0 , "5.49755813888e11" ) + , ( 8796093022208.0 , "8.796093022208e12" ) + , ( 70368744177664.0 , "7.0368744177664e13" ) + , ( 562949953421312.0 , "5.62949953421312e14" ) + , ( 9007199254740992.0 , "9.007199254740992e15" ) + + -- 1000 * (Largest power of 2 <= 10^(i+1)) + , ( 8.0e+3 , "8000.0" ) + , ( 64.0e+3 , "64000.0" ) + , ( 512.0e+3 , "512000.0" ) + , ( 8192.0e+3 , "8192000.0" ) + , ( 65536.0e+3 , "6.5536e7" ) + , ( 524288.0e+3 , "5.24288e8" ) + , ( 8388608.0e+3 , "8.388608e9" ) + , ( 67108864.0e+3 , "6.7108864e10" ) + , ( 536870912.0e+3 , "5.36870912e11" ) + , ( 8589934592.0e+3 , "8.589934592e12" ) + , ( 68719476736.0e+3 , "6.8719476736e13" ) + , ( 549755813888.0e+3 , "5.49755813888e14" ) + , ( 8796093022208.0e+3 , "8.796093022208e15" ) + ] + , testGroup "FShortest" + [ testProperty "prints equivalent value" \f -> read (LC.unpack $ toLazyByteString $ formatDouble shortest f) === f + , testProperty "shortest length always less than or equal to standard or scientific length outputs" \f -> let + sh = L.length $ toLazyByteString $ formatDouble shortest f + std = L.length $ toLazyByteString $ formatDouble standardDefaultPrecision f + sci = L.length $ toLazyByteString $ formatDouble scientific f + in sh ?<= min std sci + , testMatches "no .0 for whole numbers" (formatDouble shortest) (show . truncate) + [ (1, "1") + , (-1, "-1") + , (10, "10") + , (-10, "-10") + , (15, "15") + , (-15, "-15") ] - , testMatches "f2sPowersOf10" floatDec show $ - fmap asShowRef [read ("1.0e" ++ show x) :: Float | x <- [-46..39 :: Int]] - , testMatches "d2sPowersOf10" doubleDec show $ - fmap asShowRef [read ("1.0e" ++ show x) :: Double | x <- [-324..309 :: Int]] + ] + , testMatches "d2sPowersOf10" doubleDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Double | x <- [-324..309 :: Int]] + ] ] where testExpected :: TestName -> (a -> Builder) -> [(a, String)] -> TestTree - testExpected name dec lst = testProperty name . conjoin $ - fmap (\(x, ref) -> L.unpack (toLazyByteString (dec x)) === encodeASCII ref) lst + testExpected name dec = testCase name . traverse_ \(x, ref) -> LC.unpack (toLazyByteString (dec x)) @?= ref - singleMatches :: (a -> Builder) -> (a -> String) -> (a, String) -> Property - singleMatches dec refdec (x, ref) = L.unpack (toLazyByteString (dec x)) === encodeASCII (refdec x) .&&. refdec x === ref + singleMatches :: (a -> Builder) -> (a -> String) -> (a, String) -> Assertion + singleMatches dec refdec (x, ref) = do + LC.unpack (toLazyByteString (dec x)) @?= refdec x + refdec x @?= ref testMatches :: TestName -> (a -> Builder) -> (a -> String) -> [(a, String)] -> TestTree - testMatches name dec refdec lst = testProperty name . conjoin $ fmap (singleMatches dec refdec) lst + testMatches name dec refdec = testCase name . traverse_ (singleMatches dec refdec) maxMantissa = (1 `shiftL` 53) - 1 :: Word64 diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs.orig b/tests/builder/Data/ByteString/Builder/Tests.hs.orig new file mode 100644 index 000000000..1058e9f1f --- /dev/null +++ b/tests/builder/Data/ByteString/Builder/Tests.hs.orig @@ -0,0 +1,1001 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Testing composition of 'Builders'. + +module Data.ByteString.Builder.Tests (tests) where + +import Prelude hiding (writeFile) + +import Control.Applicative +import Control.Monad (unless, void) +import Control.Monad.Trans.State (StateT, evalStateT, evalState, put, get) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Writer (WriterT, execWriterT, tell) + +import Foreign (minusPtr) + +import Data.Char (chr) +import Data.Bits ((.|.), shiftL) +import Data.Foldable +import Data.Semigroup (Semigroup(..)) +import Data.Word + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import qualified Data.ByteString.Short as Sh + +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra +import Data.ByteString.Builder.Internal (Put, putBuilder, fromPut) +import qualified Data.ByteString.Builder.Internal as BI +import qualified Data.ByteString.Builder.Prim as BP +import Data.ByteString.Builder.Prim.TestUtils + +import Control.Exception (evaluate) +import System.IO (openTempFile, hPutStr, hClose, hSetBinaryMode, hSetEncoding, utf8, hSetNewlineMode, noNewlineTranslation) +import Foreign (ForeignPtr, withForeignPtr, castPtr) +import Foreign.C.String (withCString) +import Numeric (showFFloat) +import System.Posix.Internals (c_unlink) + +import Test.Tasty (TestTree, TestName, testGroup) +import Test.Tasty.HUnit (testCase, (@?=), Assertion) +import Test.Tasty.QuickCheck + ( Arbitrary(..), oneof, choose, listOf, elements, forAll + , counterexample, ioProperty, Property, testProperty + , (===), (.&&.), conjoin + , UnicodeString(..), NonNegative(..) + ) +import QuickCheckUtils + + +tests :: [TestTree] +tests = + [ testBuilderRecipe + , testHandlePutBuilder + , testHandlePutBuilderChar8 + , testPut + , testRunBuilder + , testWriteFile + , testStimes + ] ++ + testsEncodingToBuilder ++ + testsBinary ++ + testsASCII ++ + testsFloating ++ + testsChar8 ++ + testsUtf8 + + +------------------------------------------------------------------------------ +-- Testing 'Builder' execution +------------------------------------------------------------------------------ + +testBuilderRecipe :: TestTree +testBuilderRecipe = + testProperty "toLazyByteStringWith" $ testRecipe <$> arbitrary + where + testRecipe r = + counterexample msg $ x1 == x2 + where + x1 = renderRecipe r + x2 = buildRecipe r + toString = map (chr . fromIntegral) + msg = unlines + [ "recipe: " ++ show r + , "render: " ++ toString x1 + , "build : " ++ toString x2 + , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) + ] + +testHandlePutBuilder :: TestTree +testHandlePutBuilder = + testProperty "hPutBuilder" testRecipe + where + testRecipe :: (UnicodeString, UnicodeString, UnicodeString, Recipe) -> Property + testRecipe args = + ioProperty $ do + let { ( UnicodeString before + , UnicodeString between + , UnicodeString after + , recipe) = args } + (tempFile, tempH) <- openTempFile "." "test-builder.tmp" + -- switch to UTF-8 encoding + hSetEncoding tempH utf8 + hSetNewlineMode tempH noNewlineTranslation + -- output recipe with intermediate direct writing to handle + let b = fst $ recipeComponents recipe + hPutStr tempH before + hPutBuilder tempH b + hPutStr tempH between + hPutBuilder tempH b + hPutStr tempH after + hClose tempH + -- read file + lbs <- L.readFile tempFile + _ <- evaluate (L.length $ lbs) + removeFile tempFile + -- compare to pure builder implementation + let lbsRef = toLazyByteString $ fold + [stringUtf8 before, b, stringUtf8 between, b, stringUtf8 after] + -- report + let msg = unlines + [ "task: " ++ show args + , "via file: " ++ show lbs + , "direct : " ++ show lbsRef + -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) + ] + success = lbs == lbsRef + unless success (error msg) + return success + +testHandlePutBuilderChar8 :: TestTree +testHandlePutBuilderChar8 = + testProperty "char8 hPutBuilder" testRecipe + where + testRecipe :: (String, String, String, Recipe) -> Property + testRecipe args@(before, between, after, recipe) = ioProperty $ do + (tempFile, tempH) <- openTempFile "." "TestBuilder" + -- switch to binary / latin1 encoding + hSetBinaryMode tempH True + -- output recipe with intermediate direct writing to handle + let b = fst $ recipeComponents recipe + hPutStr tempH before + hPutBuilder tempH b + hPutStr tempH between + hPutBuilder tempH b + hPutStr tempH after + hClose tempH + -- read file + lbs <- L.readFile tempFile + _ <- evaluate (L.length $ lbs) + removeFile tempFile + -- compare to pure builder implementation + let lbsRef = toLazyByteString $ fold + [string8 before, b, string8 between, b, string8 after] + -- report + let msg = unlines + [ "task: " ++ show args + , "via file: " ++ show lbs + , "direct : " ++ show lbsRef + -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) + ] + success = lbs == lbsRef + unless success (error msg) + return success + +testWriteFile :: TestTree +testWriteFile = + testProperty "writeFile" testRecipe + where + testRecipe :: Recipe -> Property + testRecipe recipe = + ioProperty $ do + (tempFile, tempH) <- openTempFile "." "test-builder-writeFile.tmp" + hClose tempH + let b = fst $ recipeComponents recipe + writeFile tempFile b + lbs <- L.readFile tempFile + _ <- evaluate (L.length $ lbs) + removeFile tempFile + let lbsRef = toLazyByteString b + -- report + let msg = + unlines + [ "recipe: " ++ show recipe + , "via file: " ++ show lbs + , "direct : " ++ show lbsRef + ] + success = lbs == lbsRef + unless success (error msg) + return success + +testStimes :: TestTree +testStimes = testProperty "stimes" $ + \(Sqrt (NonNegative n)) (Sqrt x) -> + stimes (n :: Int) x === toLazyByteString (stimes n (lazyByteString x)) + +removeFile :: String -> IO () +removeFile fn = void $ withCString fn c_unlink + +-- Recipes with which to test the builder functions +--------------------------------------------------- + +data Mode = + Threshold Int + | Insert + | Copy + | Smart + | Hex + deriving( Eq, Ord, Show ) + +data Action = + SBS Mode S.ByteString + | LBS Mode L.ByteString + | ShBS Sh.ShortByteString + | W8 Word8 + | W8S [Word8] + | String String + | FDec Float + | DDec Double + | Flush + | EnsureFree Word + | ModState Int + deriving( Eq, Ord, Show ) + +data Strategy = Safe | Untrimmed + deriving( Eq, Ord, Show ) + +data Recipe = Recipe Strategy Int Int L.ByteString [Action] + deriving( Eq, Ord, Show ) + +newtype DList a = DList ([a] -> [a]) + +instance Semigroup (DList a) where + DList f <> DList g = DList (f . g) + +instance Monoid (DList a) where + mempty = DList id + mappend = (<>) + +fromDList :: DList a -> [a] +fromDList (DList f) = f [] + +toDList :: [a] -> DList a +toDList xs = DList (xs <>) + +renderRecipe :: Recipe -> [Word8] +renderRecipe (Recipe _ firstSize _ cont as) = + fromDList $ evalState (execWriterT (traverse_ renderAction as)) firstSize <> renderLBS cont + where + renderAction :: Monad m => Action -> WriterT (DList Word8) (StateT Int m) () + renderAction (SBS Hex bs) = tell $ foldMap hexWord8 $ S.unpack bs + renderAction (SBS _ bs) = tell $ toDList $ S.unpack bs + renderAction (LBS Hex lbs) = tell $ foldMap hexWord8 $ L.unpack lbs + renderAction (LBS _ lbs) = tell $ renderLBS lbs + renderAction (ShBS sbs) = tell $ toDList $ Sh.unpack sbs + renderAction (W8 w) = tell $ toDList [w] + renderAction (W8S ws) = tell $ toDList ws + renderAction (String cs) = tell $ foldMap (toDList . charUtf8_list) cs + renderAction Flush = tell $ mempty + renderAction (EnsureFree _) = tell $ mempty + renderAction (FDec f) = tell $ toDList $ encodeASCII $ show f + renderAction (DDec d) = tell $ toDList $ encodeASCII $ show d + renderAction (ModState i) = do + s <- lift get + tell (toDList $ encodeASCII $ show s) + lift $ put (s - i) + + renderLBS = toDList . L.unpack + hexWord8 = toDList . wordHexFixed_list + +buildAction :: Action -> StateT Int Put () +buildAction (SBS Hex bs) = lift $ putBuilder $ byteStringHex bs +buildAction (SBS Smart bs) = lift $ putBuilder $ byteString bs +buildAction (SBS Copy bs) = lift $ putBuilder $ byteStringCopy bs +buildAction (SBS Insert bs) = lift $ putBuilder $ byteStringInsert bs +buildAction (SBS (Threshold i) bs) = lift $ putBuilder $ byteStringThreshold i bs +buildAction (LBS Hex lbs) = lift $ putBuilder $ lazyByteStringHex lbs +buildAction (LBS Smart lbs) = lift $ putBuilder $ lazyByteString lbs +buildAction (LBS Copy lbs) = lift $ putBuilder $ lazyByteStringCopy lbs +buildAction (LBS Insert lbs) = lift $ putBuilder $ lazyByteStringInsert lbs +buildAction (LBS (Threshold i) lbs) = lift $ putBuilder $ lazyByteStringThreshold i lbs +buildAction (ShBS sbs) = lift $ putBuilder $ shortByteString sbs +buildAction (W8 w) = lift $ putBuilder $ word8 w +buildAction (W8S ws) = lift $ putBuilder $ BP.primMapListFixed BP.word8 ws +buildAction (String cs) = lift $ putBuilder $ stringUtf8 cs +buildAction (FDec f) = lift $ putBuilder $ floatDec f +buildAction (DDec d) = lift $ putBuilder $ doubleDec d +buildAction Flush = lift $ putBuilder $ flush +buildAction (EnsureFree minFree) = lift $ putBuilder $ ensureFree $ fromIntegral minFree +buildAction (ModState i) = do + s <- get + lift $ putBuilder $ intDec s + put (s - i) + +buildRecipe :: Recipe -> [Word8] +buildRecipe recipe = + L.unpack $ toLBS b + where + (b, toLBS) = recipeComponents recipe + + +recipeComponents :: Recipe -> (Builder, Builder -> L.ByteString) +recipeComponents (Recipe how firstSize otherSize cont as) = + (b, toLBS) + where + toLBS = toLazyByteStringWith (strategy how firstSize otherSize) cont + where + strategy Safe = safeStrategy + strategy Untrimmed = untrimmedStrategy + + b = fromPut $ evalStateT (traverse_ buildAction as) firstSize + + +-- 'Arbitary' instances +----------------------- + +instance Arbitrary Mode where + arbitrary = oneof + [Threshold <$> arbitrary, pure Smart, pure Insert, pure Copy, pure Hex] + + shrink (Threshold i) = Threshold <$> shrink i + shrink _ = [] + +instance Arbitrary Action where + arbitrary = oneof + [ SBS <$> arbitrary <*> arbitrary + , LBS <$> arbitrary <*> arbitrary + , ShBS . Sh.toShort <$> arbitrary + , W8 <$> arbitrary + , W8S <$> listOf arbitrary + -- ensure that larger character codes are also tested + , String . getUnicodeString <$> arbitrary + , pure Flush + -- never request more than 64kb free space + , (EnsureFree . (`mod` 0xffff)) <$> arbitrary + , FDec <$> arbitrary + , DDec <$> arbitrary + , ModState <$> arbitrary + ] + where + + shrink (SBS m bs) = + (SBS <$> shrink m <*> pure bs) <|> + (SBS <$> pure m <*> shrink bs) + shrink (LBS m lbs) = + (LBS <$> shrink m <*> pure lbs) <|> + (LBS <$> pure m <*> shrink lbs) + shrink (ShBS sbs) = + ShBS . Sh.toShort <$> shrink (Sh.fromShort sbs) + shrink (W8 w) = W8 <$> shrink w + shrink (W8S ws) = W8S <$> shrink ws + shrink (String cs) = String <$> shrink cs + shrink Flush = [] + shrink (EnsureFree i) = EnsureFree <$> shrink i + shrink (FDec f) = FDec <$> shrink f + shrink (DDec d) = DDec <$> shrink d + shrink (ModState i) = ModState <$> shrink i + +instance Arbitrary Strategy where + arbitrary = elements [Safe, Untrimmed] + shrink _ = [] + +instance Arbitrary Recipe where + arbitrary = + Recipe <$> arbitrary + <*> ((`mod` 33333) <$> arbitrary) -- bound max chunk-sizes + <*> ((`mod` 33337) <$> arbitrary) + <*> arbitrary + <*> listOf arbitrary + + -- shrinking the actions first is desirable + shrink (Recipe a b c d e) = asum + [ (\x -> Recipe a b c d x) <$> shrink e + , (\x -> Recipe a b c x e) <$> shrink d + , (\x -> Recipe a b x d e) <$> shrink c + , (\x -> Recipe a x c d e) <$> shrink b + , (\x -> Recipe x b c d e) <$> shrink a + ] + + +------------------------------------------------------------------------------ +-- Creating Builders from basic encodings +------------------------------------------------------------------------------ + +testsEncodingToBuilder :: [TestTree] +testsEncodingToBuilder = + [ test_encodeUnfoldrF + , test_encodeUnfoldrB + ] + + +-- Unfoldr fused with encoding +------------------------------ + +test_encodeUnfoldrF :: TestTree +test_encodeUnfoldrF = + compareImpls "encodeUnfoldrF word8" id encode + where + toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty + encode = + L.unpack . toLBS . BP.primUnfoldrFixed BP.word8 go + where + go [] = Nothing + go (w:ws) = Just (w, ws) + + +test_encodeUnfoldrB :: TestTree +test_encodeUnfoldrB = + compareImpls "encodeUnfoldrB charUtf8" (foldMap charUtf8_list) encode + where + toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty + encode = + L.unpack . toLBS . BP.primUnfoldrBounded BP.charUtf8 go + where + go [] = Nothing + go (c:cs) = Just (c, cs) + + +------------------------------------------------------------------------------ +-- Testing the Put monad +------------------------------------------------------------------------------ + +testPut :: TestTree +testPut = testGroup "Put monad" + [ testLaw "identity" (\v -> (pure id <*> putInt v) `eqPut` (putInt v)) + + , testLaw "composition" $ \(u, v, w) -> + (pure (.) <*> minusInt u <*> minusInt v <*> putInt w) `eqPut` + (minusInt u <*> (minusInt v <*> putInt w)) + + , testLaw "homomorphism" $ \(f, x) -> + (pure (f -) <*> pure x) `eqPut` (pure (f - x)) + + , testLaw "interchange" $ \(u, y) -> + (minusInt u <*> pure y) `eqPut` (pure ($ y) <*> minusInt u) + + , testLaw "ignore left value" $ \(u, v) -> + (putInt u *> putInt v) `eqPut` (pure (const id) <*> putInt u <*> putInt v) + + , testLaw "ignore right value" $ \(u, v) -> + (putInt u <* putInt v) `eqPut` (pure const <*> putInt u <*> putInt v) + + , testLaw "functor" $ \(f, x) -> + (fmap (f -) (putInt x)) `eqPut` (pure (f -) <*> putInt x) + + ] + where + putInt i = putBuilder (integerDec i) >> return i + minusInt i = (-) <$> putInt i + run p = toLazyByteString $ fromPut (do i <- p; _ <- putInt i; return ()) + eqPut p1 p2 = (run p1, run p2) + + testLaw name f = compareImpls name (fst . f) (snd . f) + + +------------------------------------------------------------------------------ +-- Testing the Driver <-> Builder protocol +------------------------------------------------------------------------------ + +-- | Ensure that there are at least 'n' free bytes for the following 'Builder'. +{-# INLINE ensureFree #-} +ensureFree :: Int -> Builder +ensureFree minFree = + BI.builder step + where + step k br@(BI.BufferRange op ope) + | ope `minusPtr` op < minFree = return $ BI.bufferFull minFree op next + | otherwise = k br + where + next br'@(BI.BufferRange op' ope') + | freeSpace < minFree = + error $ "ensureFree: requested " ++ show minFree ++ " bytes, " ++ + "but got only " ++ show freeSpace ++ " bytes" + | otherwise = k br' + where + freeSpace = ope' `minusPtr` op' + + +------------------------------------------------------------------------------ +-- Testing the Builder runner +------------------------------------------------------------------------------ + +testRunBuilder :: TestTree +testRunBuilder = + testProperty "runBuilder" prop + where + prop actions = + ioProperty $ do + let (builder, _) = recipeComponents recipe + expected = renderRecipe recipe + actual <- bufferWriterOutput (runBuilder builder) + return (S.unpack actual == expected) + where + recipe = Recipe Safe 0 0 L.empty actions + +bufferWriterOutput :: BufferWriter -> IO S.ByteString +bufferWriterOutput bwrite0 = do + let len0 = 8 + buf <- S.mallocByteString len0 + bss <- go [] buf len0 bwrite0 + return (S.concat (reverse bss)) + where + go :: [S.ByteString] -> ForeignPtr Word8 -> Int -> BufferWriter -> IO [S.ByteString] + go bss !buf !len bwrite = do + (wc, next) <- withForeignPtr buf $ \ptr -> bwrite ptr len + bs <- getBuffer buf wc + case next of + Done -> return (bs:bss) + More m bwrite' | m <= len -> go (bs:bss) buf len bwrite' + | otherwise -> do let len' = m + buf' <- S.mallocByteString len' + go (bs:bss) buf' len' bwrite' + Chunk c bwrite' -> go (c:bs:bss) buf len bwrite' + + getBuffer :: ForeignPtr Word8 -> Int -> IO S.ByteString + getBuffer buf len = withForeignPtr buf $ \ptr -> + S.packCStringLen (castPtr ptr, len) + + +------------------------------------------------------------------------------ +-- Testing the pre-defined builders +------------------------------------------------------------------------------ + +testBuilderConstr :: (Arbitrary a, Show a) + => TestName -> (a -> [Word8]) -> (a -> Builder) -> TestTree +testBuilderConstr name ref mkBuilder = + testProperty name check + where + check x = forAll (choose (0, maxPaddingAmount)) $ \paddingAmount -> let + -- use padding to make sure we test at unaligned positions + ws = ref x + b1 = mkBuilder x + b2 = byteStringCopy (S.take paddingAmount padBuf) <> b1 <> b1 + in (replicate paddingAmount (S.c2w ' ') ++ ws ++ ws) === + (L.unpack $ toLazyByteString b2) + + maxPaddingAmount = 15 + padBuf = S.replicate maxPaddingAmount (S.c2w ' ') + + +testsBinary :: [TestTree] +testsBinary = + [ testBuilderConstr "word8" bigEndian_list word8 + , testBuilderConstr "int8" bigEndian_list int8 + + -- big-endian + , testBuilderConstr "int16BE" bigEndian_list int16BE + , testBuilderConstr "int32BE" bigEndian_list int32BE + , testBuilderConstr "int64BE" bigEndian_list int64BE + + , testBuilderConstr "word16BE" bigEndian_list word16BE + , testBuilderConstr "word32BE" bigEndian_list word32BE + , testBuilderConstr "word64BE" bigEndian_list word64BE + + , testBuilderConstr "floatLE" (float_list littleEndian_list) floatLE + , testBuilderConstr "doubleLE" (double_list littleEndian_list) doubleLE + + -- little-endian + , testBuilderConstr "int16LE" littleEndian_list int16LE + , testBuilderConstr "int32LE" littleEndian_list int32LE + , testBuilderConstr "int64LE" littleEndian_list int64LE + + , testBuilderConstr "word16LE" littleEndian_list word16LE + , testBuilderConstr "word32LE" littleEndian_list word32LE + , testBuilderConstr "word64LE" littleEndian_list word64LE + + , testBuilderConstr "floatBE" (float_list bigEndian_list) floatBE + , testBuilderConstr "doubleBE" (double_list bigEndian_list) doubleBE + + -- host dependent + , testBuilderConstr "int16Host" hostEndian_list int16Host + , testBuilderConstr "int32Host" hostEndian_list int32Host + , testBuilderConstr "int64Host" hostEndian_list int64Host + , testBuilderConstr "intHost" hostEndian_list intHost + + , testBuilderConstr "word16Host" hostEndian_list word16Host + , testBuilderConstr "word32Host" hostEndian_list word32Host + , testBuilderConstr "word64Host" hostEndian_list word64Host + , testBuilderConstr "wordHost" hostEndian_list wordHost + + , testBuilderConstr "floatHost" (float_list hostEndian_list) floatHost + , testBuilderConstr "doubleHost" (double_list hostEndian_list) doubleHost + ] + +testsASCII :: [TestTree] +testsASCII = + [ testBuilderConstr "char7" char7_list char7 + , testBuilderConstr "string7" (foldMap char7_list) string7 + + , testBuilderConstr "int8Dec" dec_list int8Dec + , testBuilderConstr "int16Dec" dec_list int16Dec + , testBuilderConstr "int32Dec" dec_list int32Dec + , testBuilderConstr "int64Dec" dec_list int64Dec + , testBuilderConstr "intDec" dec_list intDec + + , testBuilderConstr "word8Dec" dec_list word8Dec + , testBuilderConstr "word16Dec" dec_list word16Dec + , testBuilderConstr "word32Dec" dec_list word32Dec + , testBuilderConstr "word64Dec" dec_list word64Dec + , testBuilderConstr "wordDec" dec_list wordDec + + , testBuilderConstr "integerDec" (dec_list . enlarge) (integerDec . enlarge) + , testBuilderConstr "floatDec" dec_list floatDec + , testBuilderConstr "doubleDec" dec_list doubleDec + + , testBuilderConstr "word8Hex" hex_list word8Hex + , testBuilderConstr "word16Hex" hex_list word16Hex + , testBuilderConstr "word32Hex" hex_list word32Hex + , testBuilderConstr "word64Hex" hex_list word64Hex + , testBuilderConstr "wordHex" hex_list wordHex + + , testBuilderConstr "word8HexFixed" wordHexFixed_list word8HexFixed + , testBuilderConstr "word16HexFixed" wordHexFixed_list word16HexFixed + , testBuilderConstr "word32HexFixed" wordHexFixed_list word32HexFixed + , testBuilderConstr "word64HexFixed" wordHexFixed_list word64HexFixed + + , testBuilderConstr "int8HexFixed" int8HexFixed_list int8HexFixed + , testBuilderConstr "int16HexFixed" int16HexFixed_list int16HexFixed + , testBuilderConstr "int32HexFixed" int32HexFixed_list int32HexFixed + , testBuilderConstr "int64HexFixed" int64HexFixed_list int64HexFixed + + , testBuilderConstr "floatHexFixed" floatHexFixed_list floatHexFixed + , testBuilderConstr "doubleHexFixed" doubleHexFixed_list doubleHexFixed + ] + where + enlarge (n, e) = n ^ (abs (e `mod` (50 :: Integer))) + +testsFloating :: [TestTree] +testsFloating = + [ testMatches "f2sBasic" floatDec show + [ ( 0.0 , "0.0" ) + , ( (-0.0) , "-0.0" ) + , ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + , ( (0/0) , "NaN" ) + , ( (1/0) , "Infinity" ) + , ( (-1/0) , "-Infinity" ) + ] + , testMatches "f2sSubnormal" floatDec show + [ ( 1.1754944e-38 , "1.1754944e-38" ) + ] + , testMatches "f2sMinAndMax" floatDec show + [ ( coerceWord32ToFloat 0x7f7fffff , "3.4028235e38" ) + , ( coerceWord32ToFloat 0x00000001 , "1.0e-45" ) + ] + , testMatches "f2sBoundaryRound" floatDec show + [ ( 3.355445e7 , "3.3554448e7" ) + , ( 8.999999e9 , "8.999999e9" ) + , ( 3.4366717e10 , "3.4366718e10" ) + ] + , testMatches "f2sExactValueRound" floatDec show + [ ( 3.0540412e5 , "305404.13" ) + , ( 8.0990312e3 , "8099.0313" ) + ] + , testMatches "f2sTrailingZeros" floatDec show + -- Pattern for the first test: 00111001100000000000000000000000 + [ ( 2.4414062e-4 , "2.4414063e-4" ) + , ( 2.4414062e-3 , "2.4414063e-3" ) + , ( 4.3945312e-3 , "4.3945313e-3" ) + , ( 6.3476562e-3 , "6.3476563e-3" ) + ] + , testMatches "f2sRegression" floatDec show + [ ( 4.7223665e21 , "4.7223665e21" ) + , ( 8388608.0 , "8388608.0" ) + , ( 1.6777216e7 , "1.6777216e7" ) + , ( 3.3554436e7 , "3.3554436e7" ) + , ( 6.7131496e7 , "6.7131496e7" ) + , ( 1.9310392e-38 , "1.9310392e-38" ) + , ( (-2.47e-43) , "-2.47e-43" ) + , ( 1.993244e-38 , "1.993244e-38" ) + , ( 4103.9003 , "4103.9004" ) + , ( 5.3399997e9 , "5.3399997e9" ) + , ( 6.0898e-39 , "6.0898e-39" ) + , ( 0.0010310042 , "1.0310042e-3" ) + , ( 2.8823261e17 , "2.882326e17" ) + , ( 7.0385309e-26 , "7.038531e-26" ) + , ( 9.2234038e17 , "9.223404e17" ) + , ( 6.7108872e7 , "6.710887e7" ) + , ( 1.0e-44 , "1.0e-44" ) + , ( 2.816025e14 , "2.816025e14" ) + , ( 9.223372e18 , "9.223372e18" ) + , ( 1.5846085e29 , "1.5846086e29" ) + , ( 1.1811161e19 , "1.1811161e19" ) + , ( 5.368709e18 , "5.368709e18" ) + , ( 4.6143165e18 , "4.6143166e18" ) + , ( 0.007812537 , "7.812537e-3" ) + , ( 1.4e-45 , "1.0e-45" ) + , ( 1.18697724e20 , "1.18697725e20" ) + , ( 1.00014165e-36 , "1.00014165e-36" ) + , ( 200.0 , "200.0" ) + , ( 3.3554432e7 , "3.3554432e7" ) + , ( 2.0019531 , "2.0019531" ) + , ( 2.001953 , "2.001953" ) + ] + , testExpected "f2sScientific" (formatFloat scientific) + [ ( 0.0 , "0.0e0" ) + , ( 8388608.0 , "8.388608e6" ) + , ( 1.6777216e7 , "1.6777216e7" ) + , ( 3.3554436e7 , "3.3554436e7" ) + , ( 6.7131496e7 , "6.7131496e7" ) + , ( 1.9310392e-38 , "1.9310392e-38" ) + , ( (-2.47e-43) , "-2.47e-43" ) + , ( 1.993244e-38 , "1.993244e-38" ) + , ( 4103.9003 , "4.1039004e3" ) + , ( 0.0010310042 , "1.0310042e-3" ) + , ( 0.007812537 , "7.812537e-3" ) + , ( 200.0 , "2.0e2" ) + , ( 2.0019531 , "2.0019531e0" ) + , ( 2.001953 , "2.001953e0" ) + ] + , testMatches "f2sLooksLikePowerOf5" floatDec show + [ ( coerceWord32ToFloat 0x5D1502F9 , "6.7108864e17" ) + , ( coerceWord32ToFloat 0x5D9502F9 , "1.3421773e18" ) + , ( coerceWord32ToFloat 0x5e1502F9 , "2.6843546e18" ) + ] + , testMatches "f2sOutputLength" floatDec show + [ ( 1.0 , "1.0" ) + , ( 1.2 , "1.2" ) + , ( 1.23 , "1.23" ) + , ( 1.234 , "1.234" ) + , ( 1.2345 , "1.2345" ) + , ( 1.23456 , "1.23456" ) + , ( 1.234567 , "1.234567" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.23456735e-36 , "1.23456735e-36" ) + ] + , testMatches "d2sBasic" doubleDec show + [ ( 0.0 , "0.0" ) + , ( (-0.0) , "-0.0" ) + , ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + , ( (0/0) , "NaN" ) + , ( (1/0) , "Infinity" ) + , ( (-1/0) , "-Infinity" ) + ] + , testMatches "d2sSubnormal" doubleDec show + [ ( 2.2250738585072014e-308 , "2.2250738585072014e-308" ) + ] + , testMatches "d2sMinAndMax" doubleDec show + [ ( (coerceWord64ToDouble 0x7fefffffffffffff) , "1.7976931348623157e308" ) + , ( (coerceWord64ToDouble 0x0000000000000001) , "5.0e-324" ) + ] + , testMatches "d2sTrailingZeros" doubleDec show + [ ( 2.98023223876953125e-8 , "2.9802322387695313e-8" ) + ] + , testMatches "d2sRegression" doubleDec show + [ ( (-2.109808898695963e16) , "-2.1098088986959632e16" ) + , ( 4.940656e-318 , "4.940656e-318" ) + , ( 1.18575755e-316 , "1.18575755e-316" ) + , ( 2.989102097996e-312 , "2.989102097996e-312" ) + , ( 9.0608011534336e15 , "9.0608011534336e15" ) + , ( 4.708356024711512e18 , "4.708356024711512e18" ) + , ( 9.409340012568248e18 , "9.409340012568248e18" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.9430376160308388e16 , "1.9430376160308388e16" ) + , ( (-6.9741824662760956e19), "-6.9741824662760956e19" ) + , ( 4.3816050601147837e18 , "4.3816050601147837e18" ) + ] + , testExpected "d2sScientific" (formatDouble scientific) + [ ( 0.0 , "0.0e0" ) + , ( 1.2345678 , "1.2345678e0" ) + , ( 4.294967294 , "4.294967294e0" ) + , ( 4.294967295 , "4.294967295e0" ) + ] + , testGroup "d2sStandard" + [ testCase "specific" do + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3 , "12.30" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.345 , "12.34" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3451 , "12.35" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0050 , "0.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.999 , "1000.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.199 , "999.20" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.999 , "1.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0051 , "0.01" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0056 , "0.006" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0096 , "0.010" ) + singleMatches (formatDouble (standard 5)) (flip (showFFloat (Just 5)) []) ( 12.345 , "12.34500" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0 , "0.000" ) + , testProperty "standard N" \(NonNegative p, d :: Double) -> (LC.unpack . toLazyByteString) (formatDouble (standard p) d) === showFFloat (Just p) d "" + ] + , testMatches "d2sLooksLikePowerOf5" doubleDec show + [ ( (coerceWord64ToDouble 0x4830F0CF064DD592) , "5.764607523034235e39" ) + , ( (coerceWord64ToDouble 0x4840F0CF064DD592) , "1.152921504606847e40" ) + , ( (coerceWord64ToDouble 0x4850F0CF064DD592) , "2.305843009213694e40" ) + , ( (coerceWord64ToDouble 0x4400000000000004) , "3.689348814741914e19" ) + + -- here v- is a power of 5 but since we don't accept bounds there is no + -- interesting trailing behavior + , ( (coerceWord64ToDouble 0x440000000000301d) , "3.6893488147520004e19" ) + ] + , testMatches "d2sOutputLength" doubleDec show + [ ( 1 , "1.0" ) + , ( 1.2 , "1.2" ) + , ( 1.23 , "1.23" ) + , ( 1.234 , "1.234" ) + , ( 1.2345 , "1.2345" ) + , ( 1.23456 , "1.23456" ) + , ( 1.234567 , "1.234567" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.23456789 , "1.23456789" ) + , ( 1.234567895 , "1.234567895" ) + , ( 1.2345678901 , "1.2345678901" ) + , ( 1.23456789012 , "1.23456789012" ) + , ( 1.234567890123 , "1.234567890123" ) + , ( 1.2345678901234 , "1.2345678901234" ) + , ( 1.23456789012345 , "1.23456789012345" ) + , ( 1.234567890123456 , "1.234567890123456" ) + , ( 1.2345678901234567 , "1.2345678901234567" ) + + -- Test 32-bit chunking + , ( 4.294967294 , "4.294967294" ) + , ( 4.294967295 , "4.294967295" ) + , ( 4.294967296 , "4.294967296" ) + , ( 4.294967297 , "4.294967297" ) + , ( 4.294967298 , "4.294967298" ) + ] + , testMatches "d2sMinMaxShift" doubleDec show + [ ( (ieeeParts2Double False 4 0) , "1.7800590868057611e-307" ) + -- 32-bit opt-size=0: 49 <= dist <= 49 + -- 32-bit opt-size=1: 28 <= dist <= 49 + -- 64-bit opt-size=0: 50 <= dist <= 50 + -- 64-bit opt-size=1: 28 <= dist <= 50 + , ( (ieeeParts2Double False 6 maxMantissa) , "2.8480945388892175e-306" ) + -- 32-bit opt-size=0: 52 <= dist <= 53 + -- 32-bit opt-size=1: 2 <= dist <= 53 + -- 64-bit opt-size=0: 53 <= dist <= 53 + -- 64-bit opt-size=1: 2 <= dist <= 53 + , ( (ieeeParts2Double False 41 0) , "2.446494580089078e-296" ) + -- 32-bit opt-size=0: 52 <= dist <= 52 + -- 32-bit opt-size=1: 2 <= dist <= 52 + -- 64-bit opt-size=0: 53 <= dist <= 53 + -- 64-bit opt-size=1: 2 <= dist <= 53 + , ( (ieeeParts2Double False 40 maxMantissa) , "4.8929891601781557e-296" ) + -- 32-bit opt-size=0: 57 <= dist <= 58 + -- 32-bit opt-size=1: 57 <= dist <= 58 + -- 64-bit opt-size=0: 58 <= dist <= 58 + -- 64-bit opt-size=1: 58 <= dist <= 58 + , ( (ieeeParts2Double False 1077 0) , "1.8014398509481984e16" ) + -- 32-bit opt-size=0: 57 <= dist <= 57 + -- 32-bit opt-size=1: 57 <= dist <= 57 + -- 64-bit opt-size=0: 58 <= dist <= 58 + -- 64-bit opt-size=1: 58 <= dist <= 58 + , ( (ieeeParts2Double False 1076 maxMantissa) , "3.6028797018963964e16" ) + -- 32-bit opt-size=0: 51 <= dist <= 52 + -- 32-bit opt-size=1: 51 <= dist <= 59 + -- 64-bit opt-size=0: 52 <= dist <= 52 + -- 64-bit opt-size=1: 52 <= dist <= 59 + , ( (ieeeParts2Double False 307 0) , "2.900835519859558e-216" ) + -- 32-bit opt-size=0: 51 <= dist <= 51 + -- 32-bit opt-size=1: 51 <= dist <= 59 + -- 64-bit opt-size=0: 52 <= dist <= 52 + -- 64-bit opt-size=1: 52 <= dist <= 59 + , ( (ieeeParts2Double False 306 maxMantissa) , "5.801671039719115e-216" ) + -- 32-bit opt-size=0: 49 <= dist <= 49 + -- 32-bit opt-size=1: 44 <= dist <= 49 + -- 64-bit opt-size=0: 50 <= dist <= 50 + -- 64-bit opt-size=1: 44 <= dist <= 50 + , ( (ieeeParts2Double False 934 0x000FA7161A4D6e0C) , "3.196104012172126e-27" ) + ] + , testMatches "d2sSmallIntegers" doubleDec show + [ ( 9007199254740991.0 , "9.007199254740991e15" ) + , ( 9007199254740992.0 , "9.007199254740992e15" ) + + , ( 1.0e+0 , "1.0" ) + , ( 1.2e+1 , "12.0" ) + , ( 1.23e+2 , "123.0" ) + , ( 1.234e+3 , "1234.0" ) + , ( 1.2345e+4 , "12345.0" ) + , ( 1.23456e+5 , "123456.0" ) + , ( 1.234567e+6 , "1234567.0" ) + , ( 1.2345678e+7 , "1.2345678e7" ) + , ( 1.23456789e+8 , "1.23456789e8" ) + , ( 1.23456789e+9 , "1.23456789e9" ) + , ( 1.234567895e+9 , "1.234567895e9" ) + , ( 1.2345678901e+10 , "1.2345678901e10" ) + , ( 1.23456789012e+11 , "1.23456789012e11" ) + , ( 1.234567890123e+12 , "1.234567890123e12" ) + , ( 1.2345678901234e+13 , "1.2345678901234e13" ) + , ( 1.23456789012345e+14 , "1.23456789012345e14" ) + , ( 1.234567890123456e+15 , "1.234567890123456e15" ) + + -- 10^i + , ( 1.0e+0 , "1.0" ) + , ( 1.0e+1 , "10.0" ) + , ( 1.0e+2 , "100.0" ) + , ( 1.0e+3 , "1000.0" ) + , ( 1.0e+4 , "10000.0" ) + , ( 1.0e+5 , "100000.0" ) + , ( 1.0e+6 , "1000000.0" ) + , ( 1.0e+7 , "1.0e7" ) + , ( 1.0e+8 , "1.0e8" ) + , ( 1.0e+9 , "1.0e9" ) + , ( 1.0e+10 , "1.0e10" ) + , ( 1.0e+11 , "1.0e11" ) + , ( 1.0e+12 , "1.0e12" ) + , ( 1.0e+13 , "1.0e13" ) + , ( 1.0e+14 , "1.0e14" ) + , ( 1.0e+15 , "1.0e15" ) + + -- 10^15 + 10^i + , ( (1.0e+15 + 1.0e+0) , "1.000000000000001e15" ) + , ( (1.0e+15 + 1.0e+1) , "1.00000000000001e15" ) + , ( (1.0e+15 + 1.0e+2) , "1.0000000000001e15" ) + , ( (1.0e+15 + 1.0e+3) , "1.000000000001e15" ) + , ( (1.0e+15 + 1.0e+4) , "1.00000000001e15" ) + , ( (1.0e+15 + 1.0e+5) , "1.0000000001e15" ) + , ( (1.0e+15 + 1.0e+6) , "1.000000001e15" ) + , ( (1.0e+15 + 1.0e+7) , "1.00000001e15" ) + , ( (1.0e+15 + 1.0e+8) , "1.0000001e15" ) + , ( (1.0e+15 + 1.0e+9) , "1.000001e15" ) + , ( (1.0e+15 + 1.0e+10) , "1.00001e15" ) + , ( (1.0e+15 + 1.0e+11) , "1.0001e15" ) + , ( (1.0e+15 + 1.0e+12) , "1.001e15" ) + , ( (1.0e+15 + 1.0e+13) , "1.01e15" ) + , ( (1.0e+15 + 1.0e+14) , "1.1e15" ) + + -- Largest power of 2 <= 10^(i+1) + , ( 8.0 , "8.0" ) + , ( 64.0 , "64.0" ) + , ( 512.0 , "512.0" ) + , ( 8192.0 , "8192.0" ) + , ( 65536.0 , "65536.0" ) + , ( 524288.0 , "524288.0" ) + , ( 8388608.0 , "8388608.0" ) + , ( 67108864.0 , "6.7108864e7" ) + , ( 536870912.0 , "5.36870912e8" ) + , ( 8589934592.0 , "8.589934592e9" ) + , ( 68719476736.0 , "6.8719476736e10" ) + , ( 549755813888.0 , "5.49755813888e11" ) + , ( 8796093022208.0 , "8.796093022208e12" ) + , ( 70368744177664.0 , "7.0368744177664e13" ) + , ( 562949953421312.0 , "5.62949953421312e14" ) + , ( 9007199254740992.0 , "9.007199254740992e15" ) + + -- 1000 * (Largest power of 2 <= 10^(i+1)) + , ( 8.0e+3 , "8000.0" ) + , ( 64.0e+3 , "64000.0" ) + , ( 512.0e+3 , "512000.0" ) + , ( 8192.0e+3 , "8192000.0" ) + , ( 65536.0e+3 , "6.5536e7" ) + , ( 524288.0e+3 , "5.24288e8" ) + , ( 8388608.0e+3 , "8.388608e9" ) + , ( 67108864.0e+3 , "6.7108864e10" ) + , ( 536870912.0e+3 , "5.36870912e11" ) + , ( 8589934592.0e+3 , "8.589934592e12" ) + , ( 68719476736.0e+3 , "6.8719476736e13" ) + , ( 549755813888.0e+3 , "5.49755813888e14" ) + , ( 8796093022208.0e+3 , "8.796093022208e15" ) + ] + , testMatches "f2sPowersOf10" floatDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Float | x <- [-46..39 :: Int]] + , testMatches "d2sPowersOf10" doubleDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Double | x <- [-324..309 :: Int]] + ] + where + testExpected :: TestName -> (a -> Builder) -> [(a, String)] -> TestTree + testExpected name dec = testCase name . traverse_ \(x, ref) -> LC.unpack (toLazyByteString (dec x)) @?= ref + + singleMatches :: (a -> Builder) -> (a -> String) -> (a, String) -> Assertion + singleMatches dec refdec (x, ref) = do + LC.unpack (toLazyByteString (dec x)) @?= refdec x + refdec x @?= ref + + testMatches :: TestName -> (a -> Builder) -> (a -> String) -> [(a, String)] -> TestTree + testMatches name dec refdec = testCase name . traverse_ (singleMatches dec refdec) + + maxMantissa = (1 `shiftL` 53) - 1 :: Word64 + + ieeeParts2Double :: Bool -> Int -> Word64 -> Double + ieeeParts2Double sign expo mantissa = + coerceWord64ToDouble $ (fromIntegral (fromEnum sign) `shiftL` 63) .|. (fromIntegral expo `shiftL` 52) .|. mantissa + + asShowRef x = (x, show x) + +testsChar8 :: [TestTree] +testsChar8 = + [ testBuilderConstr "charChar8" char8_list char8 + , testBuilderConstr "stringChar8" (foldMap char8_list) string8 + ] + +testsUtf8 :: [TestTree] +testsUtf8 = + [ testBuilderConstr "charUtf8" charUtf8_list charUtf8 + , testBuilderConstr "stringUtf8" (foldMap charUtf8_list) stringUtf8 + ] diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs.rej b/tests/builder/Data/ByteString/Builder/Tests.hs.rej new file mode 100644 index 000000000..5ee188b31 --- /dev/null +++ b/tests/builder/Data/ByteString/Builder/Tests.hs.rej @@ -0,0 +1,31 @@ +@@ -641,8 +641,9 @@ + where + enlarge (n, e) = n ^ (abs (e `mod` (50 :: Integer))) + +-testsFloating :: [TestTree] +-testsFloating = ++testsFloating :: TestTree ++testsFloating = testGroup "RealFloat" ++ [ testGroup "Float" + [ testMatches "f2sNonNumbersAndZero" floatDec show + [ ( 0.0 , "0.0" ) + , ( (-0.0) , "-0.0" ) +@@ -742,7 +743,9 @@ + , ( 1.2345678 , "1.2345678" ) + , ( 1.23456735e-36 , "1.23456735e-36" ) + ] +- , testMatches "d2sBasic" doubleDec show ++ ] ++ , testGroup "Double" ++ [ testMatches "d2sBasic" doubleDec show + [ ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + ] +@@ -962,6 +965,7 @@ + , testMatches "d2sPowersOf10" doubleDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Double | x <- [-324..309 :: Int]] + ] ++ ] + where + testExpected :: TestName -> (a -> Builder) -> [(a, String)] -> TestTree + testExpected name dec = testCase name . traverse_ \(x, ref) -> LC.unpack (toLazyByteString (dec x)) @?= ref