From 62d507054ae2260ec5c25ca7c05eed081ff89368 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Wed, 27 Dec 2023 18:22:20 -0500 Subject: [PATCH] added SpecialStrings for customizing special IEEE754 float values --- Data/ByteString/Builder/RealFloat.hs | 41 ++++++++++++++++--- Data/ByteString/Builder/RealFloat/D2S.hs | 4 +- Data/ByteString/Builder/RealFloat/F2S.hs | 4 +- Data/ByteString/Builder/RealFloat/Internal.hs | 24 ++++++++--- 4 files changed, 58 insertions(+), 15 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 1fef16a0b..52e2404a4 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -62,7 +62,11 @@ module Data.ByteString.Builder.RealFloat -- * Custom formatting , formatFloat + , formatFloatSpecials , formatDouble + , formatDoubleSpecials + , R.SpecialStrings(..) + , defaultSpecialStrings , FloatFormat , standard , standardDefaultPrecision @@ -161,7 +165,15 @@ data FormatMode -- @since 0.11.2.0 {-# INLINABLE formatFloat #-} formatFloat :: FloatFormat -> Float -> Builder -formatFloat (MkFloatFormat fmt prec) = \f -> +formatFloat = formatFloatSpecials defaultSpecialStrings + +-- TODO: support precision argument for FGeneric and FScientific +-- | Like formatFloat but allows custom strings for the special values. +-- +-- @since ?????? +{-# INLINABLE formatFloatSpecials #-} +formatFloatSpecials :: R.SpecialStrings -> FloatFormat -> Float -> Builder +formatFloatSpecials ss (MkFloatFormat fmt prec) = \f -> let (RF.FloatingDecimal m e) = RF.f2Intermediate f e' = R.int32ToInt e + R.decimalLength9 m in case fmt of @@ -172,13 +184,12 @@ formatFloat (MkFloatFormat fmt prec) = \f -> 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 + FScientific -> RF.f2s ss f FStandard -> case specialStr f of Just b -> b Nothing -> sign f `mappend` showStandard (R.word32ToWord64 m) e' prec --- TODO: support precision argument for FGeneric and FScientific -- | Returns a rendered Double. Returns the \'shortest\' representation in -- scientific notation and takes an optional precision argument in standard -- notation. Also see `doubleDec`. @@ -204,7 +215,15 @@ formatFloat (MkFloatFormat fmt prec) = \f -> -- @since 0.11.2.0 {-# INLINABLE formatDouble #-} formatDouble :: FloatFormat -> Double -> Builder -formatDouble (MkFloatFormat fmt prec) = \f -> +formatDouble = formatDoubleSpecials defaultSpecialStrings + +-- TODO: support precision argument for FGeneric and FScientific +-- | Like formatDouble but allows custom strings for the special values. +-- +-- @since ?????? +{-# INLINABLE formatDoubleSpecials #-} +formatDoubleSpecials :: R.SpecialStrings -> FloatFormat -> Double -> Builder +formatDoubleSpecials ss (MkFloatFormat fmt prec) = \f -> let (RD.FloatingDecimal m e) = RD.d2Intermediate f e' = R.int32ToInt e + R.decimalLength17 m in case fmt of @@ -215,12 +234,24 @@ formatDouble (MkFloatFormat fmt prec) = \f -> 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 + FScientific -> RD.d2s ss f FStandard -> case specialStr f of Just b -> b Nothing -> sign f `mappend` showStandard m e' prec +-- | Standard strings for special values of IEEE754 floating point values. +-- +-- @since ????? +defaultSpecialStrings :: R.SpecialStrings +defaultSpecialStrings = R.SpecialStrings + { R.nan = "NaN" + , R.positiveInfinity = "Infinity" + , R.negativeInfinity = "-Infinity" + , R.positiveZero = "0.0e0" + , R.negativeZero = "-0.0e0" + } + -- | Char7 encode a 'Char'. {-# INLINE char7 #-} char7 :: Char -> Builder diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs index fb5e8c008..b70baf36a 100644 --- a/Data/ByteString/Builder/RealFloat/D2S.hs +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -222,8 +222,8 @@ d2s' formatter specialFormatter d = in formatter sign m e -- | Render a Double in scientific notation -d2s :: Double -> Builder -d2s d = primBounded (d2s' toCharsScientific toCharsNonNumbersAndZero d) () +d2s :: SpecialStrings -> Double -> Builder +d2s ss d = primBounded (d2s' toCharsScientific (toCharsNonNumbersAndZero ss) d) () -- | Returns the decimal representation of a Double. NaN and Infinity will -- return `FloatingDecimal 0 0` diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs index 1e64e83ff..230ab673b 100644 --- a/Data/ByteString/Builder/RealFloat/F2S.hs +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -202,8 +202,8 @@ f2s' formatter specialFormatter f = in formatter sign m e -- | Render a Float in scientific notation -f2s :: Float -> Builder -f2s f = primBounded (f2s' toCharsScientific toCharsNonNumbersAndZero f) () +f2s :: SpecialStrings -> Float -> Builder +f2s ss f = primBounded (f2s' toCharsScientific (toCharsNonNumbersAndZero ss) f) () -- | Returns the decimal representation of a Float. NaN and Infinity will -- return `FloatingDecimal 0 0` diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index ccfdc5cc0..74461be60 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -22,6 +22,7 @@ module Data.ByteString.Builder.RealFloat.Internal ( mask , NonNumbersAndZero(..) + , SpecialStrings(..) , toCharsNonNumbersAndZero , decimalLength9 , decimalLength17 @@ -69,6 +70,7 @@ module Data.ByteString.Builder.RealFloat.Internal import Control.Monad (foldM) import Data.Bits (Bits(..), FiniteBits(..)) +import Data.Bool (bool) import Data.ByteString.Internal (c2w) import Data.ByteString.Builder.Prim.Internal (BoundedPrim, boundedPrim) import Data.ByteString.Builder.RealFloat.TableGenerator @@ -246,13 +248,23 @@ data NonNumbersAndZero = NonNumbersAndZero , mantissa_non_zero :: Bool } +-- | Strings for special values of IEEE754 floating point values. +-- +-- @since ????? +data SpecialStrings = SpecialStrings + { nan :: String + , positiveInfinity :: String + , negativeInfinity :: String + , positiveZero :: String + , negativeZero :: String + } deriving Show + -- | 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 "" +toCharsNonNumbersAndZero :: SpecialStrings -> NonNumbersAndZero -> BoundedPrim () +toCharsNonNumbersAndZero SpecialStrings{..} NonNumbersAndZero{..} + | mantissa_non_zero = boundString nan + | exponent_all_one = bool (boundString positiveInfinity) (boundString negativeInfinity) negative + | otherwise = bool (boundString positiveZero) (boundString negativeZero) negative -- | 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