From 0d15485856fff57826ac98ef87e3771fcceb953c Mon Sep 17 00:00:00 2001
From: William Rusnack <williamrusnack@gmail.com>
Date: Thu, 11 Jan 2024 14:50:26 -0500
Subject: [PATCH] removed specialStr and replaced with improved version of
 toCharsNonNumbersAndZero

---
 Data/ByteString/Builder/RealFloat.hs          | 82 +++++++++++--------
 Data/ByteString/Builder/RealFloat/D2S.hs      | 22 +----
 Data/ByteString/Builder/RealFloat/F2S.hs      | 23 +-----
 Data/ByteString/Builder/RealFloat/Internal.hs | 46 ++++++++---
 4 files changed, 87 insertions(+), 86 deletions(-)

diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs
index 285c506e5..7b846ea85 100644
--- a/Data/ByteString/Builder/RealFloat.hs
+++ b/Data/ByteString/Builder/RealFloat.hs
@@ -2,6 +2,8 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 -- |
 -- Module      : Data.ByteString.Builder.RealFloat
 -- Copyright   : (c) Lawrence Wu 2021
@@ -85,6 +87,8 @@ import GHC.Int (Int32)
 import GHC.Show (intToDigit)
 import Data.Char (ord)
 import GHC.Prim (Word8#)
+import Data.Proxy (Proxy(Proxy))
+import Data.Bits (Bits)
 
 -- | Returns a rendered Float. Matches `show` in displaying in standard or
 -- scientific notation
@@ -213,36 +217,56 @@ formatDouble = formatFloating
 {-# INLINABLE formatFloating #-}
 {-# SPECIALIZE formatFloating :: FloatFormat -> Float -> Builder #-}
 {-# SPECIALIZE formatFloating :: FloatFormat -> Double -> Builder #-}
-formatFloating ::
+formatFloating :: forall a mw ew.
   -- a
-  ( ToS a
+  --( ToS a
+  ( ToD a
   , Num a
   , Ord a
   , RealFloat a
-  , Intermediate a
+  , R.ExponentBits a
+  , R.MantissaBits a
+  , R.CastToWord a
   -- mantissa
   , mw ~ R.MantissaWord a
   , R.Mantissa mw
   , ToWord64 mw
   , R.DecimalLength mw
+  -- exponent
+  , ew ~ R.ExponentWord a
+  , Num ew
+  , Bits ew
+  , Integral ew
   ) => FloatFormat -> a -> Builder
 formatFloating = \case
-    FGeneric eE prec (minExpo,maxExpo) ss -> \f -> let (R.FloatingDecimal m e) = intermediate f; e' = toInt e + R.decimalLength m in
-      case specialStr ss f of
+    FGeneric eE prec (minExpo,maxExpo) ss -> \f -> let
+      (sign, mantissa, expo) = R.breakdown f
+      (R.FloatingDecimal m e) = toD @a mantissa expo
+      e' = toInt e + R.decimalLength m
+      in case R.toCharsNonNumbersAndZero ss f of
         Just b -> b
-        Nothing ->
-          if e' >= minExpo && e' <= maxExpo
-             then sign f `mappend` showStandard (toWord64 m) e' prec
-             else BP.primBounded (R.toCharsScientific eE (f < 0) m e) ()
-    FScientific eE ss -> toS eE ss
-    FStandard prec ss -> \f -> let (R.FloatingDecimal m e) = intermediate f; e' = toInt e + R.decimalLength m in
-      case specialStr ss f of
+        Nothing -> let
+          (R.FloatingDecimal m e) = toD @a mantissa expo
+          e' = toInt e + R.decimalLength m
+          in if e' >= minExpo && e' <= maxExpo
+             then prependSign f `mappend` showStandard (toWord64 m) e' prec
+             else BP.primBounded (R.toCharsScientific eE sign m e) ()
+    FScientific eE ss ->  \f -> let
+      (sign, mantissa, expo) = R.breakdown f
+      (R.FloatingDecimal m e) = toD @a mantissa expo
+      e' = toInt e + R.decimalLength m
+      in case R.toCharsNonNumbersAndZero ss f of
         Just b -> b
-        Nothing -> sign f `mappend` showStandard (toWord64 m) e' prec
-
-class Intermediate a where intermediate :: a -> R.FloatingDecimal a
-instance Intermediate Float where intermediate = RF.f2Intermediate
-instance Intermediate Double where intermediate = RD.d2Intermediate
+        Nothing -> let
+          (R.FloatingDecimal m e) = toD @a mantissa expo
+          in BP.primBounded (R.toCharsScientific eE sign m e) ()
+    FStandard prec ss -> \f -> case R.toCharsNonNumbersAndZero ss f of
+        Just b -> b
+        Nothing -> let
+          (sign, mantissa, expo) = R.breakdown f
+          (R.FloatingDecimal m e) = toD @a mantissa expo
+          e' = toInt e + R.decimalLength m
+          in  prependSign f `mappend` showStandard (toWord64 m) e' prec
 
 class ToInt a where toInt :: a -> Int
 instance ToInt Int32 where toInt = R.int32ToInt
@@ -251,9 +275,13 @@ class ToWord64 a where toWord64 :: a -> Word64
 instance ToWord64 Word32 where toWord64 = R.word32ToWord64
 instance ToWord64 Word64 where toWord64 = id
 
-class ToS a where toS :: Word8# -> R.SpecialStrings -> a -> Builder
-instance ToS Float where toS = RF.f2s
-instance ToS Double where toS = RD.d2s
+--class ToS a where toS :: Word8# -> R.SpecialStrings -> a -> Builder
+--instance ToS Float where toS = RF.f2s
+--instance ToS Double where toS = RD.d2s
+
+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 #-}
@@ -266,18 +294,8 @@ 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 => R.SpecialStrings -> a -> Maybe Builder
-specialStr R.SpecialStrings{..} f
-  | isNaN f          = Just $ string7 nan
-  | isInfinite f     = Just $ if f < 0 then string7 negativeInfinity else string7 positiveInfinity
-  | isNegativeZero f = Just $ string7 negativeZero
-  | f == 0           = Just $ string7 positiveZero
-  | otherwise        = Nothing
+prependSign :: RealFloat a => a -> Builder
+prependSign f = if f < 0 then char7 '-' else mempty
 
 -- | Returns a list of decimal digits in a Word64
 digits :: Word64 -> [Int]
diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs
index ffe8793c3..bf69b0448 100644
--- a/Data/ByteString/Builder/RealFloat/D2S.hs
+++ b/Data/ByteString/Builder/RealFloat/D2S.hs
@@ -11,8 +11,7 @@
 -- Implementation of double-to-string conversion
 
 module Data.ByteString.Builder.RealFloat.D2S
-    ( d2s
-    , d2Intermediate
+    ( d2d
     ) where
 
 import Control.Arrow (first)
@@ -188,22 +187,3 @@ d2d m e =
            else trimNoTrailing state
       !e' = e10 + removed
    in FloatingDecimal output e'
-
--- | Dispatches to `d2d` or `d2dSmallInt` and applies the given formatters
-{-# INLINE d2s' #-}
-d2s' :: (Bool -> Word64 -> Int32 -> a) -> (Bool -> MantissaWord Double -> ExponentWord Double -> Maybe a) -> Double -> a
-d2s' formatter specialFormatter d =
-  let (sign, mantissa, expo) = breakdown d
-  in flip fromMaybe (specialFormatter sign mantissa expo) $
-         let FloatingDecimal m e = d2d mantissa expo
-               in formatter sign m e
-
--- | Render a Double in scientific notation
-d2s :: Word8# -> SpecialStrings -> Double -> Builder
-d2s eE ss d = primBounded (d2s' (toCharsScientific eE) (toCharsNonNumbersAndZero @Double Proxy ss) d) ()
-
--- | Returns the decimal representation of a Double. NaN and Infinity will
--- return `FloatingDecimal 0 0`
-{-# INLINE d2Intermediate #-}
-d2Intermediate :: Double -> FD
-d2Intermediate = d2s' (const FloatingDecimal) (\_ _ _ -> Nothing)
diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs
index da68aa727..ba53b28f0 100644
--- a/Data/ByteString/Builder/RealFloat/F2S.hs
+++ b/Data/ByteString/Builder/RealFloat/F2S.hs
@@ -10,8 +10,7 @@
 -- Implementation of float-to-string conversion
 
 module Data.ByteString.Builder.RealFloat.F2S
-    ( f2s
-    , f2Intermediate
+    ( f2d
     ) where
 
 import Control.Arrow (first)
@@ -141,6 +140,7 @@ f2dLT e2' u v w =
 
 -- | Returns the decimal representation of the given mantissa and exponent of a
 -- 32-bit Float using the ryu algorithm.
+{-# INLINABLE f2d #-}
 f2d :: Word32 -> Word32 -> FD
 f2d m e =
   let float_mantissa_bits = mantissaBits @Float
@@ -169,22 +169,3 @@ f2d m e =
            else trimNoTrailing state
       !e' = e10 + removed
    in FloatingDecimal output e'
-
--- | Dispatches to `f2d` and applies the given formatters
-{-# INLINE f2s' #-}
-f2s' :: (Bool -> Word32 -> Int32 -> a) -> (Bool -> MantissaWord Float -> ExponentWord Float -> Maybe a) -> Float -> a
-f2s' formatter specialFormatter f =
-  let (sign, mantissa, expo) = breakdown f
-  in flip fromMaybe (specialFormatter sign mantissa expo) $
-         let FloatingDecimal m e = f2d mantissa expo
-               in formatter sign m e
-
--- | Render a Float in scientific notation
-f2s :: Word8# -> SpecialStrings -> Float -> Builder
-f2s eE ss f = primBounded (f2s' (toCharsScientific eE) (toCharsNonNumbersAndZero @Float Proxy ss) f) ()
-
--- | Returns the decimal representation of a Float. NaN and Infinity will
--- return `FloatingDecimal 0 0`
-{-# INLINE f2Intermediate #-}
-f2Intermediate :: Float -> FD
-f2Intermediate = f2s' (const FloatingDecimal) (\_ _ _ -> Nothing)
diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs
index 7ce4dd306..fb1536f36 100644
--- a/Data/ByteString/Builder/RealFloat/Internal.hs
+++ b/Data/ByteString/Builder/RealFloat/Internal.hs
@@ -6,9 +6,9 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BlockArguments #-}
 -- |
 -- Module      : Data.ByteString.Builder.RealFloat.Internal
 -- Copyright   : (c) Lawrence Wu 2021
@@ -77,6 +77,7 @@ module Data.ByteString.Builder.RealFloat.Internal
     , breakdown
     , MantissaBits(..)
     , ExponentBits(..)
+    , CastToWord(..)
 
     , module Data.ByteString.Builder.RealFloat.TableGenerator
     ) where
@@ -84,11 +85,12 @@ module Data.ByteString.Builder.RealFloat.Internal
 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)
@@ -260,25 +262,44 @@ boundString s = boundedPrim maxEncodedLength $ const (pokeAll s)
 --   * biased exponent = all 0 bits.
 --   * fraction = all 0 bits.
 {-# INLINABLE toCharsNonNumbersAndZero #-}
-{-# SPECIALIZE toCharsNonNumbersAndZero :: Proxy Float -> SpecialStrings -> Bool -> MantissaWord Float -> ExponentWord Float -> Maybe (BoundedPrim ()) #-}
-{-# SPECIALIZE toCharsNonNumbersAndZero :: Proxy Double -> SpecialStrings -> Bool -> MantissaWord Double -> ExponentWord Double -> Maybe (BoundedPrim ()) #-}
+{-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Float -> Maybe Builder #-}
+{-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Double -> Maybe Builder #-}
 toCharsNonNumbersAndZero :: forall a mw ew.
   ( ExponentBits a
+  , mw ~ MantissaWord a
   , Ord mw
   , Num mw
+  , ew ~ ExponentWord a
   , Ord ew
   , Num ew
   , Bits ew
   , Integral ew
-  ) => Proxy a -> SpecialStrings -> Bool -> mw -> ew -> Maybe (BoundedPrim ())
-toCharsNonNumbersAndZero _ SpecialStrings{..} sign mantissa expo =
-  if (expo == mask (exponentBits @a)) || (expo == 0 && mantissa == 0)
-  then Just $ boundString $ if
-    | mantissa > 0 -> nan
-    | expo > 0 -> if sign then negativeInfinity else positiveInfinity
-    | sign -> negativeZero
-    | otherwise -> positiveZero
+
+  , ExponentBits a
+  , MantissaBits a
+  , CastToWord a
+  , mw ~ MantissaWord a
+  , Bits mw
+  , Eq mw
+  , Integral mw
+  , ew ~ ExponentWord a
+  , Num ew
+
+  ) => SpecialStrings -> a -> Maybe Builder
+toCharsNonNumbersAndZero SpecialStrings{..} f = flip BP.primBounded () . boundString <$>
+  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
@@ -912,6 +933,7 @@ breakdown :: forall a mw ew.
   , Bits mw
   , Eq mw
   , Integral mw
+  , ew ~ ExponentWord a
   , Num ew
   ) => a -> (Bool, mw, ew)
 breakdown f = (sign, mantissa, expo)